#!/usr/bin/env perl
# from --- show you who your mail is from

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

# $Id: from,v 1.101 2017/09/12 18:53:34 friedman Exp $

# Commentary:
# Code:

use 5.10.0;  # Not tested with anything older.  YMMV.
use strict;
use Carp;
use Getopt::Long;
use Pod::Usage;
use Socket;

our $version = "3.3.0";

our @optional_modules
  = qw( Date::Parse
        Time::ParseDate
        Time::Timezone
        Text::CharWidth
     );

our %opt;
our %SSL_options;
our ($SOCKLIB, $SOCKLIB_SSL);

sub DEBUG (&;@); # prototype
*DEBUG = \&From::Debug::DEBUG;

use constant MIN_BLOCKSIZE => 4096;

sub parse_options
{
  my $help = -1;

  %opt =
    ( format          => "%-3{FMSGNO} %-20.20{FROMTO}  %-0.32Date  %Subject\n",
      date_format     => sub { strftime_iso8601 ("%Y-%m-%d  %H:%M:%S%z", @_) },
      tzdate          => 'sender',
      parsep          => 1,
      onelinep        => 1,

      match_header    => [],
      interesting     => [],
      message_numbers => [],
      bodylines       => -1,

      user            => default_user(),
      columns         => output_columns(),

      c_timeout       => 10,
      prefer_stunnel  => 1,
      stunnel_prog    => $ENV{STUNNEL} || "stunnel",
      addrfamily      => AF_UNSPEC, # use either ipv6 or ipv4

      batch_size      => 64,        # set to 0 to retrieve all at once
      block_size      => 2**19,     # read 512k at a time
    );

  my @match_header_default
    = map { $_, "Resent-$_" } qw(Sender From To Cc Date Subject);

  my @interesting_default
    = (qw(From To Apparently-To Cc Newsgroups Subject Date Reply-To));

  # Precedence for defs (highest->lowest):
  # Try $FROMRCPL and only $FROMRCPL if defined.
  # Otherwise search $XDG_CONFIG_HOME and $HOME for .fromrc.pl.
  my @rc = (defined $ENV{FROMRCPL}
            ? $ENV{FROMRCPL}
            : map { "$ENV{$_}/.fromrc.pl"
                  } grep { exists $ENV{$_}
                         } (qw(XDG_CONFIG_HOME HOME)));
  for my $fromrc (@rc)
    {
      next unless -f $fromrc;
      do $fromrc;
      _error ($fromrc, $@) if ($@ ne "" && $@ !~ /not return a true value/);
      last;
    }

  local *ARGV = \@{$_[0]}; # modify our local arglist, not real ARGV.

  my $parser = Getopt::Long::Parser->new;
  $parser->configure (qw(bundling autoabbrev no_require_order no_ignore_case));

  my $succ = $parser->getoptions
    ('h|help|usage+'             =>      \$help,
     'D|debug+'                  =>      \$::debug,
     'W|warnings!'               =>      \$^W,

     'c|count-only'              =>      \$opt{countp},
     'e|envelope'                =>      \$opt{envelopep},

     'p|parse!'                  =>      \$opt{parsep},
     'P'                         => sub { $opt{parsep} = 0 },

     'u|unread'                  =>      \$opt{search_unread},
     'n|message-numbers=s@'      =>       $opt{message_numbers}, #arrayraf
     'batch-size=i'              =>      \$opt{batch_size},
     'block-size=i'              =>      \$opt{block_size},

     '1|one-line-headers'        =>      \$opt{onelinep},
     '2|multi-line-headers'      => sub { $opt{onelinep}     = 0 },
     'a|all-headers'             => sub { $opt{all_headers}  = 1;
                                          $opt{onelinep}     = 0 },
     'I|interesting-headers=s@'  =>       $opt{interesting},  # arrayref

     'E|extract:-1'              => sub { $opt{extractp}     = 1;
                                          $opt{bodylines}    = $_[1] },

     'if|imap-folders'           => sub { $opt{imap_list}    = 'f' },
     'is|imap-subscriptions'     => sub { $opt{imap_list}    = 's' },

     'C|columns=i'               =>      \$opt{columns},
     'f|format=s'                => sub { $opt{format}       = interpolate ($_[1]) },
     'd|date-format:s'           => sub { $opt{date_format}  = interpolate ($_[1]) },
     'T|time-zone|tz=s'          =>      \$opt{tzdate},
     'utc|gmt'                   => sub { $opt{tzdate}       = 'UTC' },
     'folder-time-zone=s'        =>      \$opt{folder_time_zone},

     'i|ignore-case!'            =>      \$opt{ignore_case},
     'mmr|match-me-regexp=s'     =>      \$opt{match_me_regexp},
     'mhr|match-header-regexp=s' =>      \$opt{match_hdr_regexp},
     'mtr|match-text-regexp=s'   =>      \$opt{match_txt_regexp},

     'M|match-header=s@'         =>       $opt{match_header}, # arrayref
     'm|match-text=s'            =>      \$opt{match_text},
     's|sender=s'                => sub { $opt{match_header} = [qw(From Sender)];
                                          $opt{match_text}   = $_[1] },

     # don't autovivify SSL_options values; wrap them in a delayed eval thunk
     'ssl-ca-file=s'             => sub { $SSL_options{SSL_ca_file} = $_[1] },
     'ssl-ca-path=s'             => sub { $SSL_options{SSL_ca_path} = $_[1] },
     'ssl-version=s'             => sub { $SSL_options{SSL_version} = $_[1] },

     'S|starttls'                =>      \$opt{starttls},
     'ssl-verify-hostname'       =>      \$opt{ssl_verify_hostname},
     'ssl-no-verify'             =>      \$opt{ssl_no_verify},
     'prefer-perl-ssl!'          => sub { $opt{prefer_stunnel} = ! $_[1] },
     'prefer-stunnel!'           => sub { $opt{prefer_stunnel} = $_[1] },
     'stunnel-program=s'         =>      \$opt{stunnel_prog},
     'connect-timeout|timeout'   =>      \$opt{c_timeout},
     'prefer-socklib=s'          => sub { $opt{prefer_socklib} .= $_[1] . ' '},
     '4|ipv4-only'               => sub { $opt{addrfamily} = AF_INET  },
     '6|ipv6-only'               => sub { $opt{addrfamily} = AF_INET6 },
     'U|user=s'                  =>      \$opt{user},
     'password=s'                =>      \$opt{pass}, # don't use!

     'utf8|utf-8!'               =>      \$opt{utf8},
     'V|version',                =>      \$opt{show_version},
    );

  pod2usage (-exitstatus => 1, -verbose => 0)     unless $succ;
  pod2usage (-exitstatus => 0, -verbose => $help) if $help >= 0;

  show_version() if $opt{show_version};

  $opt{pass}            = $ENV{FROMPASS}     unless defined $opt{pass};
  $opt{match_me_regexp} = default_me_match() unless defined $opt{match_me_regexp};

  if ($opt{match_hdr_regexp})
    {
      if ($opt{match_hdr_regexp} =~ /(?:^\{BODY\}$|\|\{BODY\}|\{BODY\}\|)/)
        {
          $opt{match_hdr_regexp} =~ s///g;
          $opt{search_body_p} = 1;
        }
      $opt{match_hdr_regexp} = qr/$opt{match_hdr_regexp}/i;
    }
  else
    {
      $opt{match_header} = (@{$opt{match_header}}
                            ? [map { split (/[\s,]+/, $_) } @{$opt{match_header}}]
                            : \@match_header_default);

      for (my $i = 0; $i < @{$opt{match_header}}; $i++)
        {
          next unless $opt{match_header}->[$i] eq '{BODY}';
          splice (@{$opt{match_header}}, $i--, 1);
          $opt{search_body_p} = 1;
        }

      my $hre = sprintf ('^(?:%s)$', join ("|", @{$opt{match_header}}));
      $opt{filter_hdr_regexp} = qr/$hre/i;
    }

  if ($opt{match_text})
    {
      my $tre = quotemeta ($opt{match_text});
      $opt{filter_txt_regexp} = $opt{ignore_case} ? qr/$tre/i : qr/$tre/;
    }

  # Pre-compile any remaining defined regexps
  map { ($opt{$_} &&= $opt{ignore_case} ? qr/$opt{$_}/i : qr/$opt{$_}/)
      } qw(match_txt_regexp match_me_regexp);

  $opt{format_parsed} = parse_format_string ($opt{format});
  {
    my @hdata = @{$opt{format_parsed}};
    shift @hdata;
    # This is different from wanted_headers() because this includes literal
    # pseudoheader names, but not the actual headers added in order to
    # implement pseudoheaders.
    $opt{literal_header} = { map { $_ => 1 } @hdata };
  }

  $opt{interesting} = (@{$opt{interesting}}
                       ? [map { split (/[\s,]+/, $_) } @{$opt{interesting}}]
                       : \@interesting_default);

  $opt{simple_count_p} = ($opt{countp} && ! (   $opt{search_unread}
                                             || $opt{match_txt_regexp}
                                             || $opt{match_text}
                                             || @{$opt{message_numbers}}));

  # Convert strings like "US/Pacific" to "-0500".
  my $z = $opt{folder_time_zone};
  if (defined $z && $z !~ /^[+-]\d{4}$/)
    {
      use POSIX qw(strftime);
      local $ENV{TZ} = $z;
      if ($z =~ /^([+-]?)(\d+)$/)  # normalize numeric offsets
        {
          my ($sign, $off) = ($1, $2);
          $off = "0$off" if length ($off) < 4;
          $off .= "0" while length ($off) < 4;
          $off =~ s/(\d\d)(\d\d)$/$1:$2/;
          $sign =~ y/+-/-+/;  # Not sure why sign reversal needed
          $ENV{TZ} = "UTC" . $sign . $off;
        }
      $opt{folder_time_zone} = strftime ("%z", localtime (time));
    }

  # Don't allow a blocksize less than this.
  $opt{block_size} = MIN_BLOCKSIZE if $opt{block_size} < MIN_BLOCKSIZE;

  ::DEBUG { {state=>1}, \%opt, \%SSL_options };
}

sub show_version
{
  print "from ", $version, "\n";

  if ($::debug)
    {
      $opt{need_net} = $opt{need_ssl} = 1;
      net_init();
      $SOCKLIB     ||= "(none loaded)";
      $SOCKLIB_SSL ||= "(none loaded)";

      printf "\nUsing %s v%vd\n", $^X, $^V;
      print "\nSocket library:       $SOCKLIB\n";
      print "Socket library (SSL): $SOCKLIB_SSL\n";
      print "\nOptional modules:\n";
      map { eval "use $_";
            printf("\t%-20s %s\n", $_, ($@ ? "no" : "yes"));
          } @optional_modules;
    }
  exit (0);
}

sub net_init
{
  @_ = (@ARGV ? @ARGV : default_spool_file()) unless @_;
  map { $opt{need_net} = 1 if m=^(?:imap|pop3)s?://=;
        $opt{need_ssl} = 1 if m=^(?:imap|pop3)s://=
      } @_;
  From::Socket::__init() if $opt{need_net} || $opt{need_ssl};
}

sub main
{
  parse_options (\@_);

  @_ = default_spool_file() unless @_;
  net_init (@_);

  my $exitstat = 0;
  my $want_headers = wanted_headers();

  my %meta = ('{tmsgno}' => 0);
  for my $folder (@_)
    {
      $meta{'{folder}'} = $folder;
      $meta{'{fmsgno}'} = 0;

      my $mbox = From::Mailbox->new ($folder, wanted_headers => $want_headers);
      unless ($mbox)
        {
          $exitstat = 1;
          next;
        }

      if ($opt{imap_list} && ref($mbox) =~ /imap/i)
        {
          print_imap_list ($mbox);
          next;
        }

      if ($opt{simple_count_p})
        {
          my $n = $mbox->message_count (1);
          if (@_ > 1) { printf ("%-10d %s\n",  $n, $folder) }
          else        { print $n, "\n" }
          next;
        }

      # If counting filtered ranges, this will just accumulate
      # a match count.  Otherwise, it will print a summary.
      $mbox->map_over_msgnos
        (sub { my $result = process_message ($mbox, \%meta, $_[0]);
               $mbox->uncache_message ($_[0]);
               return $result;
             });
      if ($opt{countp})
        {
          my $n = $mbox->{message_match_count} || 0;
          if (@_ > 1) { printf ("%-10d %s\n",  $n, $folder) }
          else        { print $n, "\n" }
        }
    }
  exit ($exitstat);
}

sub process_message
{
  my ($mbox, $meta, $fmsgno) = @_;

  #::DEBUG { @_ } @_;
  if ($opt{search_unread})
    {
      my %flags = $mbox->flags ($fmsgno);
      return 1 if %flags && $flags{read};
    }

  my ($msg, $header, $envelope);
  if (($opt{match_text} || $opt{match_txt_regexp})
        && !$mbox->{server_side_filtered})
    {
      if ($opt{search_body_p})
        {
          local $opt{extractp} = 1;
          $msg = $mbox->retrieve ($fmsgno) || return;
        }
      else
        {
          $msg = $mbox->retrieve ($fmsgno) || return;
        }
      ::DEBUG { $msg };

      $envelope = $mbox->envelope ($fmsgno);
      $header   = From::Header->new ($msg, $meta, $envelope);
      # Return 1 so that processing of future messages will continue.
      return 1 unless $header->filter_matches_p;
    }

  # We don't want to count messages that don't exist.
  unless (exists $mbox->{message_range})
    {
      $msg ||= $mbox->retrieve ($fmsgno);
      return unless $msg;
    }

  if ($opt{countp})
    {
      $mbox->{message_match_count}++;
      return 1;
    }

  $meta->{'{tmsgno}'}++;
  $meta->{'{fmsgno}'} = $fmsgno;

  if ($opt{envelopep})
    {
      print $mbox->envelope_string ($fmsgno), "\n";
      return 1;
    }

  $msg ||= $mbox->retrieve ($fmsgno);
  return unless $msg;
  if ($opt{extractp} || $opt{all_headers})
    {
      my $env_str = $mbox->envelope_string ($fmsgno);
      print_message ($msg, $meta, $header, $env_str);
    }
  else
    {
      $meta->{'{octets}'} = $mbox->message_size ($fmsgno)
        if (exists $opt{literal_header}->{'{octets}'});

      $envelope ||= $mbox->envelope ($fmsgno);
      $header   ||= From::Header->new ($msg, $meta, $envelope);
      print_message_summary ($msg, $header);
    }
  return 1;
}

sub print_message
{
  my ($msgref, $meta, $header, $envelope_string) = @_;
  local *_ = $msgref; # bind @_ to ref

  if ($opt{all_headers})
    {
      map { utf8::decode ($_);
            utf8::encode ($_);
          } @_ if $opt{utf8};

      print $envelope_string, "\n", @_;
      print "\n" if @_ > 1;
      return 1;
    }

  print $envelope_string, "\n";
  $header ||= From::Header->new ($msgref, $meta);
  my $contents = $opt{onelinep} ? 'contents1' : 'contents';
  map { my $name = $_;
        map { my $s = sprintf ("%s: %s\n", $name, $_);
              if ($opt{utf8})
                {
                  utf8::decode ($s);
                  utf8::encode ($s);
                }
              print $s;
            } $header->$contents ($_, 1);
      } $header->names (@{$opt{interesting}});
  print "\n";

  if (@_ > 1)
    {
      if ($opt{utf8})
        {
          utf8::decode ($_[1]);
          utf8::encode ($_[1]);
        }
      print $_[1], "\n";
    }
}

sub print_message_summary
{
  my ($msg, $header) = @_;

  ::DEBUG { $msg, $header };

  my ($fmt, @name) = @{$opt{format_parsed}};
  my $fn = $opt{parsep} ? 'allparsed1' : 'allcontents1';
  map { $_ = $header->$fn ($_) } @name;

  my $s;
  if ($opt{utf8})
    {
      unless (*mbswidth{CODE})
        {
          eval "use Text::CharWidth qw(mbswidth)";
          *mbswidth = sub { length $_[0] } if $@;
        }

      # Need to change locale to a utf8 one in order to use mbswidth.
      use POSIX qw(:locale_h setlocale);
      my $lang = setlocale (LC_CTYPE);
      $lang = $1 if $lang =~ /^([^.]+)\./;
      $lang = "en_US" if !$lang || $lang eq "C";
      setlocale (LC_CTYPE, "$lang.UTF-8");

      map { utf8::decode ($_);
            my $pad = mbswidth ($_) - length ($_);
            $_ .= ("\0" x $pad) if $pad > 0;
          } @name;

      $s = sprintf ($fmt, @name);
      $s =~ s/\0+//g;
      $s =~ s/^(.{$opt{columns}}).*/$1/mgo if $opt{columns};
      utf8::encode ($s);
      setlocale (LC_CTYPE, "");
    }
  else
    {
      $s = sprintf ($fmt, @name);
      $s =~ s/^(.{$opt{columns}}).*/$1/mgo if $opt{columns};
    }
  print $s;
}

sub print_imap_list
{
  my $mbox = shift;

  my $method = $opt{imap_list} eq 's' ? 'lsub' : 'list';
  my $list = $mbox->$method ('', '*');
  return unless $list;

  (my $uri = $mbox->{uri}) =~ s=:\*\@=@=; # strip out any blanked out password
  my $url = substr ($uri, 0, length ($uri) - length ($mbox->{path}));

  for my $elt (@$list)
    {
      my $flag = $elt->[2];
      next if $flag->{'\Noselect'};
      printf "%s%s\n", $url, $elt->[1];
    }
}


# This is an optimization for IMAP folders to reduce the amount of
# bandwidth needed for header retrieval.  Other protocols either don't
# support it (pop3) or would not be particularly efficient (mbox files) so
# those classes just ignore this data.
sub wanted_headers
{
  return if $opt{all_headers};
  return if $opt{match_txt_regexp};

  my @headers;
  if ($opt{extractp})
    {
      push @headers, @{$opt{interesting}};
    }
  else
    {
      my @x = @{$opt{format_parsed}};
      shift @x; # discard fmt
      map { if    ($_ eq '{fromto}') { push @headers, 'from', 'to' }
            elsif ($_ !~ /^\{/)      { push @headers, $_ }
          } @x;
    }
  return wantarray ? @headers : \@headers;
}

sub parse_format_string
{
  local $_ = shift;
  my $fmt;
  my @header;

  my %format_token = ( '{tmsgno}' => 'd',
                       '{fmsgno}' => 'd',
                       '{octets}' => 'd',
                     );
  my $start = 0;
  my $hchars = '[\x21-\x24\x26-\x39\x3b-\x5b\x5d-\x7e]';
  my $re = qr/(?:(?:|[^%]|(?:%%))*)%-?[\d.]*((?:(?:\\\\)+|(?:%%|$hchars))+)/;
  while (/$re/gc)
    {
      my $h_orig = $1;
      (my $h = lc $h_orig) =~ s=%%=%=g;
      push @header, $h;

      my $c = defined $format_token{$h} ? $format_token{$h} : 's';
      $fmt .= substr ($_, $start, pos ($_) - $start - length ($h_orig)) . $c;
      $start = pos ($_);
    }
  $fmt .= substr ($_, pos ($_));

  unshift @header, $fmt;
  map { s/\\(.)/$1/g } @header; # unescape \'d chars
  return wantarray ? @header : \@header;
}

sub max
{
  my $x = shift;
  map { $x = $_ if $_ > $x } @_;
  return $x;
}

sub output_columns
{
  my $fh = shift || *STDOUT{IO};

  my $fileno = fileno ($fh);
  if (-t $fileno)
    {
      unless (defined &TIOCGWINSZ)
        {
          # The .ph files do not define the sizeof variable used in a lot
          # of macros.  These are typical sizes, but not guaranteed to be
          # portably correct.
          our %sizeof = ( 'struct winsize' => 8,
                          'struct ttysize' => 4, );
          local *__OPTIMIZE__ = sub { 1; }; # silence warnings in v5.22
          for my $ph (map { $_ . ".ph"
                          } (qw(sys/ioctl sys/termios sys/ttycom ttold)))
            {
              local $@;  # save and restore prior exception
              eval { require "$ph" };
              last if defined &TIOCGWINSZ;
            }
        }
      if (defined &TIOCGWINSZ)
        {
          my $result;
          if (ioctl ($fh, &TIOCGWINSZ, my $data = ''))
            {
              my ($rows, $cols, $xpix, $ypix) = unpack ('S4', $data);
              $result = $cols;
            }
          return max (0, $result - 1) if defined $result;
        }

      my $stty = ($fileno == 1 ? `stty -a` : `stty -a 0<&$fileno`);
      return max (0, $1 - 1) if $stty =~ /columns (\d+);/;
    }
  return defined $ENV{COLUMNS} ? max (0, $ENV{COLUMNS} - 1) : 0;
}

sub default_user
{
  for my $var (qw(FROMUSER USER LOGNAME))
    {
      my $val = $ENV{$var};
      return $val if defined $val && $val ne '';
    }
  return scalar getpwuid ($<);
}

sub default_me_match
{
  my $username = $opt{user};
  my @passwd = $username ? getpwnam ($username) : getpwuid ($>);
  return unless @passwd;

  (my $match = $passwd[6]) =~ s/,.*//;
  $match =~ s/^\s*(.*?)\s*$/$1/;
  $match =~ s/(\W)/\\$1/g;
  return $match;
}

sub default_spool_file
{
  return $ENV{FROMMAIL} if defined $ENV{FROMMAIL};
  return $ENV{MAIL}     if defined $ENV{MAIL};

  my $user = shift || $opt{user};
  my $spooldirs = (shift || [qw(/var/mail /var/spool/mail)]);
  for my $spool (@$spooldirs)
    {
      my $file = join ("/", $spool, $user);
      return $file if -f $file;
    }
  return;
}

# Using `eval' at runtime is pretty questionable, but there's no other
# reliable way to honor all the escape sequences that perl understands in
# interpolated strings, especially unicode escape sequences. Besides, we
# read (and execute) anything in the .fromrc.pl config.
sub interpolate
{
  local $_ = shift;
  return $_ unless /\\/;

  my $result = eval "\"$_\"";
  _error ("\"$_\"", $@) if $@;
  return $result;
}

our $errors_fatal   =  0;
our $debug          =  0;
(my $progname = $0) =~ s=.*/==;

# check for readability on non-blocking file handle
# Usage: canread ($handle, $timeout)
sub canread
{
  vec (my $v = '', fileno ($_[0]), 1) = 1;
  my $n = select ($v, undef, undef, $_[1]);

  ::DEBUG { { res => $n, mask => unpack ('B*', $v) } };
  ::_error ("select", $!) if !defined $n || $n < 0;
  return $n;
}

sub _verbose
{
  return unless $^W;
  my $msg = join (": ", $progname, @_);
  $msg .= "\n" unless substr ($msg, -1, 1) eq "\n";
  print STDERR $msg;
  return;
}

sub _error
{
  my $msg = join (": ", $progname, "error", @_);
  $msg .= "\n" unless substr ($msg, -1, 1) eq "\n";

  if ($errors_fatal)
    {
      my $pkg = __PACKAGE__;
      local $Carp::CarpInternal{$pkg} = 1; # don't show this pkg in backtrace
      local $Carp::Verbose = $debug;
      croak $msg;
    }

  print STDERR $msg;
  return;
}

# For rc file convenience.
sub command_output
{
  chomp (local $_ = `@_`);
  return $_;
}

# Make it convenient for users to use this in their .fromrc.pl
*strftime_iso8601 = \&From::Timestamp::strftime_iso8601;


package From::Socket;

use strict;
use Socket;
use Symbol;

my $stunnel_class = q(From::Socket::Stunnel);
my $ssl_class     = q(IO::Socket::SSL);

our $SSL_ERROR    = ""; # Will be overridden by ssl_class if loaded.

our $SSL_version_default = 'TLSv1.2'; # 2016-07-04

# These only contain mappings for values that need to be adjusted.
# If not listed here, they will be passed through as-is.
# The keys are case-insensitive for our purposes.
our %SSL_version_normalize
  = ( 'From::Socket::Stunnel' =>
      { 'tlsv1_1' => 'TLSv1.1',  'tlsv11' => 'TLSv1.1',
        'tlsv1_2' => 'TLSv1.2',  'tlsv12' => 'TLSv1.2',
        'tlsv1_3' => 'TLSv1.3',  'tlsv13' => 'TLSv1.3',
      },

      'IO::Socket::SSL' =>
      { 'tlsv1.1' => 'TLSv1_1',  'tlsv11' => 'TLSv1_1',
        'tlsv1.2' => 'TLSv1_2',  'tlsv12' => 'TLSv1_2',
        'tlsv1.3' => 'TLSv1_3',  'tlsv13' => 'TLSv1_3',
      },
    );

my %socklib = ( inet6 => q(IO::Socket::INET6),      # supports ipv4, ipv6
                inet4 => q(IO::Socket::INET),       # supports ipv4
                inet  => q(IO::Socket::INET),       # supports ipv4
                ip    => q(IO::Socket::IP),         # supports ipv4, ipv6
              );

sub __init
{
  local $errors_fatal = 1;

  if ($opt{need_net})
    {
      $opt{prefer_socklib} ||= "inet6 ip inet"; # try ipv6-supporting first
      unless (ref $opt{prefer_socklib})
        {
          my @slibs = map { $socklib{lc $_} || $_
                          } split (/[,\s]+/, $opt{prefer_socklib});
          $opt{prefer_socklib} = \@slibs;
        }

      for my $try (@{$opt{prefer_socklib}})
        {
          $SOCKLIB = $try;
          eval "use $try";
          last unless $@;
        }
    }

  if ($opt{need_ssl} || $opt{starttls})
    {
      if ($opt{prefer_stunnel} && $stunnel_class->have_stunnel)
        {
          $SOCKLIB_SSL = $stunnel_class;
        }
      else
        {
          my $ssl_debug = $::debug ? "qw(:DEFAULT debug3)" : "";
          eval "use $ssl_class $ssl_debug";
          if ($@)
            {
              ::_error ("Cannot find native perl ssl library or $opt{stunnel_prog}")
                unless $stunnel_class->have_stunnel;
              $SOCKLIB_SSL = $stunnel_class;
            }
          else
            {
              $SOCKLIB_SSL = $ssl_class;
            }
        }
    }
}

sub _connect_internal
{
  my $self  = shift;
  my $class = shift;

  return ::_error ($self->{uri}, "$class does not support IPv6")
      if ($opt{addrfamily} == AF_INET6 && $class eq $socklib{inet4});

  my $fh;
  my %p = (Type    => SOCK_STREAM,
           Domain  => $opt{addrfamily}, # ignored by IO::Socket::INET
           Timeout => $opt{c_timeout},
           @_);

  # There is nothing elegant about this at all.
  if ($class eq $stunnel_class)
    {
      my %s = $self->_ssl_args;
      ::DEBUG { $class, \%s, \%p };
      $fh = $class->new ( self => $self, %s, %p);
    }
  else
    {
      ::DEBUG { $class, \%p };
      $fh = $class->new (%p);
    }
  unless ($fh)
    {
      my $errstr = $@ || $SSL_ERROR;
      ::_error ($self->{uri}, $errstr);
      return;
    }

  $fh->autoflush (1);
  $fh->blocking (1);
  return $fh;
}

sub connect
{
  my $self = shift;
  my $class = ($opt{starttls} && $SOCKLIB_SSL eq $stunnel_class
               ? $SOCKLIB_SSL
               : $SOCKLIB);

  $self->_connect_internal ($class, @_);
}

sub connect_ssl
{
  my $self = shift;
  my $fh = $self->_connect_internal ($SOCKLIB_SSL, $self->_ssl_args, @_);
  ::DEBUG { ({state=>1},
                   $fh->get_cipher,
                   $fh->dump_peer_certificate,
            ) if $fh->can ('get_cipher');
          } if $fh;
  $self->{tls_started} = 1 if $fh;
  return $fh;
}

sub starttls
{
  my $self = shift;
  return 1 if $self->{tls_started};

  if ($SOCKLIB_SSL->can ('start_SSL'))
    {
      my %sslargs = ($self->_ssl_args);
      ::DEBUG { {state=>1}, 'STARTTLS', \%sslargs };
      unless ($SOCKLIB_SSL->start_SSL ($self->{fh}, %sslargs))
        {
          ::_error ($self->{uri}, $SOCKLIB_SSL->errstr ());
          $self->disconnect;
          return 0;
        }
      $self->{tls_started} = 1;
    }
}

sub mkpipe
{
  my @pair = $SOCKLIB->socketpair (AF_UNIX, SOCK_STREAM, PF_UNSPEC);
  map { $_->autoflush (1) } @pair;
  return @pair;
}

sub _ssl_args
{
  my $self = shift;

  (my $proto = $self->{proto}) =~ s=s$==;

  my %param = (SSL_version         => $SSL_version_default,
               SSL_verify_mode     => ($opt{ssl_no_verify} ? 0 : 2|4),
               SSL_verify_callback => sub { $self->_ssl_verifycb (@_) },
               %SSL_options,
              );

  if ($param{SSL_version})
    {
      my $ver = lc $param{SSL_version};
      $param{SSL_version} = $SSL_version_normalize{$SOCKLIB_SSL}->{$ver}
        if defined $SSL_version_normalize{$SOCKLIB_SSL}->{$ver};
    }

  # Native SSL class in v5.18 does not permit both SSL_ca_file and
  # SSL_ca_path to be specified.
  # If neither is specified, prefer a ca path over a ca file.
  unless ($SOCKLIB_SSL eq $ssl_class
          && (defined $param{SSL_ca_file} || defined $param{SSL_ca_path}))
    {
      unless (defined $param{SSL_ca_file})
        {
          my $cafile = $self->_ssl_cafile;
          $param{SSL_ca_file} = $cafile if $cafile;
        }

      unless (defined $param{SSL_ca_path})
        {
          if (defined $param{SSL_ca_file})
            {
              ($param{SSL_ca_path} = $param{SSL_ca_file}) =~ s=/+[^/]*$=/=;
              delete $param{SSL_ca_file} if $SOCKLIB_SSL eq $ssl_class;
            }
          else
            {
              my @cadirs = $self->_ssl_certdirs;
              $param{SSL_ca_path} = $cadirs[0] if @cadirs;
            }
        }
    }
  return %param;
}

sub _ssl_certdirs
{
  my $self = shift;

  my @found;
  map { push @found, $_ if -d $_
      } qw(/etc/pki/tls/certs
           /etc/ssl/certs
           /etc/ssl );
  return @found;
}

sub _ssl_cafile
{
  my $self = shift;

  map { my $dir = $_;
        map { return "$dir/$_" if -r "$dir/$_"
            } qw(ca-bundle.crt
                 ca-root.crt
                 cert.pem );
      } (@_ || $self->_ssl_certdirs);
  return; # void
}

# Callback
sub _ssl_verifycb
{
  my $self = shift;
  my ($valid, $certstore_addr, $attrib_str, $liberrstr, $cert_addr) = @_;
  ::DEBUG { {state=>1}, @_ } @_;

  return 1      if $opt{ssl_no_verify};
  return $valid if $valid || !$opt{ssl_verify_hostname};

   my $fh    = $self->{fh};
  (my $proto = $self->{proto}) =~ s=s$==;

  my $vfn = qualify_to_ref (q(verify_hostname_of_cert), ref $fh || $SOCKLIB_SSL);
  return &{*$vfn{CODE}} ($self->{host}, $cert_addr, $proto);
}

sub spawn
{
  my ($self, $fnchild, $fnparent) = (shift, shift, shift);
  my %param = @_;

  local $^F = 255;
  my ($rc, $wc) = $self->mkpipe () if $fnparent;
  my ($rh, $wh) = $self->mkpipe ();

  $SIG{CHLD} = q(IGNORE);
  my $pid = fork;
  unless (defined $pid)
    {
      ::_error ('fork', $!);
      exit (1);
    }
  if ($pid) # parent
    {
      &$fnparent ($wc) if defined $fnparent;
      map { close ($_) if $_ } ($rc, $wc, $wh);
    }
  else
    {
      delete $ENV{FROMPASS}; # don't expose if set
      open (STDIN,  "<&=" . fileno ($wh));
      open (STDOUT, ">&=" . fileno ($wh));
      map { close ($_) if $_ } ($rh, $wh, $wc);
      &$fnchild ($rc) if defined $fnchild;
    }
  return $rh;
}


package From::Socket::Stunnel;

use strict;
use Socket qw(:all);

our @ISA = qw(From::Socket);

my $have_stunnel_cacheresult;
my $stunnel_fips_enabled;

*new = *connect; # symbol alias

sub connect
{
  my $class = shift;
  my %param = @_;
  my $self = $param{self};

  my $re_ipaddr = qr/^(?:[0-9.]+|[0-9a-f:]+)$/i;

  my (@connect, $canon);
  if ($opt{addrfamily} == AF_UNSPEC || $param{PeerHost} =~ /$re_ipaddr/)
    {
      @connect = ($param{PeerHost});
    }
  else
    {
      # We cannot control whether stunnel uses ipv4 or ipv6, if a host name
      # has both kinds of address records.  So resolve the corresponding
      # addresses for the specified address family and direct stunnel to
      # connect to those instead.
      ($canon, @connect) = hostaddrs ($param{PeerHost});
    }
  unless (@connect)
    {
      $@ = "Host not found";
      return;
    }

  my $fnparent
    = sub { my $wc = shift;
            my @conf = ("foreground     = yes",
                        "syslog         = no",
                        "debug          = " . ($::debug ? 'debug' : 'err'),

                        "client         = yes",
                        (map { "connect        = $_:$param{PeerPort}" } @connect),
                        "TIMEOUTconnect = $param{Timeout}",

                        "ciphers        = HIGH",
                        "sslVersion     = $param{SSL_version}",
                       );
            push @conf, "fips           = no"                    if $stunnel_fips_enabled;
            push @conf, "CApath         = $param{SSL_ca_path}"   if $param{SSL_ca_path};
            push @conf, "CAfile         = $param{SSL_ca_file}"   if $param{SSL_ca_file};

            push @conf, "protocol       = $self->{proto}"
              if ($opt{starttls} && $self->{proto} !~ /s$/);

            unless ($opt{ssl_no_verify})
              {
                push @conf, "verify         = 2";
                # n.b. stunnel v5.17 won't allow this option in the global
                # section of a config.  stunnel v5.30 seems to allow it.
                if ($opt{ssl_verify_hostname})
                  {
                    push @conf, "checkHost      = $canon" if defined $canon;
                    map { push @conf, (/$re_ipaddr/
                                       ? "checkIP        = $_"
                                       : "checkHost      = $_")
                        } @connect;
                  }
              }

            ::DEBUG { @conf };
            map { print $wc $_, "\n" } @conf;

            $self->{tls_started} = 1 if $opt{starttls};
          };

  my $fnchild = sub { exec ($opt{stunnel_prog}, "-fd", fileno ($_[0]))
                        || die "$progname: exec $opt{stunnel}: $!\n";
                    };

  $class->spawn ($fnchild, $fnparent);
}

sub have_stunnel
{
  return $have_stunnel_cacheresult if defined $have_stunnel_cacheresult;

  my $class = shift;

  my $fnchild = sub { open (STDERR, ">&=" . fileno (STDOUT));
                      exec ($opt{stunnel_prog}, "-version")
                        || die "$progname: exec $opt{stunnel_prog}: $!\n";
                    };

  my $fh = $class->spawn ($fnchild);
  local $/ = undef;
  local $_ = <$fh>;
  close ($fh);

  $stunnel_fips_enabled     = $_ && /(?:SSL|TLS):\S*FIPS[ ,]/;
  $have_stunnel_cacheresult = $_ && /Global options:/;
}

sub hostaddrs
{
  return (defined &getaddrinfo
          ? ha_getaddrinfo   (@_)
          : ha_gethostbyname (@_));
}

sub ha_gethostbyname
{
  return ::_error ("Cannot obtain ipv6 addresses without getaddrinfo")
    if ($opt{addrfamily} == AF_INET6);

  my ($name, $aliases, $addrtype, $length, @addrs ) = gethostbyname ($_[0]);

  return unless @addrs;
  map { $_ = inet_ntoa ($_) } @addrs;
  return ($name, @addrs);
}

sub ha_getaddrinfo
{
  my $hints = { family   => $opt{addrfamily},
                socktype => SOCK_STREAM,
                flags    => &AI_CANONNAME | &AI_ADDRCONFIG,
              };
  my ($err, @result) = getaddrinfo ($_[0], undef, $hints);
  return if $err;

  my @addr;
  map { my ($err, $ipaddr) = getnameinfo ($_->{addr}, &NI_NUMERICHOST, &NIx_NOSERV);
        push @addr, $ipaddr unless $err;
      } @result;

  return unless @addr;
  return ($result[0]->{canonname}, @addr);
}


package From::NetCmd;

use strict;

our @ISA = qw(From::Socket);

sub new
{
  my $type = shift;
  my $class = ref ($type) || $type;

  my $self = {};
  bless $self, $class;

  my %args = @_;
  while (my ($key, $val) = each %args) { $self->{$key} = $val }
  $self->{host} ||= "localhost";
  return $self;
}

sub connect
{
  my $self = shift;

  $self->disconnect;
  my $fh = $self->SUPER::connect (PeerHost => $self->{host},
                                  PeerPort => $self->{port},
                                  @_);
  return unless $fh;
  $self->{fh} = $fh;
}

sub disconnect
{
  my $self = shift;
  my $fh = $self->{fh};
  return unless $fh;

  ::DEBUG { $self->{uri} };
  $fh->shutdown (2); # 2 == SHUTDOWN_BOTH
  $fh->close;
  delete $self->{fh};
}

sub command
{
  my $self = shift;
  { my $args = \@_;
    ::DEBUG { if (   @$args == 4 && lc $args->[1] eq 'login')
                { my @elide = @$args; $elide[3] = '*'; @elide }
              elsif (@$args == 2 && lc $args->[0] eq 'pass')
                { my @elide = @$args; $elide[1] = '*'; @elide }
              else { @$args }
            };
  }

  my $fh = $self->{fh};
  return unless $fh;
  $fh->syswrite (join (" ", @_) . "\r\n");
}


package From::Mailbox::Imap; # See rfc3501

use strict;

our @ISA = qw(From::NetCmd From::Mailbox::_Range);

sub new
{
  my $type = shift;
  my $class = ref ($type) || $type;
  my $self = $class->SUPER::new (@_);

  return unless $self->connect;

  $self->{folder_data} = {};
  $self->{imap_tagno} = 1;

  return unless $self->response_ok_p ('*');
  $self->capability ($self->analyze_response);

  return if ($opt{starttls} && !$self->starttls);
  return unless $self->login ($self->{user}, $self->{pass});

  $self->message_count ($self->{folder} || 'INBOX'); # Sets folder
  $self->{message_range} = $self->normalize_ranges (@{$opt{message_numbers}});
  $self->{batch_list}    = $self->batch_ranges (@{$self->{message_range}});

  $self->search if $opt{match_text};
  return $self;
}

sub starttls
{
  my $self = shift;
  return 1 if $self->{tls_started};
  return unless $self->command_ok_p ("STARTTLS");
  $self->SUPER::starttls ();
}

sub command_ok_p
{
  my $self = shift;
  my $tag  = $self->{imap_tag} = sprintf ("A%03d", $self->{imap_tagno}++);

  $self->command ($tag, @_);
  $self->response_ok_p ($tag);
}

sub response_ok_p
{
  my ($self, $tag) = @_;
  $tag ||= $self->{imap_tag};

  my $response = $self->response ($tag);
  $tag = quotemeta ($tag);
  return unless $response =~ /^$tag (OK|NO|BAD|PREAUTH)/m;
  return ($1 eq "OK");
}

# If called with no arguments, return last response.
# A tag argument means a new response is expected matching that tag.
sub response
{
  my $self = shift;

  ::DEBUG { @_ } @_;

  return $self->{response} unless @_;

  my $tag = quotemeta (shift || $self->{imap_tag});
  my $fh = $self->{fh};

  local $_;
  my $offset = 0;
  $fh->blocking (0);
  while (::canread ($fh))  # Don't use timeout
    {
      # Must use sysread; don't mix buffered io with select.
      my $read = $fh->sysread ($_, $opt{block_size}, $offset);
      last if defined $read && $read == 0;
      last if /^$tag (?:OK|NO|BAD|PREAUTH)(?: .*|)\n/m;
      $offset += $read;
    }
  $fh->blocking (1);

  ::DEBUG { {state=>1}, $_ };
  $self->{response} = defined $_ ? $_ : "";
}

# Amazingly cheesy recursive descent parser.
# Takes a server response and converts it into a perl data structure.
sub parse_response
{
  my $self = shift;
  local $_ = @_ ? $_[0] : $self->response;
  my $startpos = $_[1] || 0;

  my (@all, @list);
  pos $_ = $startpos;
  while ($_ =~ /\s*([[("]|\]<[\d.]+>|[])]|[^[("\s]\S*?[[]\S+|[^])\s]+)/gc)
    {
      my $pos = pos $_;
      my $beg = $pos - length ($1);
      my $s = $1;

      if ($s eq '"') { push @list, $1 if /(.*?)(?<!\\)(?>\\\\)*"/g }
      elsif ($s eq '[')
        {
          my $text = $1 if /(.*?)]/g;
          my ($data, $newpos) = $self->parse_response ($text, 0);
          push @list, $data;
        }
      elsif ($s eq '(')
        {
          my ($data, $newpos) = $self->parse_response ($_, $pos);
          pos $_ = $newpos;
          push @list, $data;
        }
      elsif ($s eq ')' || $s eq ']') { last }
      elsif ($s eq 'NIL') { push @list, undef }
      elsif ($s =~ /^\{(\d+)\}$/)
        {
          my $n = $1;
          /\r?\n/g; # skip proceeding newline
          my $text = substr ($_, pos $_, $n);
          pos $_ += $n;
          push @list, $text;
        }
      elsif ($s =~ /\[.*[^]>]$/)
        {
          my ($data, $newpos) = $self->parse_response ($_, $pos);
          pos $_ = $newpos;
          $s .= substr ($_, $pos, $newpos - $pos);
          push @list, $s;
        }
      elsif (@list && substr ($_, $beg - 1, 1) eq "\n")
        {
          push @all, [@list]; # make copy, since array is reused
          @list = $s;
        }
      else { push @list, $s }
    }
  return (\@list, pos $_) if @_ > 1;

  push @all, \@list if @list;
  ::DEBUG { {state=>1}, \@all };
  return \@all;
}

# Convert parsed response into more immediately useful data structure
# for message processing.
sub analyze_response
{
  my $self = shift;

  my $response = @_ ? $_[0] : $self->parse_response;
  $response = $self->parse_response ($response) unless ref $response;

  # If there is only the tagged response, treat it as untagged for analysis
  # purposes.  But don't use it in other cases since that might clobber
  # more valuable untagged data (e.g. SEARCH responses).
  $response->[0]->[0] = '*' if (@$response == 1
                                && exists $self->{imap_tag}
                                && $response->[0]->[0] eq $self->{imap_tag});

  my %data;
  map { local *_ = $_; # dereference @$_ into @_
        if ($_[0] eq '*')
          {
            if ($_[1] eq 'OK')
              {
                my $list = $_[2];
                if (ref $list)
                  {
                    my $label = $list->[0];
                    if (@$list > 2)
                      {
                        splice (@$list, 0, 1);
                        $data{$label} = $list;
                      }
                    else
                      {
                        $data{$label} = $list->[1];
                      }
                  }
              }
            elsif ($_[1] =~ /^(CAPABILITY|SEARCH)$/)
              {
                splice (@_, 0, 2);
                $data{$1} = \@_;
              }
            elsif ($_[1] =~ /^(?:FLAGS|NO|BAD)$/)
              { $data{$_[1]} = $_[2] }
            elsif ($_[1] =~ /^(LIST|LSUB)$/)
              {
                my %flag = map { $_ => 1 } @{$_[2]};
                push @{$data{$1}}, [$_[3], $_[4], \%flag];
              }
            elsif (@_ == 3 && $_[1] =~ /^\d+$/)
              { $data{$_[2]} = $_[1] }
            else
              {
                my $n = $_[1];
                my $list = $_[3];
                my %field;

                while (@$list)
                  {
                    my ($key, $val) = splice (@$list, 0, 2);
                    $key = $1 if $key =~ /^(?:BODY|BINARY)\[(HEADER|TEXT)/;
                    $field{$key} = $val;
                  }
                $data{$n} = \%field;
              }
          }
      } @$response;

  ::DEBUG { {state=>1}, \%data };
  return \%data;
}

# If passed hashref, use it to create capability list.
# If no arg, retrieve cap list from server and save it.
# if cap exists and has subcaps, return list of subcaps.
# Otherwise if cap exists, return that cap name.
# Otherwise, return void.
sub capability
{
  my $self = shift;
  my ($arg) = @_;

  unless (@_)
    {
      return unless $self->command_ok_p ('CAPABILITY');
      $arg = $self->analyze_response;
    }
  if (ref $arg eq 'HASH' && exists $arg->{CAPABILITY})
    {
      my %cap;
      map { if (/=/)
              {
                my ($key, $val) = split (/=/, $_, 2);
                $cap{$key}->{$val} = undef;
              }
            $cap{$_} ||= undef;
          } @{$arg->{CAPABILITY}};
      ::DEBUG { {state=>1}, \%cap };
      return $self->{CAPABILITY} = \%cap;
    }

  ::DEBUG { $arg };

  my $caps = $self->{CAPABILITY};
  if (!exists $caps->{$arg}) { return }
  elsif (ref $caps->{$arg} eq 'HASH')
    {
      my @keys = sort keys %{$caps->{$arg}};
      ::DEBUG { {state=>1}, @keys };
      return wantarray ? @keys : @keys ? \@keys : undef;
    }
  ::DEBUG { {state=>1}, $arg };
  return $arg;
}

sub search
{
  my $self = shift;

  my   @cmd = (q(SEARCH));
  push @cmd,  qw(CHARSET UTF-8) if $opt{utf8};
  push @cmd,  $self->format_message_range (@{$self->{message_range}});

  my @q = 'UNSEEN' if $opt{search_unread};

  {
    my $text = $opt{match_text};
    $text =~ s/"/\\"/g;

    my @s = map { sprintf ('HEADER "%s" "%s"', $_, $text) } @{$opt{match_header}};
    push @s, sprintf ('BODY "%s"', $text) if $opt{search_body_p};
    if (@s)
      {
        my $s = shift @s;
        map { $s = sprintf ('OR %s %s', $_, $s) } @q;
        push @q, $s;
      }
  }
  return unless @q;
  return unless $self->command_ok_p (@cmd, @q);
  $self->{server_side_filtered} = 1;

  my $resp = $self->analyze_response;
  my @found = @{$resp->{SEARCH}};

  $self->{message_range} = @found ? $self->normalize_ranges (@found) : [];
  $self->{batch_list}    = $self->batch_ranges (@{$self->{message_range}});

  ::DEBUG { { message_range => $self->{message_range},
              batch_list    => $self->{batch_list}, } };
}

sub analyze_message
{
  my ($self, $msgno) = @_;

  my $fdata = $self->{folder_data};
  return $fdata->{$msgno} if exists $fdata->{$msgno};

  my $batch = $self->in_batch ($msgno, $self->{batch_list});
  my $range = $batch ? $self->batch_string ($batch) : $msgno;

  my $headers = "BODY.PEEK[HEADER]";
  my $wanted = $self->{wanted_headers};
  if ($wanted)
    {
      my %h = map { uc ($_) => undef } (@$wanted, q(RETURN-PATH));
      $headers = sprintf ("BODY.PEEK[HEADER.FIELDS (%s)]",
                          join (" ", $self->quote (keys %h)));
    }

  my $cmd = sprintf ("FETCH %s (RFC822.SIZE INTERNALDATE ENVELOPE FLAGS %s)",
                     $range, $headers);
  return unless $self->command_ok_p ($cmd);

  my $resp = $self->analyze_response;
  while (my ($key, $val) = each %$resp)
    {
      $fdata->{$key} = $val;
    }

  return $fdata->{$msgno};
}

sub list
{
  my ($self, $prefix, $pattern) = @_;
  return unless $self->command_ok_p ("LIST", $self->quote ($prefix, $pattern));
  my $res = $self->analyze_response;
  return unless $res;
  return $res->{LIST};
}

sub lsub
{
  my ($self, $prefix, $pattern) = @_;
  return unless $self->command_ok_p ("LSUB", $self->quote ($prefix, $pattern));
  my $res = $self->analyze_response;
  return unless $res;
  return $res->{LSUB};
}

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

  unless ($self->command_ok_p ("LOGIN", $login, $pass))
    {
      ::_error ($self->{uri}, scalar $self->response);
      $self->disconnect;
      return;
    }
  $self->capability ($self->analyze_response);
  return 1;
}

sub logout
{
  my $self = shift;

  $self->command_ok_p ("LOGOUT");
  $self->disconnect;
  return;
}

sub message_count
{
  my $self = shift;

  return $self->{folder_metadata}->{EXISTS}
    if exists $self->{folder_metadata};

  $self->{folder} = $_[0] if @_;
  my $folder = $self->{folder};

  return unless $self->command_ok_p ("EXAMINE", $self->quote ($folder));
  my $data = $self->analyze_response;
  $self->{folder_metadata} = $data;

  return $data->{EXISTS} if defined $data->{EXISTS};
  return;
}

sub message_size
{
  my ($self, $msgno) = @_;

  my $data = $self->analyze_message ($msgno);
  return unless $data;
  return $data->{'RFC822.SIZE'};
}

sub flags
{
  my ($self, $msgno) = @_;

  my $data = $self->analyze_message ($msgno);
  return unless $data;

  my %trans = ( seen => ['read', 1],
              );
  my %flag;
  map { (my $f = lc $_) =~ s=^\\==;
        my $p = $trans{$f};
        my $k = $p ? $p->[0] : $f;
        my $v = $p ? $p->[1] : 1 ;
        $flag{$k} = $v;
      } @{$data->{FLAGS}};

  return unless %flag;
  ::DEBUG { {state=>1}, $msgno, \%flag };
  return wantarray ? %flag : \%flag;
}

sub envelope
{
  my ($self, $msgno) = @_;

  my $data = $self->analyze_message ($msgno);
  return unless $data;

  # Envelope data elements:
  #	0 = Date	5 = To
  #	1 = Subject	6 = Cc
  #	2 = From	7 = Bcc
  #	3 = Sender	8 = In-Reply-To
  #	4 = Reply-To	9 = Message-Id
  #
  # Address element structure:
  # 	0 = personal name
  #	1 = [SMTP] at-domain-list (source route),
  #	2 = mailbox (user) name
  #	3 = host name
  my $e = $data->{ENVELOPE}->[3]->[0];
  my $addr;
  if ($e->[2] && $e->[3])
    { ($addr = join ("@", $e->[2], $e->[3])) =~ s/[<>]//g }
  elsif ($e->[0] =~ /<(.*?)>/)
    { $addr = $1 }
  elsif ($data->{HEADER} =~ /^Return-Path:\s+<(.*?)>/m)
    # Return-Path usually matches the original SMTP envelope address.
    { $addr = 1 }
  else
    { $addr = "unknown" }

  local $opt{date_format} = "%a %b %e %H:%M:%S %Y";
  local $opt{tzdate}      = 'local';
  my $date = From::Header::_parse_date ($data->{INTERNALDATE});

  my @data = ($addr, $date);
  return wantarray ? @data : \@data;
}

sub envelope_string
{
  my $self = shift;
  my ($addr, $date) = $self->envelope (@_);
  return unless $addr && $date;
  return "From $addr  $date";
}

sub header
{
  my ($self, $msgno) = @_;
  my $data = $self->analyze_message ($msgno);
  return unless $data;
  return $data->{HEADER};
}

sub body
{
  my ($self, $msgno) = @_;

  my $data = $self->analyze_message ($msgno);
  return unless $data;
  return $data->{TEXT} if exists $data->{TEXT};

  my $bodylines = $opt{bodylines};
  return unless $opt{extractp} && $bodylines != 0;

  my $batch = $self->in_batch ($msgno, $self->{batch_list});
  my $range = $batch ? $self->batch_string ($batch) : $msgno;
  my $fdata = $self->{folder_data};

  if ($bodylines < 0)
    {
      $self->command_ok_p ("FETCH $range BODY.PEEK[TEXT]");
      my $resp = $self->analyze_response;

      while (my ($n, $elt) = each %$resp)
        {
          $fdata->{$n}->{TEXT} = $elt->{TEXT} . "\n";
        }
    }
  else
    {
      # Reasonably generous assumption?  The idea is to overshoot somewhat
      # on average, to reduce round trips.
      my $blocksize = 120 * $bodylines;
      my $offset    = 0;
      my $newlines  = 0;

      while ($range && $newlines < $bodylines)
        {
          last unless $self->command_ok_p
            ("FETCH $range BODY.PEEK[TEXT]<$offset.$blocksize>");
          my $resp = $self->analyze_response;

          # For each message, see if we've acquired enough lines.
          # Any message which isn't complete and still short will be
          # fetched again for more data.
          my @newrange;
          my ($tnl, $len);
          while (my ($n, $elt) = each %$resp)
            {
              my $text = $elt->{TEXT};
              $len  = length ($text);
              next unless $len;  # no more data for this msg

              $tnl = $newlines;
              while ($text =~ /\n/gc && ++$tnl < $bodylines) {}
              $fdata->{$n}->{TEXT} .= ($tnl < $bodylines
                                       ? $text
                                       : substr ($text, 0, pos $text));
              next if $len != $blocksize || $tnl >= $bodylines;

              push @newrange, $n;
            }
          last unless @newrange;
          $newlines = $tnl;
          $offset += $len;
          $range = $self->batch_string (scalar $self->normalize_ranges (@newrange));
        }
    }
  return $data->{TEXT};
}

sub retrieve
{
  my ($self, $msgno) = @_;
  ::DEBUG { $msgno };

  my $header = $self->header ($msgno);
  return unless $header;
  $header =~ s/\r$//gm;
  my @msg = ($header);

  my $body = $self->body ($msgno);
  if (defined $body)
    {
      $body =~ s/\r$//gm;
      push @msg, $body;
    }

  ::DEBUG { {state=>1}, @msg };
  return wantarray ? @msg : \@msg;
}

sub uncache_message
{
  my ($self, $msgno) = @_;
  delete $self->{folder_data}->{$msgno};
}

sub quote
{
  my $self = shift;
  map { my $s = $_;  # make copy
        $s =~ s/(?<!\\)(?>\\\\)*"/\\"/g;
        '"' . $s . '"';
      } @_;
}


package From::Mailbox::Imaps;

use strict;

our @ISA = qw(From::Mailbox::Imap);

sub connect
{
  my $self = shift;

  $self->disconnect;
  my $fh = $self->SUPER::connect_ssl (PeerHost => $self->{host},
                                      PeerPort => $self->{port},
                                      @_);
  return unless $fh;
  $self->{fh} = $fh;
}


package From::Mailbox::Pop3;

use strict;
use POSIX qw(:errno_h strftime);

our @ISA = qw(From::NetCmd From::Mailbox::_Range);

sub new
{
  my $type = shift;
  my $class = ref ($type) || $type;
  my $self = $class->SUPER::new (@_);

  $self->connect;
  return unless $self->{fh};

  $self->response_ok_p;
  return if $opt{starttls} && $self->{proto} eq 'pop3' && !$self->starttls;
  return unless $self->login ($self->{user}, $self->{pass});
  return $self;
}

sub starttls
{
  my $self = shift;
  return unless $self->command_ok_p ("STLS");
  $self->SUPER::starttls ();
}

sub response
{
  my $self = shift;
  my $fh = $self->{fh};
  my $line = <$fh>;
  ::DEBUG { $line };
  return $line;
}

sub response_ok_p
{
  my $self = shift;
  local $_ = $self->response;

  return 1 if /^\+OK/;
  $self->{response} = $_;
  return 0;
}

sub command_ok_p
{
  my $self = shift;
  $self->command (@_);
  $self->response_ok_p;
}

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

  return 1 if (   $self->command_ok_p ("USER", $login)
               && $self->command_ok_p ("PASS", $pass));

  $self->disconnect;
  ::_error ($self->{uri}, $self->{response});
  return;
}

sub logout
{
  my $self = shift;
  $self->command_ok_p ("QUIT");
  $self->disconnect;
  return;
}

sub message_count
{
  my $self = $_[0];

  $self->command ("STAT");
  local $_ = $self->response;
  return $1 if /^\+OK\s+(\d+)/;
  return;
}

sub message_size
{
  my ($self, $msgno) = @_;

  $self->command ("LIST ", $msgno);
  local $_ = $self->response;
  return $1 if /^\+OK\s+\d+\s+(\d+)/;
  return;
}

# No POP3 implementations I'm aware of provide any status flags.
sub flags { return }

# It's not worth trying to compute a real envelope for this protocol.
my $pop3_envdate;
sub envelope
{
  my ($self, $msgno) = @_;

  $pop3_envdate = strftime ("%a %b %e %H:%M:%S %Y", localtime) unless $pop3_envdate;

  my @data = sprintf ("m%03d\@pop3", $msgno);
  push @data, $pop3_envdate;
  return wantarray ? @data : \@data;
}

sub envelope_string
{
  my ($self, $msgno) = @_;
  my ($addr, $date) = $self->envelope (@_);
  return "From $addr  $date";
}

sub retrieve
{
  my ($self, $msgno) = @_;
  my $bodylines = $opt{bodylines};

  $self->command ($bodylines < 0
                  ? "RETR $msgno"
                  : "TOP $msgno $bodylines");
  return unless $self->response_ok_p;

  my $fh = $self->{fh};
  $fh->blocking (0);

  local $_;
  my $pos = 0;
  while (1)
    {
      my $rsz = $fh->read ($_, $opt{block_size}, $pos);
      last if (!defined $rsz
               && length $_ > 4
               && substr ($_, -4) =~ /^\.[\r\n]/m);
      $pos += $rsz if defined $rsz;
    }
  $fh->blocking (1);

  s/\r\n/\n/gm;

  my ($header, $body) = split (/\n\n/, $_, 2);
  $body =~ s/^\.//mg if defined $body;
  chop $body; # remove last newline from `.' terminator
  return [$header, $body];
}

sub uncache_message { return }  # no cache


package From::Mailbox::Pop3s;

use strict;

our @ISA = qw(From::Mailbox::Pop3);

sub connect
{
  my $self = shift;

  $self->disconnect;
  my $fh = $self->SUPER::connect_ssl (PeerHost => $self->{host},
                                      PeerPort => $self->{port},
                                      @_);
  return unless $fh;
  $self->{fh} = $fh;
}


package From::Mailbox::MboxFile;

use strict;
use IO::File;
use Fcntl qw(:DEFAULT :seek);

our @ISA = qw(From::NetCmd From::Mailbox::_Range);

# 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 <support"@speakeasy.net  Thu Dec 19 22:46:37 2002
my $re_message_delimiter = 'From\s+.*?\s+\S{3}\s+\S{3}\s+\d+\s+\d\d:\d\d';

use constant { M_EBEG => 0,
               M_HBEG => 1,
               M_HEND => 2,
               M_BEND => 3,

               M_ENV  => 4,
               M_HDR  => 5,
               M_BDY  => 6,
             };

sub new
{
  my $type = shift;
  my $class = ref ($type) || $type;

  my $self = {};
  bless $self, $class;

  my %args = @_;
  while (my ($key, $val) = each %args) { $self->{$key} = $val }

  $self->open || return;
  $self->{buffer}        = "";
  $self->{last_scanned}  = 0;
  $self->{folder_data}   = {};
  # Don't initialize this.  Lazy read unless later necessary.
  #$self->{message_range} = $self->normalize_ranges (@{$opt{message_numbers}});
  return $self;
}

sub open
{
  my $self = shift;
  my $fh = IO::File->new;

  return ::_error ("open", $_[0], $!)
      unless $fh->open ($self->{folder});

  my @st = stat $fh;
  # If regular file < 16mb, read whole thing in at once
  $self->{block_size} = $st[7] && $st[7] < 2**24 ? $st[7] : $opt{block_size};

  $self->{stat} = \@st;
  $self->{fh}   = $fh;
}

# Create temp file and then immediately unlink it.  This will free the
# space used automatically when the last reference to it is closed.
sub copy_to_tmpfile
{
  my $self      = shift;
  my $fh        = $self->{fh};
  my $blocksize = $self->{block_size};

  my $tmpdir = $ENV{TMPDIR} || $ENV{TEMPDIR} || "/tmp";
  my $name   = "$tmpdir/from$<$$";  # uid + pid
  ::DEBUG { $name };

  my $tfh = IO::File->new;
  return ::_error ("open", $name, "$!")
      unless sysopen ($tfh, $name, O_RDWR | O_CREAT | O_EXCL, 0600);
  unlink ($name);

  local $_;
  while ($fh->read ($_, $blocksize))
    {
      my $amt = $tfh->write ($_);
      return ::_error ("write", $name, $!) unless defined $amt;
    }
  $self->{stat} = [stat $tfh];
  $self->{fh} = $tfh;
}

# Try to find the nearest offset earlier than msgno via bisection
sub highest_scanned_before
{
  use integer;
  my ($self, $msgno) = @_;

  my @seen = sort { $a <=> $b } keys %{$self->{folder_data}};
  return 0 unless @seen;
  my $last  = (scalar @seen) - 1;

  return 0            if $msgno <= $seen[0];
  return $seen[$last] if $msgno >  $seen[$last]; # most common case

  my $len   = $last / 2;
  my $start = $len;
  while ($len > 1 || $seen[$start] >= $msgno)
    {
      return $seen[$start-1] if (       $seen[$start]   == $msgno
                                 || (   $seen[$start-1] <  $msgno
                                     && $seen[$start+1] >  $msgno));

      $start -= $len while ($seen[$start] > $msgno);
      $start += $len while ($seen[$start] < $msgno);
      $len /= 2 if $len > 1;
    }
  return $seen[$start];
}

# Args: fh, buffer, size, offset into buffer, var for amtread
# Side-effects: modifies buffer, offset, and amtread in-place.
sub __grow_buffer
{
  my $pos    = pos $_[1];  # Save and restore regexp pos on buffer
  my $amt    = $_[0]->read ($_[1], $_[2], $_[3]);
  pos $_[1]  = $pos;
      $_[3] += $amt;
      $_[4]  = $amt;
  ::DEBUG { { marker => $pos, amtread => $amt, offset => $_[3], } } @_;
  return $amt;
}

# Creates a vector with the starting offset in the file of the envelope,
# plus markers relative to that offset for the header block and body.
# Includes the actual envelope, header, and body text if the corresponding
# boolean params are true.
sub scan_msgno
{
  my ($self, $target_msgno, $envp, $hdrp, $bdyp) = @_;

  my $fdata        = $self->{folder_data};
  my $msgno        = $self->highest_scanned_before ($target_msgno);
  my $start_offset = (exists $fdata->{$msgno}
                      ? $fdata->{$msgno}->[M_EBEG] + $fdata->{$msgno}->[M_BEND]
                      : 0);
  my $blocksize = $self->{block_size};
  ::DEBUG { { target_msgno => $target_msgno,
              start_msgno  => $msgno,
              start_offset => $start_offset,
              envp         => $envp,
              hdrp         => $hdrp,
              bdyp         => $bdyp, } };

  my ($amtread, $offset) = ($blocksize, 0);
  local *_ = \$self->{buffer}; # alias $_ to our buffer string
  # If continuing from last search, pick up where we left off.
  if ($msgno == $self->{last_scanned}) { $offset = length $_ }
  else                                 { $_ = "" }

  my $fh = $self->{fh};
  $fh->seek ($start_offset + $offset, SEEK_SET);
  # Make sure buffer is long enough to find any reasonable envelope
  __grow_buffer ($fh, $_, $blocksize, $offset, $amtread)
    unless $offset > ::MIN_BLOCKSIZE;

  while (/^${re_message_delimiter}.*$/mogc)
    {
      last if (++$msgno == $target_msgno);

      # Read in more data until we find the next envelope
      __grow_buffer ($fh, $_, $blocksize, $offset, $amtread)
        while (!/^(?=$re_message_delimiter)/mogc && $amtread == $blocksize);

      my $len = pos $_;
      substr ($_, 0, $len) = "";  # discard skipped data
      $start_offset += $len;
      $offset = length $_;
    }

  $self->{last_scanned} = $msgno;
  return unless $msgno == $target_msgno;

  my $hbeg = pos ($_) + 1; # does not include prior newline
  # Read in more data until we find the end of the headers
  __grow_buffer ($fh, $_, $blocksize, $offset, $amtread)
    while (!/\n\r?\n/gc && $amtread == $blocksize);
  my $hend = pos ($_);

  # Read in more data until we find the next envelope or hit eof
  __grow_buffer ($fh, $_, $blocksize, $offset, $amtread)
    while (!/^(?=$re_message_delimiter)/mogc && $amtread == $blocksize);

  # don't include final newline except at eof
  # if pos is still at hend, empty message or 1 blank line.
  my $bend = (pos $_ == $hend
              ? ($amtread == $blocksize
                 # Sometimes a message will not even have a blank line
                 # between the end of the headers (which is 2 newlines)
                 # and the next envelope.  If that happens, back up.
                 ? (substr ($_, $hend, 1) ne "\n"
                    ? $hend - 1
                    : $hend)
                 : length ($_) - 1)
              : pos ($_) - 1);

  # skip preceding newline for start
  my @data = ($start_offset + 1, $hbeg, $hend, $bend);
  ::DEBUG { $msgno, @data };
  $data[M_ENV] = substr ($_, 0,     $hbeg - 1    ) if $envp;
  $data[M_HDR] = substr ($_, $hbeg, $hend - $hbeg) if $hdrp;
  if ($bdyp && $bend >= $hend)
    {
      if ($opt{bodylines} > 0)
        {
          # For large m, loop is actually *much* faster than using a single
          # /((?:.*\n){1,$m})/g regexp.  Also, pcre limits m to 32766.
          my ($n, $m) = (1, $opt{bodylines});
          pos $_ = $hend;
          $n++ while (/$/mgc && $n < $m && pos $_ < $bend);
          $data[M_BDY] = substr ($_, $hend, pos ($_) - $hend);
          $data[M_BDY] .= "\n" if $n == $m; # need fake eom newline
        }
      else
        {
          $data[M_BDY] = substr ($_, $hend, $bend - $hend);
        }
    }
  substr ($_, 0, $bend + 1) = "";  # trim buffer up to start of next msg.
  $fdata->{$msgno} = \@data;
}

sub analyze_message
{
  my ($self, $msgno) = @_;

  my $fdata = $self->{folder_data};
  return $fdata->{$msgno} if exists $fdata->{$msgno};

  my ($envp, $hdrp, $bdyp);
  if    ($opt{simple_count_p}) {}
  elsif ($opt{envelopep} && !$opt{match_txt_regexp}) { $envp = 1 }
  else
    {
      $envp = 1;
      $hdrp = 1;
      $bdyp = $opt{extractp};
    }

  $self->scan_msgno ($msgno, $envp, $hdrp, $bdyp);
}

sub message_count
{
  my $self = shift;

  ::DEBUG { @_ } @_;
  my $n = scalar keys %{$self->{folder_data}};

  if ($n == 0)
    {
      if ($_[0]) # force full scan
        {
          return unless ($opt{simple_count_p}
                         || $self->{fh}->seek (0, SEEK_CUR) # seekable?
                         || $self->copy_to_tmpfile);

          # Try scanning as many messages as there are bytes in the file.
          # scan will stop at last message, and because there are no
          # intermediate method calls and marker recording, this will be faster
          # than calling iteratively from 1 to n.
          $self->scan_msgno ($self->{stat}->[7]); # st_size
          $n = $self->{last_scanned};
        }
      else
        {
          $n = $self->{stat}->[7];  # provide upper bound
        }
    }
  return $n;
}

sub message_size
{
  my ($self, $msgno) = @_;

  my $data = $self->{folder_data}->{$msgno};
  return unless $data;

  # Size should include both body and headers for consistency with imap
  return $data->[M_BEND];
}

sub flags
{
  my ($self, $msgno) = @_;

  my @msg = $self->retrieve ($msgno);
  return unless @msg;

  my $status = $1 if $msg[0] && $msg[0] =~ /^Status: (.*)/m;
  return unless $status;

  my %trans = ( R => [qw(read       1)],
                O => [qw(recent     0)],
                D => [qw(deleted    1)],
                F => [qw(important  1)],
                A => [qw(answered   1)], );
  my %flag = ( recent => 1, );
  map { my $p = $trans{$_};
        my $k = $p ? $p->[0] : $_;
        my $v = $p ? $p->[1] : 1 ;
        $flag{$k} = $v;
      } split (//, uc $status);
  return wantarray ? %flag : \%flag;
}

sub envelope
{
  my ($self, $msgno) = @_;
  my $text = $self->envelope_string ($msgno);
  return unless $text;

  my ($addr, $date) = ($1, $2)
    if $text =~ /^From (.*?)  ?(.*)/;

  return wantarray ? ($addr, $date) : [$addr, $date];
}

sub envelope_string
{
  my ($self, $msgno) = @_;
  my $msg = $self->analyze_message ($msgno);
  return unless $msg;
  return $msg->[M_ENV];
}

sub header
{
  my ($self, $msgno) = @_;

  my $msg = $self->analyze_message ($msgno);
  return unless $msg;
  return $msg->[M_HDR];
}

sub body
{
  my ($self, $msgno) = @_;

  my $bodylines = $opt{bodylines};
  return unless (defined $bodylines && $bodylines != 0);

  my $msg = $self->analyze_message ($msgno);
  return unless $msg;

  return $msg->[M_BDY];
}

sub retrieve
{
  my ($self, $msgno) = @_;
  ::DEBUG { $msgno };

  my @msg = ($self->header ($msgno));
  return unless @msg;

  my $body = $self->body ($msgno);
  push @msg, $body if defined $body;

  ::DEBUG { {state=>1}, @msg };
  return wantarray ? @msg : \@msg;
}

sub uncache_message
{
  my ($self, $msgno) = @_;

  my $fdata = $self->{folder_data};
  my $msg   = $fdata->{$msgno};
  return unless $msg;

  # For the current msgno, just delete the header and body text.
  # Save the markers because we'll need them for quickly locating
  # the following message.
  my $len = scalar @$msg;
  splice (@$msg, 4, ($len - 4));

  # The message prior to the current one can be purged completely.
  delete $fdata->{$msgno - 1};

  ::DEBUG { $msgno, @$msg };
}


package From::Mailbox::_Range;  # mixin for mailbox classes

sub normalize_ranges
{
  my $self = shift;

  ::DEBUG { @_ } @_;

  my $min = 1;
  # regexp: we only need the real max for mbox files if counting backwards
  # from the end.
  my $max = $self->message_count ("@_" =~ m/(?:^|[\s,])-\d/);
  return unless defined $max && $max >= $min;

  unless (@_ && defined $_[0]) # ignore undef
    {
      #::DEBUG { "default:", [$min, $max] };
      return wantarray ? ([$min, $max]) : [[$min, $max]];
    }

  my $s = join (" ", @_);
  if (defined $max)
    {
      while ($s =~ /(\d+)/g)
        {
          next unless $1 > $max;
          my $len   = length ($1);
          my $start = pos ($s) - $len;
          substr ($s, $start, $len) = $max;
          pos ($s) = $start;
        }
    }
  $s =~ s/\s*[:-]+\s*/-/g;
  my @elt = split (/[\s,]+/, $s);

  map { if (/^(\d*)-(\d*)$/)
          {
            if    ($1 && $2) { $_ = [$1, $2]   }
            elsif ($1)       { $_ = [$1, $max] }
            elsif ($2)       { # mbox: force full scan
                               $max = $self->message_count (1) unless $max;
                               $_ = [$max + 1 - $2, $max]
                             }
          }
      } @elt;

  my @single = sort { $a <=> $b } grep { /^\d+$/ } @elt;
  my @range  =                    grep { ref $_  } @elt;

  my @sunique;  # unique singletons
  my $prev = -1;
  my $dup = 0;
  while (@single)   # Eliminate redundant singletons
    {
      my $n = shift @single;
      next if $n == $prev; # duplicate
      $prev = $n;

      # check ranges
      for my $r (@range)
        {
          next unless ($n >= $r->[0] && $n <= $r->[1]);
          $dup = 1;
          last;
        }
      push @sunique, $n unless $dup;
    }
  #::DEBUG { ({state=>1}, "unique singletons", @sunique) };

  # Convert remaining singletons into ranges if they are consecutive
  while (@sunique)
    {
      my $beg  = shift @sunique;
      my $step = $beg;
      while (@sunique && $sunique[0] == $step + 1)
        {
          shift @sunique;
          $step++;
        }
      if    ($step > $beg + 1) { push @range, [$beg, $step] }
      elsif ($step > $beg)     { push @single, $beg, $step }
      else                     { push @single, $beg }
    }

  @range  = sort { $a->[0] <=> $b->[0] } @range; # now needs to be sorted
  while (@range) # Keep merging overlapping or adjacent ranges
    {
      my @k = ($range[0]);
      for (my $ri = 1; $ri < @range; $ri++)
        {
          my $r = $range[$ri];
          my ($rb, $re) = @$r;

          my $found;
          for (my $ki = 0; $ki < @k; $ki++)
            {
              my ($kb, $ke) = @{$k[$ki]};

              $found = 1;
              if ($re < $kb)                       # rb    re
                {                                  #           kb    ke
                  splice (@k, $ki, 0, $r);         # r before k
                }
              elsif ($rb >= $kb && $re <= $ke)     #  rb      re
                {                                  # kb        ke
                  # r is redundant; drop it.
                }
              elsif ($rb <= $kb && $re >= $ke)     # rb        re
                {                                  #  kb      ke
                  $k[$ki] = $r;                    # k is redundant
                }
              elsif ($rb <= $kb && $re + 1 >= $kb) # rb    re
                {                                  #      kb    ke
                  $k[$ki] = [$rb, $ke];
                }
              elsif ($rb >= $kb && $rb <= $ke + 1) #      rb    re
                {                                  # kb    ke
                  $k[$ki] = [$kb, $re];
                }
              else { $found = 0 } # else wait til the end to append r to k.
              last if $found;
            }
          push @k, $r unless $found;
        }
      last if @k == @range;
      @range = @k;
    }
  my @all = sort { if (ref $a && ref $b) { $a->[0] <=> $b->[0] }
                   elsif (ref $a)        { $a->[0] <=> $b      }
                   elsif (ref $b)        { $a      <=> $b->[0] }
                   else                  { $a      <=> $b      }
                 } (@single, @range);
  #::DEBUG { ({state=>1}, "final ranges", @all) };
  return wantarray ? @all : \@all;
}

sub batch_ranges
{
  my $self = shift;

  ::DEBUG { @_ } @_;
  my @r = map { ref $_ ? [@$_] : $_ } @_; # copy
  my (@ab, @tb);  # all batches, this batch

  my $batch = $opt{batch_size};
  return [\@r] unless $batch;

  my $n = 1;

  while (@r)
    {
      my $left = $batch - $n;
      my $elt = $r[0];

      if (ref $elt)
        {
          my ($beg, $end) = @$elt;
          ::DEBUG { {state=>1}, "elt", $elt };

          if (($end - $beg) > $left)
            {
              $elt->[0] += $left + 1;

              my $rend = $elt->[0] - 1;
              push @tb, ($beg == $rend ? $beg : [$beg, $rend]);
              $n += $left;
            }
          else
            {
              push @tb, $beg == $end ? $beg : $elt;
              shift @r;
              $n += ($end - $beg);
            }
        }
      else
        {
          push @tb, shift @r;
          $n++;
        }

      if ($n == $batch)
        {
          push @ab, [@tb]; # must copy, not reference var
          undef @tb;
          $n = 1;
        }
    }
  push @ab, \@tb if @tb;
  ::DEBUG { {state=>1}, @ab };
  return wantarray ? @ab : \@ab;
}

sub map_over_msgnos
{
  my ($self, $fn) = (shift, shift);

  map { if (ref $_) { my ($i, $end) = @$_;
                      while (&$fn ($i))
                        {
                          last if defined $end && $i == $end;
                          $i++;
                        }
                    }
        else        { &$fn ($_) }
      } (@_ && ref $_[0]
         ? @_
         : $self->message_ranges (@_));
}

sub message_ranges
{
  my $self = shift;

  return (@_
          ? $self->normalize_ranges (@_)
          : ($self->{message_range}
             ? @{$self->{message_range}}
             : $self->normalize_ranges (@{$opt{message_numbers}})));
}

sub format_message_range
{
  my $self = shift;
  join (",", map { ref $_ ? sprintf("%d:%d", @$_) : $_ } @_);
}

sub in_batch # return batch into which n falls
{
  my ($self, $n, $all) = @_;

  my $idx = 0;
  map { my $batch = $_;
        map { ::DEBUG { {state=>1}, "in_batch : batch", $n, $_ };
              return wantarray ? ($batch, $idx) : $batch
                if ((ref $_
                     && $n >= $_->[0]
                     && $n <= $_->[1])
                    || $n == $_);
            } @$batch;
        $idx++;
      } @$all;
  return;
}

sub batch_string
{
  my $self = shift;
  ::DEBUG { @_ } @_;

  return join (":", 1, $self->message_count)
    unless @_ || $opt{message_numbers};

  join (",", (map { ::DEBUG { {state=>1}, $self->format_message_range ($_) };
                    $self->format_message_range ($_)
                  } @{$_[0]}));
}


package From::Mailbox;

use strict;
use POSIX;

my %protoclass =
  ( imap4s => 'From::Mailbox::Imaps',     imap4 => 'From::Mailbox::Imap',
    imaps  => 'From::Mailbox::Imaps',     imap  => 'From::Mailbox::Imap',

    pop3s  => 'From::Mailbox::Pop3s',     pop3  => 'From::Mailbox::Pop3',
    pops   => 'From::Mailbox::Pop3s',     pop   => 'From::Mailbox::Pop3',

    mbox   => 'From::Mailbox::MboxFile',  file  => 'From::Mailbox::MboxFile',
  );

sub new
{
  my $class = shift;  # notused
  my $loc = shift;

  $loc = "file:///$loc" unless $loc =~ m|://|;
  my %spec = _parse_spec ($loc);

  my $proto = lc ($spec{proto});
  $class    = $protoclass{$proto};

  unless (defined $class)
    {
      ::_error ($proto, "unsupported protocol");
      return;
    }

  ($spec{port} = lc $class) =~ s/^.*::// unless (defined $spec{port});
  $spec{pass} = input_noecho () unless defined $spec{pass} || $class =~ /file$/i;
  $spec{folder} = $spec{path} if defined $spec{path} && !defined $spec{folder};

  ::DEBUG { \%spec, @_ } @_;

  return $class->new (%spec, @_);
}

sub _parse_spec
{
  local $_ = shift;

  my ($proto, $user, $pass, $host, $port, $path);
  my $loc;

  ($proto, $loc, $path) = ($1, $2, $3)
    if m=^(.*?)://(.*?(?<!\\)(?>\\\\)*)(?:/(.*)?|$)=;

  if ($loc =~ /^(.*)@([^@]*)$/)
    {
      my ($userpass, $hostport) = ($1, $2);
      ($user, $pass) = split (/(?<!\\)(?>\\\\)*:/, $userpass, 2);
      ($host, $port) = split (/(?<!\\)(?>\\\\)*:/, $hostport, 2);
    }
  else
    {
      ($host, $port) = split (/(?<!\\)(?>\\\\)*:/, $loc, 2);
    }

  # unescape \'d chars
  map { s/\\(.)/$1/g if defined $_ } ($user, $pass, $host, $port);

  s|(://.*?(?<!\\)(?>\\\\)*):.*\@|$1:*\@|;  # strip password from uri if present
  my %data = ( uri   => $_,
               proto => $proto,
               user  => (defined $user ? $user : $opt{user}),
               pass  => (defined $pass ? $pass : $opt{pass}),
               host  => $host,
               port  => $port,
               path  => $path,
             );
  map { delete $data{$_} unless defined $data{$_} && $data{$_} ne ""
      } keys %data;
  ::DEBUG { \%data };
  return wantarray ? %data : \%data;
}

sub input_noecho
{
  my ($prompt) = @_;
  my $tty;
  my $c_lflag;
  my %trap_sigs = ( HUP  =>  1,
                    INT  =>  2,
                    QUIT =>  3,
                    TERM => 15);
  my %sig_orig;
  my $fd = fileno (STDIN);

  # If stdin is a tty, disable echo while reading password.
  if (-t STDIN)
    {
      $tty = POSIX::Termios->new;
      $tty->getattr ($fd);
      $c_lflag = $tty->getlflag;

      # Set up handlers to restore tty on typical signals
      my $restore = sub {
        $tty->setlflag ($c_lflag);
        $tty->setattr ($fd);
        my $signum = $trap_sigs{$_[0]};
        print STDERR "\n";
        ::_verbose ("Exiting on signal $signum (SIG$_[0])");
        # 7th bit set indicates lower 6 bits represent a
        # signal number (0x80 == 2**7)
        exit (0x80 | $signum);
      };
      map { $sig_orig{$_} = $SIG{$_} || 'DEFAULT';
            $SIG{$_} = $restore
          } keys %trap_sigs;

      $tty->setlflag ($c_lflag & ~&POSIX::ECHO);
      $tty->setattr ($fd);
    }

  # Temporarily disable buffering on stderr, which is where prompt is printed.
  my $fh_orig = select (STDERR);
  my $stderr_bufp = $|;
  $| = 1;
  $prompt = "Password:" unless defined $prompt;
  print $prompt;
  my $input = <STDIN>;
  chomp $input if defined $input;
  $| = $stderr_bufp;
  select ($fh_orig);

  # Restore echo afterward, if it was originally on;
  # and restore signal handlers
  print STDERR "\n";
  if ($tty)
    {
      $tty->setlflag ($c_lflag);
      $tty->setattr ($fd);
      map { $SIG{$_} = $sig_orig{$_} } keys %trap_sigs;
    }

  return $input;
}


package From::Header;

use strict;
use POSIX qw(strftime tzset);
use Encode qw(:all);

use constant { H_HDR => 0,
               H_MET => 1,
               H_ENV => 2,
               H_BDY => 3,
             };

sub new
{
  my $type = shift;
  my $class = ref ($type) || $type;

  my $self = [];
  bless $self, $class;

  $self->[H_HDR] = \$_[0]->[0];
  $self->[H_BDY] = \$_[0]->[1] if @{$_[0]} > 1;
  $self->[H_MET] = $_[1] || {};
  $self->[H_ENV] = $_[2] || [];
  return $self;
}

sub names
{
  my $self = shift;

  # Pre-compiling this regexp only seems to slow it down (marginally) in
  # most cases.
  my $re = (@_
            ? sprintf ("^(%s):", join ('|', map { quotemeta $_ } @_))
            : '^([^\s:]+):');

  my (@n, %seen);
  local *_ = $self->[H_HDR];
  pos $_ = 0;
  while (/$re/gim)
    {
      my $lh = lc $1;
      push @n, $1 unless exists $seen{$lh}; # return original case
      $seen{$lh} = undef;
    }

  ::DEBUG { @n };
  return wantarray ? @n : @n ? \@n : undef;
}

sub contents
{
  my ($self, $name, $allp) = @_;

  my $ln = lc $name;
  my @c;

  if    ($ln eq '{fromto}')  { push @c, $self->fromto }
  elsif ($ln eq '{envfrom}') { push @c, $self->[H_ENV]->[0] }
  elsif ($ln eq '{envdate}')
    {
      my $date = $self->[H_ENV]->[1];
      $date =~ s/ (\d{4})$/ $opt{folder_time_zone} $1/
        if ($opt{parsep}
            && defined $opt{folder_time_zone}
            && $date !~ /[+-]\d{4}/);

      push @c, ($opt{parsep} ? _parse_date ($date) : $date);
    }
  elsif (exists $self->[H_MET]->{$ln}) { push @c, $self->[H_MET]->{$ln} }
  else
    {
      # This seems to be marginally faster if not precompiled!
      # Perhaps because there are no alternate names?
      my $re = sprintf ('^%s:[ \t]*([\S\s\n]*?)(?=\r?\n(?:\S|\r?\n))',
                        quotemeta ($name));
      local *_ = $self->[H_HDR];  # alias reference
      pos $_ = 0;
      while (/$re/gim)
        {
          push @c, $1;
          last unless $allp;
        }
    }
  ::DEBUG { $name, @c };
  return wantarray ? @c : @c ? \@c : undef;
}

# Fold wrapped header contents into a single line
sub contents1
{
  my ($self, $name, $allp) = @_;

  my @contents = $self->contents ($name, $allp);
  map { s/\r?\n\s+/ /mg; $_ } @contents;

  return wantarray ? @contents : @contents ? \@contents : undef;
}

# join all header contents into a single line
sub allcontents1
{
  my ($self, $name) = @_;
  join (", ", $self->contents1 ($name, 1));
}

sub filter_matches_p
{
  my $self = shift;
  local $_;

  my $hre = $opt{match_hdr_regexp} || $opt{filter_hdr_regexp};
  my $tre = $opt{match_txt_regexp} || $opt{filter_txt_regexp};
  if ($hre)
    {
      for my $h (grep { /$hre/ } $self->names)
        {
          for $_ ($self->contents ($h, 1)) { return 1 if /$tre/m }
          for $_ ($self->parsed   ($h, 1)) { return 1 if /$tre/m }
        }
    }
  return 1 if ($opt{search_body_p}
               && defined $self->[H_BDY]
               && ${$self->[H_BDY]} =~ /$tre/m);
  return 0;
}

sub fromto
{
  my ($self, $allp) = @_;
  my $from = join (", ", $self->contents ('from', $allp));

  my $me_re = $opt{match_me_regexp};
  if ($me_re && $from =~ /$me_re/o)
    {
      my @to = map { $self->contents ($_, 1) } (qw(to cc newsgroups));
      return $from unless @to;
      return "To " . join (", ", @to);
    }
  return $from;
}


my %header_parser =
  ( '{fromto}'      => \&_parse_address,

    'return-path'   => \&_parse_address,
    'sender'        => \&_parse_address,
    'from'          => \&_parse_address,
    'reply-to'      => \&_parse_address,

    'to'            => \&_parse_address,
    'cc'            => \&_parse_address,
    'bcc'           => \&_parse_address,

    'resent-sender' => \&_parse_address,
    'resent-from'   => \&_parse_address,
    'resent-to'     => \&_parse_address,
    'resent-cc'     => \&_parse_address,
    'resent-bcc'    => \&_parse_address,

    'date'          => \&_parse_date,
    'resent-date'   => \&_parse_date,

    'subject'       => \&_parse_subject,
  );

sub parsed
{
  my ($self, $name, $allp) = @_;
  ::DEBUG { $name };

  my $fn = $header_parser{$name} if $opt{parsep};
  return $self->contents ($name, $allp) unless $fn;

  my @contents = map { &$fn ($_) } $self->contents ($name, $allp);
  return wantarray ? @contents : \@contents;
}

sub allparsed
{
  my ($self, $name) = @_;
  join (", ", $self->parsed ($name, 1));
}

sub allparsed1
{
  my ($self, $name) = @_;
  local $_ = $self->allparsed ($name);
  s/\r?\n\s+/ /mg;
  return $_;
}

sub _parse_subject
{
  return $opt{utf8} ? _parse_rfc1522 ($_) : $_;
}

# Try to extract real name from From: line when possible.
sub _parse_address
{
  local $_ = $_[0];
  ::DEBUG { $_ };

  $_ = $1
    if (   m/"(.+?)"/         # From: "real name" <foobar@host>
        || m/^(.+?)</         # From: real name <foobar@host>
        || m/\((.*?)\)/       # From: foobar@host (real name)
        || m/"".*?<(.*?)>/    # From: "" <foobar@host>
        || m/^<(.*?)>/);      # From: <foobar@host>

  # Address is 'To <user@domain>' as generated by fromto,
  # with no actual real name component.
  return $_ . $1 if ($_ eq 'To ' && $_[0] =~ /<(.*?)>/);

  # Strip any leading and trailing whitespace
  s/^\s+//;
  s/\s+$//;

  return _parse_rfc1522 ($_) if $opt{utf8};
  return $_ unless /=\?.*?\?.\?.*?\?=/;
  # If not utf8 but real name is rfc1522-encoded, return address.
  $_ = $_[0];
  $_ = $1 if /<(.*?)>/ || /^\s*(.*?)\s+\(/;
  return $_;
}

sub _parse_rfc1522
{
  local $_ = $_[0];
  my $result = "";

  # Remove whitespace between adjacent encoded regions (per section 6.2)
  s/\?=\s+=\?/?==?/mg;

  while (/(.*?)=\?(.*?)\?(.)\?(.*?)\?=/gc)
    {
      my $pos = pos $_; # perl 5.8 seems to lose this if encoding

      $result .= $1;
      my $charset  = lc ($2);
      my $encoding = lc ($3);

      my $s = (  $encoding eq 'q' ? qp_decode     ($4)
               : $encoding eq 'b' ? base64_decode ($4)
               : "$4");
      if ($opt{utf8})
        {
          eval { $s = decode ($charset, $s); # convert to utf8
                 utf8::encode ($s);          # convert back to bytes for now
               };
          if ($@)
            {
              # Just return original encoded text if there is a decoding problem.
              # e.g. perl 5.14.4 doesn't recognize the gb18030 charset.
              ::DEBUG { $@ };
              return $_[0];
            }
        }
      $result .= $s;

      pos $_ = $pos;
    }
  return $_ if $result eq "";
  return $result . substr ($_, pos $_);
}

sub _parse_date
{
  my $str = shift;
  return $str unless defined $opt{date_format} && $opt{date_format} ne "";

  my ($tm, $offset) = From::Timestamp::_parse_timestamp ($str);
  return $str unless $tm;

  my @tminfo;
  {
    local $ENV{TZ} = $ENV{TZ} if defined $ENV{TZ};
    if (! $opt{tzdate}) {}
    elsif (lc $opt{tzdate} eq 'local' || lc $opt{tzdate} eq 'tz') {}
    elsif (lc $opt{tzdate} eq 'sender' && $offset)
      {
        $offset =~ s/(\d\d)(\d\d)$/$1:$2/;
        $offset =~ y/+-/-+/;
        $ENV{TZ} = "UTC" . $offset;
      }
    elsif ($opt{tzdate} ne 'sender')
      {
        $ENV{TZ} = $opt{tzdate};
      }
    tzset (); # multithreaded perl 5.8.0 requires this
    @tminfo = localtime ($tm);

    my $fmt = $opt{date_format};
    local $_; # let formatter mangle
    $fmt = &$fmt (@tminfo, $str) if ref $fmt eq 'CODE';
    $str = strftime ($fmt, @tminfo) if defined $fmt;
  }
  tzset();    # restore timezone cache for perl 5.8.0

  return $str;
}

my @base64_decode_vector;
sub base64_decode
{
  return $_[0] unless (length ($_[0]) % 4 == 0);

  if (! @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;
}


package From::Timestamp;

use strict;
use POSIX qw(strftime localtime);
use Time::Local;

my @time_parser_list =
  ( [ "Time::ParseDate" => \&Time::ParseDate::parsedate ],
    [ "Date::Parse"     => \&Date::Parse::str2time      ], );

sub _parse_timestamp
{
  local $_ = shift;

  # Try this first since we have a few normal cases and it's faster.
  my @result = cheesy_timestamp_parser ($_);
  return @result if @result;

  # Break out bigger guns
  unless (*time_parser{CODE})
    {
      for my $elt (@time_parser_list)
        {
          my ($module, $fn) = @$elt;
          eval "require $module";
          next if ($@ ne "");
          *time_parser = $fn;
          last;
        }
      *time_parser = sub { return } unless *time_parser{CODE};
    }
  return time_parser ($_);
}

my %month_conv
  = (Jan => 1,    Apr => 4,    Jul => 7,    Oct => 10,
     Feb => 2,    May => 5,    Aug => 8,    Nov => 11,
     Mar => 3,    Jun => 6,    Sep => 9,    Dec => 12);

sub cheesy_timestamp_parser
{
  local $_ = shift;

  #return      $_  if /^[0-9]+$/;
  #return hex ($_) if /^(?:0x)?[0-9a-f]+$/i;

  my ($y, $m, $d, $H, $M, $S, $offset, $tm);

  # Handle dates of the form:
  #    Sun, 19 Jan 1992 22:44:05 -0500
  #    21 Dec 1992 17:32:12 -500 (EST)
  #    01-Sep-2011 16:31:24 -0700
  # These are the most common.
  if (/^(?:\D+,?\s+)?(\d+)[\s+|-](\S+)[\s+|-](\d+)\s+(\d+):(\d+):(\d\d)\s+([+-]\d?\d:?\d\d)/)
    {
      ($y, $m, $d, $H, $M, $S, $offset) = ($3, $month_conv{$2}, $1, $4, $5, $6, $7);
    }

  # Handle dates of the form:
  #    Fri, 19 Apr 91 01:07:33 PDT
  #    Fri, 12 May 95 17:26 MET DST
  #    23 Dec 92 02:17:25
  elsif (/^(?:\D+,?\s+)?(\d+)\s+(\S+)\s+(\d+)\s+(\d+):(\d+)(?::(\d\d))?(?:\s+([a-z ]+))?/i)
    {
      ($y, $m, $d, $H, $M, $S, $offset) = ($3, $month_conv{$2}, $1, $4, $5, $6, $7);
      $offset = tzconv ($offset) if $offset;
    }

  # Handle dates of the form:
  #    Sun Feb 17 23:41:23 1991
  #    Sat Jan  1 21:24:52 IST 2000
  #    Tue Jun 18 17:51:38 MET DST 1996
  #    Fri Nov 29 11:14:58 -0500 2013
  elsif (/^[a-z]{3}\s+([a-z]{3})\s+(\d+)\s+(\d+):(\d+):(\d\d)\s*?([+-]\d{4}|[a-z]{3,4}(?: DST|))?\s+(\d{4})/i)
    {
      ($y, $m, $d, $H, $M, $S, $offset) = ($7, $month_conv{$1}, $2, $3, $4, $5, $6);
      $offset = tzconv ($offset) if $offset;
    }

  # ISO-8601 date format: YYYY-MM-DD{T}HH:MM:SS[+-]hh{:}mm
  # Or sloppy variants.
  elsif (/^(\d{2,4})\D(\d?\d)\D(\d?\d)\D+(\d?\d)\D(\d?\d)\D(\d?\d)\s*(Z|[+-]\d\d:?\d\d)?/)
    {
      ($y, $m, $d, $H, $M, $S, $offset) = ($1, $2, $3, $4, $5, $6, $7);
    }

  else { return } # unrecognized.

  my @tmargs = ($S + 0, $M + 0, $H + 0,
                $d + 0, ($m + 0 > 0 ? $m - 1 : 0), normalize_year ($y));
  if ($offset && $offset =~ /^([+-])(\d?\d):?(\d\d)/)
    {
      my ($sign, $h, $m) = ($1 . '1', $2, $3);
      $tm = timegm (@tmargs) - ($sign * (($h * 3600) + ($m * 60)));
    }
  else
    {
      $tm = timelocal (@tmargs);
    }

  return unless defined $tm;
  return wantarray ? ($tm, $offset) : $tm;
}

my ($hcurrentyear, $lcurrentyear);
sub normalize_year
{
  my $y = 0 + shift;
  return $y        if $y > 999;  # 1000 or higher
  return $y + 1900 if $y >  99;  #  100 or higher

  unless ($hcurrentyear)
    {
      ($hcurrentyear, $lcurrentyear) = ($1, $2)
        if strftime ("%Y", localtime (time)) =~ /^(\d+?)(\d\d)$/;
    }

  # For years 0-99, see if the value is equal to or less than the current
  # year.  If it is, use the current epoch.  If higher, use the previous epoch.
  my $h = $hcurrentyear;
  $h-- if $y > $lcurrentyear;
  return $y + $h * 100;
}

my %tzconv;
sub tzconv
{
  my $tz = uc shift;

  unless (%tzconv)
    {
      # This is not meant to be complete, just to pick up the more common
      # ancient, pre-RFC2822 timezone indicators.
      %tzconv = ( GMT  => '+0000',  UTC   => '+0000',
                  EST  => '-0500',  EDT   => '-0400',
                  CST  => '-0600',  CDT   => '-0500',
                  MST  => '-0700',  MDT   => '-0600',
                  PST  => '-0800',  PDT   => '-0700',
                  WET  => '+0000',  WEST  => '+0100',
                  CET  => '+0100',  CEST  => '+0200',
                  EET  => '+0200',  EEST  => '+0300',
                  JST  => '+0900',
                  'WET DST' => '+0100', 'MET DST' => '+0200', );
    }
  return $tzconv{$tz} if exists $tzconv{$tz};

  # Break out bigger guns.
  unless (*tz2zone{CODE})
    {
       eval "require Time::Timezone";
       if ($@ eq "")
         {
           *tz2zone   = \&Time::Timezone::tz2zone;
           *tz_offset = \&Time::Timezone::tz_offset;
         }
       else
         {
           *tz2zone = *tz_offset = sub { return };
         }
     }
  use integer;
  my $z = tz2zone ($tz);
  return unless $z;
  my $s = tz_offset ($z);
  my $h = $s / 3600;
  my $m = ($s - 3600 * $h) / 60;
  my $o = sprintf ("%02.2d%02d", $h, $m);
  $o = "+$o" if $s >= 0;
  return $o;
}

# strftime doesn't directly let you display Zulu time correctly.
# This implementation conforms to iso8601:2004.
sub strftime_iso8601
{
  my $fmt = shift;

  local $_ = strftime ($fmt, @_[0 .. 8]);

  # We pad the end if shortened and not using zulu time consistently,
  # to keep widths consistent.
  $fmt =~ /[^\s]%z/ && s=\+0000=Z=
    && $ENV{TZ} && uc $ENV{TZ} ne 'UTC' && s=$=    =;

  s=%=%%=g;  # re-quote outstanding `%' for reinput to strftime again.
  return $_;
}


package From::Debug;

# object_pp is lifted from NF::PrintObject.

use strict;
use Carp;
use Scalar::Util qw(reftype refaddr);

our $object_pp_indent =  0;
our $object_pp_maxlen = 64;
our $object_pp_verbose = 0;
our $object_pp_maxwidth = 120;

*max = \*::max; # import from main

sub __escape_ctrl
{
  $_[0] =~ s/\r/\\r/g;
  $_[0] =~ s/\n/\\n/g;
}

sub object_pp
{
  my $obj = shift;
  my @list;

  return "undef" unless defined $obj;

  my $ref     = ref $obj;
  my $reftype = reftype ($obj) || "";
  my $refstr  = ($ref eq $reftype
                 ? ""
                 : ($object_pp_verbose > 2
                    ? sprintf ("$ref(0x%x)=", refaddr ($obj))
                    : "$ref="));

  local $object_pp_indent = $object_pp_indent + 2 + length $refstr;
  my $prefix = "\n" . (" " x $object_pp_indent) if $object_pp_verbose > 1;

  if ($reftype eq 'ARRAY')
    {
      return "${refstr}[]" unless @$obj;
      my @res = map { object_pp ($_) } @$obj;
      my $sep = ($prefix && length ("@res") > ($object_pp_maxwidth - $object_pp_indent)
                 ? ",$prefix "
                 : ", ");
      return "${refstr}[ " . join ($sep, @res) . " ]" if $prefix;
      return "${refstr}["  . join ($sep, @res) .  "]";
    }
  elsif ($reftype eq 'HASH')
    {
      return "${refstr}{}" unless %$obj;

      my @keys = sort { ($a =~ /^\d+$/ && $b =~ /^\d+$/
                         ? $a <=> $b
                         : $a cmp $b)
                      } keys %$obj;

      my %pkey;
      my $w = max (map { my $pkey = $_;
                         $pkey{$_} = $pkey
                           if $pkey =~ s/^(.*?[^A-Za-z0-9_].*)$/'$1'/;
                         length $pkey;
                       } @keys);

      $object_pp_indent += $w + 4;
      my $fmt = $prefix ? "%-${w}s => %s," : "%s => %s";
      my @elt = map { sprintf ($fmt,
                               (exists $pkey{$_} ? $pkey{$_} : $_),
                               ($_ eq "pass" ? '"*"' : object_pp ($obj->{$_})))
                    } @keys;
      if ($prefix)
        {
          my $hprefix = substr ($prefix, 0, length ($prefix) - 1);
          return "${refstr}{ " . join ("$prefix ", @elt) . " }";
        }
      return ("${refstr}{ " . join (", ", @elt) . " }");
    }
  elsif ($reftype eq 'CODE')   { return "$refstr" . $ref  }
  elsif ($reftype eq 'SCALAR') { return "${refstr}\\" . object_pp ($$obj) }
  elsif ($reftype eq 'REGEXP') { return $refstr . object_pp ("$obj") }
  elsif ($ref ne "")
    {
      $ref =~ s/=.*//;
      return $ref;
    }
  elsif ($obj =~ /^[+-]?[\d.]+$/ && $obj ne '.')
    { return $obj }
   #{ return $prefix ? sprintf ("%6d", $obj) : $obj }

  my $len = length $obj;
  if ($object_pp_verbose < 3
      && $object_pp_maxlen > 0
      && $len > $object_pp_maxlen)
    {
      my $n = $object_pp_maxlen / 2;
      substr ($obj, $n, -$n) = "...";
      __escape_ctrl ($obj);
      $obj =~ s/"/\\"/g;
      return "\"$obj\" {$len}";
    }
  else
    {
      __escape_ctrl ($obj) if $len <= $object_pp_maxlen;
      $obj =~ s/"/\\"/g;
      return "\"$obj\"";
    }
}

sub DEBUG (&;@)
{
  return unless $::debug;

  if ($::debug > 2)
    {
      local $Carp::CarpLevel = 2;
      local ($@, $SIG{__DIE__});
      eval { confess "DEBUG" };
      print STDERR "\n", $@;
    }

  my $fn = shift;
  @_ = eval { &$fn };

  my @caller = caller (1);
  my $pkg = $caller[0];
  $fn     = $caller[3];
  $fn =~ s/.*:://;

  my $state = 0;
  if (@_ && ref $_[0] eq 'HASH' && exists $_[0]->{state})
    {
      $state = 1;
      shift;
    }

  local $object_pp_verbose = $::debug;
  my ($args, $fmt);
  my @elt  = map { object_pp ($_) } @_;
  my @refs = grep { ref $_ } @_;
  $args = join (", ", @elt) unless @refs;

  if ($::debug > 1 && !(defined $args && length $args < $object_pp_maxlen))
    {
      $fmt = $state ? "%s::%s :\n %s\n\n" : "%s->%s (\n %s)\n\n";
      $args = join (",\n ", @elt);
    }
  else
    {
      $fmt = $state ? "%s::%s : %s\n" : "%s->%s (%s)\n";
      $fmt .= "\n" if $::debug > 1;
      $args ||= join (", ", @elt);
      __escape_ctrl ($args);
    }

  my $msg = sprintf ($fmt, $pkg, $fn, $args);
  print STDERR $msg;
  return;
}


::main (@ARGV);

1;

__END__

=begin text

=encoding utf8

=end text

=head1 NAME

from - summarize mailbox folder

=head1 SYNOPSIS

     {-h|--help|--usage}                   {-C|--columns       COLS}
     {-D|--debug}                          {-f|--format        OUTPUTFMT}
     {-W|--warnings}                       {-d|--date-format   STRFTIME}
                                           {-T|--time-zone     TZ}
     {-c|--count-only}                     {--utc|--gmt}
     {-e|--envelope}                       {--folder-time-zone TZ}

     {-i|--ignore-case}                    {--utf8|--utf-8}
     {--no-ignore-case}                    {--no-utf8|--no-utf-8}

     {-1|--one-line-headers}               {-U|--user USER}
     {-2|--multi-line-headers}             {--pass PASS} (don't use this)
     {-a|--all-headers}                    {-u|--unread}
     {-I|--interesting-headers HDRS,...}   {-n|--message-numbers N1,...}
     {-E|--extract [LINES]}

     {-M|--match-header  STRING}           {-p|--parse}
     {-m|--match-text    STRING}           {-P|--no-parse}
     {-s|--sender        STRING}

     {--mmr|--match-me-regexp     REGEXP}  {--imap-folders}
     {--mhr|--match-header-regexp REGEXP}  {--imap-subscriptions}
     {--mtr|--match-text-regexp   REGEXP}

     {-S|--starttls}                       {--ssl-ca-file     FILE}
     {--ssl-verify-hostname}               {--ssl-ca-path     DIR}
     {--ssl-no-verify}                     {--ssl-version     PROTOCOL}

     {--prefer-stunnel |--no-prefer-perl-ssl}
     {--prefer-perl-ssl|--no-prefer-stunnel}
     {--prefer-socklib  CLASS1,...}        {--stunnel-program PROGRAM}

     {--connect-timeout SECONDS}           {-4|--ipv4-only}
     {--batch-size      COUNT}             {-6|--ipv6-only}
     {--block-size      BYTES}

     [folder ...]

 The -h option may be repeated up to 3 times for increased verbosity.

=head1 OPTIONS

Long-format options may be abbreviated as long as the result is not ambiguous.

=head2 FORMATTING OPTIONS

=over 2

=over 4

=item B<-c>, B<--count-only>

Only count the number of messages that would be displayed,
without displaying any other information about them.
E.g. B<-cu> would print the number of unread messages you have.

=item B<-e>, B<--envelope>

Show message envelope instead of headers.
This causes any formatting options (e.g. B<--columns>) to be ignored.

This option only makes sense for local folders and, to a lesser degree, imap folders.

=item B<-E>, B<--extract>, B<--extract=>I<LINES>

Print the body of each matched message.
If the optional argument I<LINES> is supplied,
print only the first LINES number of lines of the body.

In this case, the B<--format> option is ignored and a subset of the message
headers deemed "interesting" presented.  These headers can be specified via
the B<--interesting-headers> option (which see) or if the B<-all-headers>
option is specified, the entire original set of headers is displayed.

=item B<-C>, B<--columns=>I<COLS>

Truncate lines exceeding I<COLS> length on output.
If COLS is 0 or no option is specified and output is not to a terminal,
no truncation is done.

The default is the current width of the terminal.

This option has no effect when displaying message bodies;
only the normal summary mode is affected.

=item B<-I>, B<--interesting-headers=>I<H1,H2,...>

When extracting parts or all of message bodies (see C<--extract>),
display only the enumerated headers of those messages if they exist.

This option can be specified multiple times, and header names can be space
or comma separated.  The default set of headers are C<From>, C<To>,
C<Apparently-To>, C<Cc>, C<Newsgroups>, C<Subject>, C<Date>, C<Reply-To>.

=item B<-a>, B<--all-headers>

Show all headers.  Ignores B<--format>.

=item B<-1>, B<--one-line-headers>

Un-fold wrapped header lines so they display as a single line.
This is the default.

=item B<-2>, B<--multi-line-headers>

Do not un-fold wrapper header lines.
Display them as delivered.

=item B<-f>, B<--format=>I<FMT>

Use I<FMT> as the output format.
See the section L</"OUTPUT FORMAT"> for details.

The default is S<< C<"%-3{FMSGNO} %-20.20{FROMTO}  %-0.32Date  %Subject\n"> >>

=item B<-d>, B<--date-format>=I<FMT>

Format of the %Date field in summary output format (see B<--format>).
This string can be any format understood by the C<strftime> library function.
The default conforms to iso8601:2004.

If you use a configuration file (see L</"ENVIRONMENT">) you can assign a
string or a function to the C<$opt{date_format}> variable.  In the latter
case, the function will be called with a 9-element array of the parsed
timestamp plus a 10th element, the unparsed text string of the timestamp.
The values will be those parsed by C<localtime> with the time zone
specified by B<--time-zone> taken into consideration.  They are:

     0     1     2      3      4     5      6      7      8      9
   $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst, $raw

=item B<-p>, B<--parse>

Do fancy parsing of the C<From>, C<Subject>, and C<Date> fields.
This is the default unless extracting message bodies.

=item B<-P>, B<--no-parse>

Do not do fancy parsing of the C<From>, C<Subject>, and C<Date> fields.

=item B<-T>, B<--time-zone=>I<TZ>

By default, the C<Date> header is parsed and re-formatted per the
B<--date-format> option, but there are at least two useful time references:
the time the message was sent with respect to the sender, or the time the
message was sent with respect to the recipient.

If the I<TZ> parameter is the string C<local>, the time is represented in
local time, no matter what timezone the original date was in (assuming that
can be determined, but any rfc2822-compliant timestamp should be).

If the I<TZ> parameter is the string C<sender>, the time will be displayed
in the original timezone of the message.  The zone or offset itself may or
may not be displayed, depending on the date format given by
B<--date-format>, but the default includes it.

Any other value for I<TZ> is interpreted as a time zone specifier a la the
C<TZ> environment variable.  For example, if the parameter is given as
C<US/Eastern>, all dates will be displayed in United States Eastern
Standard/Daylight time.

The options B<--utc> and B<--gmt> are shorthand for S<--time-zone=UTC>.

=item B<--folder-time-zone=>I<TZ>

This option only meaningfully affects envelope timestamps.
See C<{ENVDATE}> for details.

=item B<--utf8>, B<--utf-8>

Convert header or body contents encoded in other charsets to UTF8 for display.

Furthermore, if B<--parse> is also enabled, decode From, To, and Subject
header fields with rfc1522-encoded values to UTF8.
That is, a Subject header with the raw contents

	Subject: =?windows-1252?B?b2ssIG9rLCBzbyBJIGxpZWQu?=

would decode to

        Subject: squeamish ossifrage

=item B<--no-utf8>, B<--no-utf-8>

Do not do any charset conversion or decoding of rfc1522-format headers.

=back

=back

=head2 SEARCH OPTIONS

=over 2

=over 4

=item B<-n>, B<--message-numbers=>I<N1,N2,...|FIRST-LAST|-LAST|FIRST->

Only display specific message numbers.  This option can be specified
multiple times and ranges are supported.  For example:

=over 2

=item * C<1,4,9>

Display messages 1, 4, and 9.

=item * C<3-5>

Display messages 3, 4, and 5.

=item * C<10->

Skip messages 1-9.

=item * C<-10>

Display the last 10 messages.

=back

Messages are always displayed in folder order even if message numbers
specified with this option are listed out of order.

=item B<-u>, B<--unread>

Only show information about unread messages.

Some protocols (e.g. POP3) do not store this information, so all messages
will be treated as unread.
But this is generally supported for IMAP and local mbox folders.

=item B<-m>, B<--match-text=>I<TEXT>

Seach for messages which contain I<TEXT> in one of the headers specified
with B<--match-header>.

Matching using this option is performed server-side for IMAP
folders and in that case is always case-insensitive, as required by
L<RFC3501 E<sect>6.4.4|http://tools.ietf.org/html/rfc3501#section-6.4.4>.
If you need case-sensitive search with IMAP folders, use
B<--match-text-regexp> instead.

=item B<-M>, B<--match-header=>I<H1,H2,...>

Search only headers included in list for text specified with B<--match-text>.
By default, the headers searched are
C<Sender>, C<From>, C<To>, C<Cc>, C<Subject>, and their C<Resent-> variants.

The pseudoheader C<{BODY}> can be used to search the actual message body.

This option may be repeated more than once.

=item B<-s>, B<--sender=>I<ADDR>

Show only messages sent from I<ADDR>.
This is equivalent to specifying the options
S<--match-header='From, Sender' --match-text=I<ADDR>>.

=item B<--mtr>, B<--match-text-regexp=>I<REGEXP>

Only print messages in which I<REGEXP> could be found in the header(s)
matching the regexp specified with B<--match-header-regexp>, or the list of
headers specified with B<--match-header> if the former is not specified.

This search is always performed client-side, which means that headers in
networked folders must be downloaded first in order to be searched.

=item B<--mhr>, B<--match-header-regexp=>I<REGEXP>

Seach only headers matching REGEXP for patterns specified with
B<--match-text> or B<--match-text-regexp>.

=item B<--mmr>, B<--match-me-regexp=>I<REGEXP>

Pattern to match against the C<From> field to determine whether you are the
sender (affects the C<{FROMTO}> format specifier).
Defaults to everything up until the first comma in your GECOS information.

=item B<-i>, B<--ignore-case>

Make text and regular expression searches case-insensitive.

=item B<--no-ignore-case>

Make searches case-sensitive.  This is the default.

Header names are always case-insensitive per RFC2822, so this does not
affect B<--match-header-regexp> or B<--match-header>.

=item B<--if>, B<--imap-folders>

Instead of printing a summary of the specified folders, print a list of all
the IMAP folders available to the user on the server.  For each folder, a
complete URI based on the current connection parameters is presented.

This option has no effect for non-IMAP folders and is mutually exclusive
with B<--imap-subscriptions>.

=item B<--is>, B<--imap-subscriptions>

Like B<--imap-folders>, but only print the folder URIs to which the user is
subscribed.

This option has no effect for non-IMAP folders and is mutually exclusive
with B<--imap-folders>.

=back

=back

=head2 CONNECTION AND SSL OPTIONS

=over 2

=over 4

=item B<-U>, B<--user=>I<USER>

Show headers of I<USER>'s messages.  This either selects that user's local
mbox file or provides the username for network mailboxen whose IMAP or POP3
urls don't specify one.

=item B<--timeout>=I<seconds>, B<--connect-timeout>=I<seconds>    (default: 10)

Abort if connection cannot be established within this many seconds.
(See the L</"BUGS"> section for caveats about this.)

=item B<-S>, B<--starttls>

Initiate encryption after establishing plain connection but before login.
This option has no effect if connecting via C<imaps> or C<pops>,
which establish encryption immediately.

=item B<--ssl-version>=I<SSL protocol>

Use the specified version of SSL.
The syntax for this follows that used by OpenSSL.
Recognized names include (but may not be limited to)
C<TLSv1.2>, C<TLSv1.1>, C<TLSv1>, C<SSLv3>, or C<SSLv2>.

The default is C<TLSv1.2>.

=item B<--ssl-ca-file>=I<certificate_file>

Location of CA (Certificate Authority) bundle.
If not specified, a few typical locations will be searched.

=item B<--ssl-ca-path>=I<certificate_directory>

Location of certificate files.
If not specified, a few typical locations will be searched.

=item B<--ssl-verify-hostname>

If server certificate is not signed by a recognized certificate authority,
compare the subject CN (Common Name) and matching aliases against the
server name or address, and accept the certificate if they match.

This is less secure than verification via a certificate signature chain.
Use of this option is not recommended.

=item B<--ssl-no-verify>

Do no certificate verification at all; just encrypt the connection.
Use of this option is discouraged.

=item B<--prefer-stunnel>, B<--no-prefer-perl-ssl>

Prefer using the stunnel program for encryption instead of the native perl
SSL library, if it is available.
This is the default, because it's usually faster.

=item B<--prefer-perl-ssl>, B<--no-prefer-stunnel>

Prefer using the native perl SSL interface (IO::Socket::SSL) instead of the
stunnel program, if it is available.

B<Note>: The perl SSL interface has been observed to be significantly
slower than stunnel, especially for large transfers in extraction mode.

=item B<--stunnel-program>=I<program_name>    (default: C<stunnel>)

Name of the stunnel program to call.  This can be a fully-qualified name or
a relative name that will be searched for in the user's PATH.

=item B<--prefer-socklib>=I<classes>          (default: C<inet6, ip, inet>)

Specify priority of perl classes to use for ordinary sockets.
The first available class is used.
This option can be specified multiple times and each argument can be a
comma or space-separated list of classes to try loading.

Class names should either be fully-qualified names or one of the following
specially-recognized aliases:

=over 2

=item * B<inet6>

IO::Socket::INET6; supports ipv4 and ipv6.

=item * B<ip>

IO::Socket::IP; supports ipv4 and ipv6.

=item * B<inet4>, B<inet>

IO::Socket::INET; supports ipv4 only.

=back

=item B<-4>, B<--ipv4-only>, B<-6>, B<--ipv6-only>

Use only IPv4 or IPv6 as indicated.
By default, whichever address family is available will be chosen,
subject to the whims and availability of the socket class used.

=back

=back

=head2 DEBUGGING, DIAGNOSTIC, AND PERFORMANCE OPTIONS

=over 2

=over 4

=item B<-h>, B<--help>

Usage information.
May be repeated 1-3 times for more verbosity.

=item B<-V>, B<--version>

Display the version number of this program.

Combined with the B<--debug> option, display extra information about SSL
libraries and optional modules used.

=item B<-W>, B<--warnings>

Enable Perl internal warnings.
This is mainly for debugging.

=item B<-D>, B<--debug>

Show protocol messages and replies, and some parsing results.  This option
may be repeated more than once for more verbose diagnostics.

B<Warning>: while passwords are elided from the output at debug level 1,
it is possible that one may be displayed at higher debug levels.

=item B<--batch-size>=I<n>

Fetch I<n> messages at a time from remote server, to reduce the number of
round trips over the network.  A value of 0 means fetch the entire folder
(or whatever messages were specified via the B<--message-numbers> option)
at once.  The default is 64.

Higher values may reduce round trip latency, but can also make the output
from this program appear choppier when run interactively.

=item B<--block-size>=I<n>

Read only I<n> bytes of data at a time from local folders or the network
while parsing.  The default is 524288 (512KiB).  Setting this value higher
will have diminishing performance improvement when not I/O bound, and
increase memory footprint significantly.

Regardless of this setting, for local mbox folders less than 16MiB the
entire file is read into memory at once to improve speed.

=back

=back

=head1 DESCRIPTION

This utility prints out a summary of the messages in a mailbox to show you
who your mail is from.  Local mbox files, POP3, and IMAP4 folders can be
specified.  Encryption with SSL, including STARTTLS support, is available
if your perl installation includes the C<IO::Socket::SSL> class or the
C<stunnel> program is available.

There are essentially two modes of operation: summary and extraction.

In summary mode, each message is summarized by a single line displaying the
message number in the folder, the sender (or recipient, if you sent the
message), the date, and subject.  This summary may be changed via the
B<--format> option and modified by numerous switches documented above.  By
default, some semantic parsing and decoding of the C<From> (and other known
address headers), C<Date>, and C<Subject> headers is performed to display
real names and normalized dates.

In B<--extract> mode, a portion or entirety of each message is displayed.
No semantic parsing of headers or MIME format bodies is currently done,
e.g. base64-encoded text will not be converted to readable form.
However, raw characters I<are> converted from non-UTF8 character sets to
UTF8 if the B<--utf8> option is enabled.

To download the complete contents of an imap folder to a local mbox file,
the following command could be issued:

	from --no-utf8 -aPE imap://foobar@blurdybloop.com/INBOX > foobar.mbox

=head1 FOLDER SPECIFICATION

=head2 IMAP4

To specify an IMAP folder:

=over 4

=over 4

=item imap://I<USER>:I<PASS>@I<HOST>:I<PORT>/I<MAILBOX>

=item imaps://I<USER>:I<PASS>@I<HOST>:I<PORT>/I<MAILBOX>

=back

=back

If C</> or C<:> characters form part of a username or password, they can be
preceded with a backslash (C<\>) character to prevent them from being
parsed as a field delimiter.  Since the C<@> character cannot be part of a
host name, only the final occurrence is treated as a field delimiter.  So
this character can be escaped as well, but it is not required.

Fields may be unspecified, in which case:

=over 4

=over 2

=item * I<USER> defaults to your current username

=item * I<PASS> is obtained from the C<FROMPASS> environment variable if not specified.

=item * I<HOST> defaults to C<localhost>

=item * I<PORT> defaults to C<143> (imap) or C<993> (imaps)

=item * I<MAILBOX> defaults to C<INBOX>

=back

=back

Currently, only the C<PLAIN LOGIN> authentication method is supported.

If no password is specified, you will be prompted to enter one.

=head2 POP3

To specify a POP3 folder:

=over 4

=over 4

=item pop3://I<USER>:I<PASS>@I<HOST>:I<PORT>/

=item pop3s://I<USER>:I<PASS>@I<HOST>:I<PORT>/

=back

=back

Escaping field-delimiting characters is available here as with IMAP URIs (see above).

Fields may be unspecified, in which case:

=over 4

=over 2

=item * I<USER> defaults to your current username

=item * I<PASS> is obtained from the C<FROMPASS> environment variable if not specified.

=item * I<HOST> defaults to C<localhost>

=item * I<PORT> defaults to C<110> (pop3) or C<995> (pop3s)

=back

=back

Currently, only the C<PASS> authentication method is supported.

If no password is specified, you will be prompted to enter one.

=head2 MBOX

To specify a local MBOX folder:

=over 4

=over 4

=item file://path/to/mbox

=item /path/to/mbox

=back

=back

=head1 OUTPUT FORMAT

=head2 Syntax

The I<FMT> specifier to the B<--format> option can contain literal text for
the output, along with header specifiers in the form

=over 4

=over 4

=item %{{-}{n}{.m}}Header

=back

=back

where

=over 4

=over 2

=item *

B<n> is the line width reserved for the value of B<Header>.

=item *

B<-> means that header strings shorter than B<n> chars are flushed left
within the field, instead of right.

=item *

B<.m> is the maximum allowed length of the field;
if the header string is longer than this, it is truncated.

=item *

B<Header> is the name of the header, e.g. C<Subject>.

=back

=back

=head2 Virtual Headers

Some special "header names" are defined for useful information that cannot
generally be obtained directly from message headers.

These special names, surrounded by curly braces (which, while technically
legal in real header names, rarely ever occur), are:

=over 4

=over 2

=item * B<{TMSGNO}>

The number of this message irrespective of any folder it may have come from
(if more than one folder was specified on the command line).

=item * B<{FMSGNO}>

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.

=item * B<{FOLDER}>

The name of this folder, as specified on the command line.

=item * B<{OCTETS}>

The size of this message, in 8-bit bytes.
This includes the body and all headers.

=item * B<{FROMTO}>

The sender of the message if it isn't you, or C<< To I<recipient> >> otherwise.

The option B<--match-me-regexp> sets the regexp which matches your email address.
By default, this is just your current full name (as identified in the password database).

=item * B<{ENVFROM}>

The sender address in the "envelope" of the message.  This is normally the
same address as in the C<Return-Path> header, but it is whatever the remote
mail transfer agent specified as the C<MAIL FROM> address during the SMTP
session which delivered the message.

=item * B<{ENVDATE}>

The local delivery time of the message.

B<NOTICE>: Since envelope timestamps usually have no timezone offset
indicator, these timestamps will be treated as "local" time by default.
If you are retrieving messages from a remote mailbox located in a different
timezone from your current one, use the B<--folder-time-zone> option to
change the timezone in which envelope timestamps are considered.

=back

=back

As usual, you can use general format specifiers, e.g C<%-4.3{TMSGNO}>.

=head2 Examples

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.
(C<-|> indicates the results here; it is not actually printed.)

        "%From  %Subject\n"
        -| Noah Friedman  example

        "%-19.18From %-13.12Date %-.45Subject\n"
        -| Noah Friedman       1994-10-18    example

        "To %-19To  %Date  %12Subject\n"
        -| To nobody@prep.ai.mit.edu  1994-10-18  10:22:50-0700       example

        "   From: %From\nSubject: %Subject\n   Date: %Date\n\n"
        -|    From: Noah Friedman
        -| Subject: example
        -|    Date: 1994-10-18  10:22:50-0700
        -|

If you use something like last example format specifier,
you may wish to use the B<--no-parse> option to avoid any parsing
(and therefore truncation) of the C<From> and C<Date> lines, in which case you would see

        -|    From: Noah Friedman <friedman@splode.com>
        -| Subject: example
        -|    Date: Tue, 18 Oct 94 12:22:50 CDT
        -|

=head1 ENVIRONMENT

=over

=item I<FROMRCPL>

Configuration file to load before parsing options.

If this variable is defined, that file and I<only> that file will be
loaded, if it exists.
When this variable is not defined, load the first file found in the list
C<$XDG_CONFIG_HOME/.fromrc.pl>, C<$HOME/.fromrc.pl>.

This should be a perl script which sets fields in the global C<%opt>
variable and/or C<%SSL_options> variable.  The easiest way to figure out
which parameters to modify is to look at the C<parse_options> function in
the source code of this program.

For example, if you wanted the date field to ignore the year unless it was
different from the current year, and you also wanted to show the offset of
the date from UTC only when showing timestamps in the sender's timezone,
you could do this:

	use POSIX qw(strftime);
	my $thisyear = strftime ("%Y", localtime (time)) - 1900;
        $opt{date_format}
          = sub { join ("",
                        ($_[5] != $thisyear
                         ? "%b %d %H:%M %Y"
                         : "%b %d %H:%M"),

                        ($opt{tzdate} eq 'sender'
                         ? " %z" : ""));
                };

Suppose you wanted to enable B<--utf8> mode automatically in the appropriate locale:

        $opt{utf8} = 1
          if (   (defined $ENV{LANG}     && $ENV{LANG}     =~ /utf-?8/i)
              || (defined $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i));

To specify a location for SSL certificates, one might add something like the following;

        $SSL_options{SSL_ca_file} = "/etc/pki/tls/certs/ca-bundle.crt";
        $SSL_options{SSL_ca_path} = "/etc/pki/tls/certs/";

=item I<FROMMAIL>, I<MAIL>

Mail folder to open if none is specified on the command line.
May be a local or remote folder.

C<MAIL> is only used if C<FROMMAIL> is not defined.

You can set a default folder in your ~/.fromrc.pl file as follows:

        $ENV{FROMMAIL} = 'imap://localhost/INBOX';

=item I<FROMUSER>

Default user for local and remote mailboxen.  If not specified, the
C<LOGNAME> or C<USER> environment variables are used instead.

=item I<FROMPASS>

Password for remote mailboxen, if not included in folder URL.
If no password is specified, one is prompted for interactively.

You can set a default password in your C<~/.fromrc.pl> file like so:

        $ENV{FROMPASS} = 'squeamish ossifrage';

or

        # chomp() will remove any trailing newline
        chomp ($ENV{FROMPASS} = `cat .secret`);

=back

=head1 REQUIREMENTS

Optional system packages that will improve the functionality of this program:

        Fedora/CentOS packages     Debian
        ----------------------     -------------
        perl-TimeDate              libtimedate-perl
        perl-Time-ParseDate        libtime-parsedate-perl
        perl-Text-CharWidth        libtext-charwidth-perl
        perl-IO-Socket-INET6       libio-socket-inet6-perl
        perl-IO-Socket-IP          libio-socket-ip-perl

For SSL, use stunnel 4.x or later, or install:

        IO::Socket::SSL            libio-socket-ssl-perl

Stunnel usually seems to be faster.

=head1 BUGS

Only plaintext authentication schemes are currently supported.

No integration with any password managers.

Search support is fairly primitive; you cannot build boolean
queries with different patterns for different headers.

The pseudoheaders ({ENVDATE}, etc) do not work with IMAP search queries.

No option for threaded display of summaries.

MIME entities are not parsed.
In extraction mode, for example, it would be useful to have the option to
display only the text/plain version of multipart/alternative messages,
or to decode quoted-printable and base64 text.

POP3 support is relatively primitive.  This isn't likely to change, since
this protocol is very primitive itself.

The C<IO::Socket::IP> class does not implement connection timeouts as of
perl v5.14, but does seem to as of v5.20.

=head1 SEE ALSO

stunnel(8)

=head1 AUTHOR

Noah Friedman <friedman@splode.com>

=head1 COPYRIGHT

This program is donated to the public domain.

=head1 ACKNOWLEDGEMENTS

The C<from> command originally appeared in 3.0BSD.

This Perl-based implementation drew much inspiration from a
version written in C by Brian Fox in 1990 for the GNU Project,
which they never released.

Support for the C<{FROMTO}> virtual header field was originally contributed
by Jonathan Kamens <jik@kamens.us>, who also provided suggestions which led
to the creation of the C<{ENVFROM}> and C<{ENVDATE}> virtual header fields.

=cut