#!/usr/bin/perl -Tw
use strict;

use Errno 'EINTR', 'ENOENT', 'ECONNRESET';
use Fcntl ':flock';
use POSIX ":sys_wait_h";
use IO::Handle;
use IO::Socket;
use Sys::Hostname;

# Configure:

# If you want to bind low ports, you'll have to run proxypot as root. If you
# want it to change to another user after binding the ports, specify the user
# here. The first existing user in this list will be used. The abuser can see
# what you choose here through identd, so using "squid" by default makes the
# proxypot more convincing, but if you're afraid it might accidentally stomp
# on your real squid-owned files, put "nobody" at the front of the list and
# take out the others.
my @runas_user=qw/ squid apache www-data nobody /;

# Everything gets logged to a file, which rotates itself periodically. For
# rotation to work, it needs write permission on the directory that contains
# the logfile.
my $logfile='/var/log/proxypot';
my $logrotate_seconds=86400;

# The log file is large, hard to read, and harder to search. But it is
# complete. It tells about failed connections, aborted SMTP transactions, and
# connections that did not involve SMTP at all. You can also deliver mail
# messages to an mbox or maildir, which won't contain as much information but
# should be easier to deal with, considering the wide variety of existing
# tools for reading mboxes and maildirs (mailx, courier-imap, Mozilla, etc.)
# Maildir is recommended because the mbox locking might be flaky.
my $mbox=undef;
my $maildir=undef;

# Limit the amount of your bandwidth that can be used by the proxypot. The
# default 1k/s is for comfortable use on a slow modem; others should increase
# this number a lot!
my $max_kilobytes_per_second=1;

# Limit the total number of proxied connections to each /32, /24, /16, and
# the whole Internet, in any 10 minute period
my $max_connects_per_destination_host_per_10_minutes=10;
my $max_connects_per_destination_C_per_10_minutes=50;
my $max_connects_per_destination_B_per_10_minutes=200;
my $max_connects_per_destination_any_per_10_minutes=300;

# Limit the number of connections that will be kept alive at the same time.
# "Connection" here means a pair of TCP connections, one on each side of the
# proxy. Limit by the /32, /24, and /16 of the client who connected to your
# proxypot, and other limit for all clients together.
my $max_simultaneous_connections_per_client_host=10;
my $max_simultaneous_connections_per_client_C=15;
my $max_simultaneous_connections_per_client_B=40;
my $max_simultaneous_connections_per_client_any=50;

# Limit the rate of RCPT and VRFY commands sent to each target SMTP server.
# This only applies when the commands are actually being proxied; when they
# are faked internally the only limit in effect is the bandwidth limit.
my $seconds_between_rcpts_per_destination_host=10;

# Choose which ports and incoming protocols to support. A smart tester might
# notice that several proxies are running on the same IP address, and become
# suspicious that they are a proxypot. If that seems to be happening, just
# choose one protocol and disable the others.
my @incoming = (
  [ http => 3128 ],
  [ http => 8080 ],
  [ socks => 1080 ],
  [ wingate => 23 ]
);

# Set which of your IP addresses are used by your proxypot. 0.0.0.0 listens
# on all addresses. If you have multiple IP addresses and don't want them all
# to be seen as open proxies, replace the 0.0.0.0 with a space-separated list
# of addresses.
my @selfaddrs=qw/ 0.0.0.0 /;

# Limit the length of a proxy chain. If you don't allow connections to other
# proxies in the allow/deny table, these limits don't matter. The result of
# mixing real and fake proxies in the same chain
my $max_real_proxy_chain_length=10;
my $max_fake_proxy_chain_length=100;

# Some testers might use GET commands sent directly to the proxy to find out
# if it works. This is a different mechanism from CONNECT commands requesting
# port 80 of another server, which are handled according to the normal
# allow/deny table below. This option also determines the behavior when GET
# commands are sent along a proxy chain where the end node is currently a
# (real or fake) HTTP proxy awaiting its CONNECT command. The value of this
# option is 1 or 2, corresponding to the http1 or http2 levels described
# below, or 0 to deny all commands other than CONNECT.
my $direct_http_commands=1;

# If we don't know the type of a target SMTP server, we can pretend to be a
# qmail server. That's a good choice because qmail's minimalistic responses
# to SMTP commands are easy to fake. Other choices are:
# aimc aol apex asterisks domino earthlink exchange55 exim firstclass fsmtpd
# gordano groupwise imail intermail juno litemail lsmtp lyris merak mercury
# microsoft50 microsoft55 navgw nplex pmdf postfix postini sendmail8
# sendmail9 sendmail12 smtpprox smtprcv stalker turbosendmail viruswall
# webshield yahoo zmailer
my $smtp_servertype_default='qmail';

# Choose which connections to allow. Entries higher in the list have
# precedence over lower ones. By default connections to localhost and to
# private IP addresses are denied because you might not want outsiders to get
# there. You might also want to deny connections to yourself on your own
# external IP address(es). This is done by the "self/32" block according to
# the @selfaddrs list above.
#
# When a connection is allowed, you must decide what to do with the data
# that is sent. For SMTP there are 3 levels of emulation. The higher levels
# are more realistic but they achieve that realism by making real connections
# to the destination SMTP server, which may anger sensitive administrators.
# THE PROXY WILL NEVER COMPLETE THE SENDING OF AN SMTP MESSAGE.
#
# smtp1: the whole SMTP connection is faked.
# smtp2: connect to the real SMTP server, read its 220 banner and maybe issue
#        a HELP command to find out what kind of server it is, then hang up
#        and use that information to fake a more convincing SMTP session.
# smtp3: connect to the real SMTP server and pass through all recognized
#        commands except DATA and EXPN. RCPT and VRFY are rate-limited.
#
# For HTTP, the levels are:
#
# http1: Fake empty 200 reply to any valid request
# http2: Pass through safe-looking GET commands (short URLs with no "cgi" or
#        other dynamic-content indicators, and no weird ports) and fake empty
#        200 reply to all other request types
#
# When the client tries to connect to another proxy (forming part of a proxy
# chain), you can either fake success or really let it connect. Either way,
# when the end of the chain is reached, the final connection will be handled
# as usual - it might be a fake SMTP session, a partially fake SMTP session,
# or it might just be refused, depending on where it tries to go.
#
# socks1: pretend to connect to a server and accept a socks connect request
# socks2: actually connect to a server to confirm it exists, then hang up and
#         fake the rest
# socks3: actually connect to a server and pass through a socks connect request
#         if the destination is one that would be allowed directly
# httpc1: pretend to connect to a server and accept an http connect request
# httpc2: actually connect to a server to confirm it exists, then hang up and
#         fake the rest
# httpc3: actually connect to a server and pass through an http connect request
#         if the destination is one that would be allowed directly
#
# In a proxy chain, fake proxies specified as httpc2 and socks2 will always
# get their connection directly from the proxypot, because if we connect to
# it through the proxy chain and then drop the connection, we'll have to
# reestablish the entire chain before continuing.
#
# For other protocols, you can allow a "banner" connection, which allows the
# client to connect and see whatever the server sends, but does not allow him
# to send anything the other way. This might fool some testers and shouldn't
# cause any real trouble for the servers he's trying to abuse. Only a small
# chunk of data will be passed through, to avoid accidentally providing full
# proxying for services which don't require the client to send anything.
#
# The "client/32" rule allows anyone to connect back to his own IP address,
# and use the "raw" protocol which means we actually behave as a true open
# proxy. There is a severe bandwidth limit on this protocol, and it doesn't
# allow connections that look like part of a proxy loop. You can't configure
# the "raw" protocol on anything other than "client/32" so don't try.
my @allow_deny = (
#   coming from          connecting to        to port range     action
  [ '0.0.0.0/0',         '127.0.0.0/8',       0 => 65535,       'deny' ],
  [ '0.0.0.0/0',         '10.0.0.0/8',        0 => 65535,       'deny' ],
  [ '0.0.0.0/0',         '172.16.0.0/12',     0 => 65535,       'deny' ],
  [ '0.0.0.0/0',         '192.168.0.0/16',    0 => 65535,       'deny' ],
  [ '0.0.0.0/0',         'self/32',           0 => 65535,       'deny' ],
  [ '0.0.0.0/0',         '0.0.0.0/0',         25 => 25,         'smtp2' ],
  [ '0.0.0.0/0',         '0.0.0.0/0',         587 => 587,       'smtp2' ],
# [ '0.0.0.0/0',         '0.0.0.0/0',         80 => 80,         'http1' ],
  [ '0.0.0.0/0',         '0.0.0.0/0',         1080 => 1080,     'socks1' ],
  [ '0.0.0.0/0',         '0.0.0.0/0',         3128 => 3128,     'httpc1' ],
  [ '0.0.0.0/0',         '0.0.0.0/0',         8080 => 8080,     'httpc1' ],
# [ '0.0.0.0/0',         'client/32',         1024 => 65535,    'raw' ],
  [ '0.0.0.0/0',         '0.0.0.0/0',         0 => 65535,       'banner' ]
);

# If defined, dumps all variables to "$debugfile" on SIGUSR1
my $debugfile=undef;

# Stop configuring

# Changes:
# Tue Nov 12 15:22:22 EST 2002
# Die if there is any failure writing to the log
#
# Tue Nov 12 15:51:41 EST 2002
# Child processes die cleanly if parent is killed
#
# Wed Nov 13 16:06:27 EST 2002
# Apply connect rate-limit to proxied HTTP GET commands
#
# Wed Nov 13 16:17:57 EST 2002
# Consolidate some redundant rate-limit-related code into rlsleep()
#
# Wed Nov 13 17:06:08 EST 2002
# RBSF added - no more single-byte-sysread loops, and banner logs client data
#
# Wed Nov 13 17:38:24 EST 2002
# raw protocol implemented
#
# Tue Dec  3 00:20:39 EST 2002
# Ignore spurious slash in CONNECT command that some broken tester is using
#
# Thu Dec  5 13:19:39 EST 2002
# Fix bug: some unsafe GET commands were getting rejected instead of empty 200
#
# Fri Feb 14 20:59:56 EST 2003
# fix a socks reply bug - \8 isn't a valid octal escape
#
# Mon Feb 17 13:45:59 EST 2003
# When starting a fake serverproto, don't try to close nonexistent serversock
#
# Tue Feb 18 21:27:11 EST 2003
# Add litemail (bigfoot's mail server) as a recognized type. Its bogus HELP
# reply broke the generic detection.
#
# Tue Feb 18 21:29:57 EST 2003
# Let's try ReuseAddr so maybe you can kill and restart this thing quicker
#
# Wed Feb 19 10:39:28 EST 2003
# Add zmailer as a recognized server type
#
# Wed Feb 19 10:41:39 EST 2003
# Make stderr follow log rotations
#
# Wed Feb 19 10:49:48 EST 2003
# Log the "simultaneous connection limit" condition
#
# Wed Feb 19 12:30:04 EST 2003
# Idle connections take up slots in the connection table. Time them out.
#
# Wed Feb 19 15:00:07 EST 2003
# Fix bug: connection limits were using acceptaddr instead of clientaddr! D'oh!
#
# Wed Feb 19 16:22:45 EST 2003
# Log which SOCKS protocol version is used.
#
# Wed Feb 19 21:09:56 EST 2003
# Add apex as a recognized server type. With another misformatted HELP reply.
#
# Thu Feb 20 10:18:59 EST 2003
# Spread out RCPTs more. Clients get impatient if you sleep for 60 seconds
#
# Thu Feb 20 10:29:52 EST 2003
# Better logging of write errors
#
# Thu Feb 20 10:52:24 EST 2003
# Fix bug: an SMTP server that dropped connection when we were expecting a
# banner or reply would cause an infinite loop
#
# Thu Feb 20 11:33:03 EST 2003
# Handle mail messages containing lines that are too long for SMTP.
#
# Thu Feb 20 12:02:40 EST 2003
# Fix identification of InterMail servers
#
# Thu Feb 20 12:17:23 EST 2003
# Preserve errno when we call alarm(0), to fix error reporting
#
# Thu Feb 20 14:00:13 EST 2003
# Fix $datasize
#
# Thu Feb 20 15:43:50 EST 2003
# Fixing the infinite loop bug uncovered another bug: RBSF::getc was not
# handling EOFs correctly.
#
# Thu Feb 20 23:21:40 EST 2003
# Oops, cleanstr translated tabs to \r instead of \t. Cut and paste coding...
#
# Fri Feb 21 11:59:49 EST 2003
# If the connect rate-limit imposes a long sleep, the client may hang up.
# Detect it and handle it by cancelling the connect.
#
# Sat Feb 22 09:58:06 EST 2003
# Log host lookup failure when CONNECT is given a bad hostname
#
# Sat Feb 22 11:36:14 EST 2003
# stalker is nostdbanner
#
# Sat Feb 22 15:26:02 EST 2003
# Fix bug in imail detection
#
# Tue Mar  4 09:15:01 EST 2003
# cleanstr was ambiguous: "\13" could mean chr(1)."3" or chr(013).
#
# Tue Mar  4 15:50:33 EST 2003
# Some Micros~1 servers ignore empty lines on input instead of replying 500
# (One-to-one correspondence between commands and replies? Ha! Too simple!)
# And some spamware targeting MSN apparently depends on this behavior.
#
# Tue Mar  4 16:05:01 EST 2003
# Log HTTP request headers (finally!)
#
# Tue Apr  8 16:14:24 EST 2003
# Accept and drop connections when global simul limit is hit, instead of
# leaving them in SYN_RECV limbo.
#
# Tue Apr 28 14:03:36 EST 2003
# Do a debugging dump on SIGHUP - maybe I'll find a memory leak
#
# Tue Apr 28 17:37:51 EST 2003
# Not exactly a leak, but the rate-limit database was accumulating a lot of
# stale entries, so scrub() was added to clean them out.
#
# Thu May  1 17:40:50 EST 2003
# Add smtpprox as a recognized server type. Worst... HELP reply... Ever!
#
# Sat May  3 15:01:07 EST 2003
# Deliver SMTP messages to an mbox
#
# Sat May  3 19:00:16 EST 2003
# Optimize away some unnecessary rate-limit calculations (major CPU relief)
#
# Sun May  4 18:48:55 EST 2003
# Deliver SMTP messages to a maildir
#
# Mon May  5 17:03:07 EST 2003
# Change the debugging signal from HUP to USR1 - HUP should mean reconfigure
# (and probably will at some later date)
#
# Wed May  7 16:31:57 EST 2003
# maildir delivery was checking /tmp/ instead of tmp/ for filename conflicts.
# Fixed it to check the right place.
#
# Wed May  7 16:43:01 EST 2003
# maildir delivery had filename conflicts! maildir(5) doesn't tell the whole
# story. Now using time.PID_msgnum.host instead of time.PID.host
#
# Fri Jul 25 14:00:40 EST 2003
# Detect client hangups during read rate limit sleeps, and handle by
# returning a read error.
#
# Fri Jul 25 14:19:57 EST 2003
# Ignore another variation of the spurious slash
#
# Fri Jul 25 15:53:31 EST 2003
# The client hangup issue turns out to be more difficult than expected.
# Detecting the hangup requires a read, which can require a sleep. Infinite
# recursion found and fixed.

# TODO (long term): NNTP, IRC, HTTPS(generate fake certificate and carry on
# with HTTP), generate stats (unique clients, total messages, total RCPTs,
# duplicated RCPTs==possible seeds), rewrite in C

# RBSF.pm taken from another project of mine - line mode operations have some
# shortcomings but fortunately none of them matter for proxypot. By the way
# it stands for "read-buffered selectable filehandle".
package RBSF;
use strict;

# $r=new RBSF(new FileHandle)
sub new
{
  return undef if !defined($_[1]);
  my $self={
    fh => $_[1],
    rbuf => '',
    eofseen => 0
  };
  return bless $self, $_[0];
}

# $r->write($s) returns bytes written or undef on error
sub write
{
  return syswrite($_[0]{fh}, $_[1]);
}

# $r->print(@s) returns true if all written, undef otherwise
sub print
{
  my $self=shift();
  my $data=join '',@_;
  my $wrote=0;
  while($wrote<length($data)) {
    my $w=syswrite($self->{fh}, $data, length($data)-$wrote, $wrote);
    if(!defined($w)) {
      return undef;
    }
    $wrote+=$w;
  }
  return $wrote || 1;
}

# $r->readline() returns line, which is empty on EOF, or undef on error
sub readline
{
  my $self=shift();
  my $ret='';
  while(substr($ret, -1, 1) ne "\n" && !$self->{eofseen}) {
    if(!$self->_underflow()) {
      return undef;
    }
    $self->{rbuf} =~ s/^([^\n]*(?:\n|\z))//;
    $ret .= $1;
  }
  return $ret;
}

# $r->read($s, $n) puts a chunk in $s, returns its length (max $n), undef on err
sub read
{
  my $self=shift();
  if(!$self->_underflow()) {
    return undef;
  }
  my $data=substr($self->{rbuf}, 0, $_[1]);
  substr($self->{rbuf}, 0, $_[1])='';
  $_[0]=$data;
  return length($data);
}

# $r->fullread($s, $n) reads until $n bytes or EOF, returns length, undef on err
sub fullread
{
  my $self=shift();
  while(length($self->{rbuf})<$_[1] && !$self->{eofseen}) {
    if(!$self->_underflow(4096)) {
      return undef;
    }
  }
  my $data=substr($self->{rbuf}, 0, $_[1]);
  substr($self->{rbuf}, 0, $_[1])='';
  $_[0]=$data;
  return length($data);
}

# $r->getc() returns a char, '' on EOF, undef on error
sub getc
{
  my $self=shift();
  if(!$self->_underflow()) {
    return undef;
  }
  return $1 if $self->{rbuf} =~ s/^(.)//s;
  return '';
}

# @rfds=( (new FileHandle), new RBSF(new FileHandle) )
# ($nfound,$timeleft)=RBSF::select(\@rfds, \@lrfds, \@wfds, \@efds, $timeout)
sub select
{
  my ($rfds,$lrfds,$wfds,$efds,$timeout)=@_;
  my (@foundrfds,@foundlrfds,@foundwfds,@foundefds,@lowrfds,@lowwfds,@lowefds);
  for my $r (@$rfds) {
    if($r->isa('RBSF')) {
      if(length($r->{rbuf})) {
        push(@foundrfds, $r);
        push(@lowrfds, undef);
      } else {
        push(@lowrfds, $r->{fh});
      }
    } else {
      push(@lowrfds, $r);
    }
  }
  for my $lr (@$lrfds) {
    if($lr->{eofseen} || $lr->{rbuf} =~ /\n/) {
      push(@foundlrfds, $lr);
      push(@lowrfds, undef);
    } else {
      push(@lowrfds, $lr->{fh});
    }
  }

  # $lowrfds[FOO] now corresponds to (@$rfds,@$lrfds)[FOO]
  my $orignumrfds=@$rfds;

  @lowwfds = map { $_->isa('RBSF') ? $_->{fh} : $_ } @$wfds;
  @lowefds = map { $_->isa('RBSF') ? $_->{fh} : $_ } @$efds;

  my $timeleft = $timeout;
  my ($rout, $wout, $eout);
  do {
    my ($rbits, $wbits, $ebits)=('','','');
    for(@lowrfds) { vec($rbits, fileno($_), 1)=1 if defined; }
    for(@lowwfds) { vec($wbits, fileno($_), 1)=1; }
    for(@lowefds) { vec($ebits, fileno($_), 1)=1; }
    my $lownfound;
    ($lownfound, $timeleft) =
      select($rout=$rbits, $wout=$wbits, $eout=$ebits, (@foundrfds || @foundlrfds)?0:$timeleft);
    if(!defined($lownfound) || $lownfound==-1) {
      if(wantarray) {
        return (undef, undef);
      } else {
        return undef;
      }
    }
    for my $i ($orignumrfds..$#lowrfds) {
      if(defined($lowrfds[$i]) && vec($rout, fileno($lowrfds[$i]), 1)) {
        my $lr=$lrfds->[$i-$orignumrfds];
        if(!$lr->_underflow(4096)) {
          if(wantarray) {
            return (undef, undef);
          } else {
            return undef;
          }
        }
        vec($rout, fileno($lowrfds[$i]), 1)=0;
        if($lr->{eofseen} || $lr->{rbuf} =~ /\n/) {
          undef $lowrfds[$i];
          push(@foundlrfds, $lr);
        }
      }
    }
  } while($timeleft && !@foundrfds && !@foundlrfds &&
          $rout =~ /^\0*\z/ && $wout =~ /^\0*\z/ && $eout =~ /^\0*\z/);
  for my $i (0..$orignumrfds-1) {
    push(@foundrfds, $rfds->[$i])
      if defined($lowrfds[$i]) && vec($rout, fileno($lowrfds[$i]), 1);
  }
  for my $i (0..$#lowwfds) {
    push(@foundwfds, $wfds->[$i])
      if defined($lowwfds[$i]) && vec($wout, fileno($lowwfds[$i]), 1);
  }
  for my $i (0..$#lowefds) {
    push(@foundefds, $efds->[$i])
      if defined($lowefds[$i]) && vec($eout, fileno($lowefds[$i]), 1);
  }
  @{$_[0]}=@foundrfds;
  @{$_[1]}=@foundlrfds;
  @{$_[2]}=@foundwfds;
  @{$_[3]}=@foundefds;
  if(wantarray) {
    return (@{$_[0]}+@{$_[1]}+@{$_[2]}+@{$_[3]}, $timeleft);
  } else {
    return @{$_[0]}+@{$_[1]}+@{$_[2]}+@{$_[3]};
  }
}

# $r->sockname passes through the request to the underlying filehandle
sub sockname
{
  my $self=shift();
  return $self->{fh}->sockname(@_);
}

# $r->close passes through the request to the underlying filehandle
sub close
{
  my $self=shift();
  return $self->{fh}->close(@_);
}

# internal, don't touch
sub _underflow
{
  my $self=shift();
  my $aggressive=shift();
  my $no_hooks=shift();
  if((!$aggressive && length($self->{rbuf})) || $self->{eofseen}) {
    return 1;
  }
  my $try=$aggressive || 4096;
  !$no_hooks and $self->{before_read}
             and !$self->{before_read}->($try)
             and return undef;
  my $r=sysread($self->{fh}, $self->{rbuf}, $try, length($self->{rbuf}));
  !$no_hooks and $self->{after_read}
             and $self->{after_read}->($try, $r || 0);
  if(!defined($r)) {
    return undef;
  }
  if(!$r) {
    $self->{eofseen}=1;
  }
  return 1;
}

# This part added just for proxypot:

# $r->eofahead() tries to return true if EOF or error is coming
sub eofahead
{
  my $self=shift();
  my $aggressive=shift();
  return 1 if $self->{eofseen};
  return 0 if $self->{rbuf};
  my $nfound=RBSF::select([$self], [], [], [], 0);
  return 1 if !defined($nfound);
  return 0 if !$nfound;
  return 0 if !$aggressive;
  return 1 if !$self->_underflow(1, 1);
  return 1 if $self->{eofseen};
}

# Hooks for rate-limiting. This could probably get cleaner...
sub set_read_hooks
{
  my $self=shift();
  $self->{before_read}=shift();
  $self->{after_read}=shift();
}
# End RBSF.pm
package main;

sub iscidr;
sub iscidr_withspecials;
sub iscidrlist_withspecials;
sub clientok;
sub cleanstr;
sub proxy_request;
sub spawnchild;
sub readfromchild;
sub handle_http_proxyreq;
sub handle_socks_proxyreq;
sub handle_wingate_proxyreq;
sub handle_serverproto;
sub passthrough_proxy_request;

##### Check the allow/deny table for errors #####
for (@allow_deny) {
  $_={
    clientaddr  => $_->[0],
    destaddr    => $_->[1],
    destportmin => $_->[2],
    destportmax => $_->[3],
    outproto    => $_->[4]
  };
  $_->{destaddr}='client/32' if $_->{outproto} eq 'raw';
  if(!iscidr($_->{clientaddr})) {
    die "Invalid client specification $_->{clientaddr}\n";
  }
  if(!iscidr_withspecials($_->{destaddr})) {
    die "Invalid destination specification $_->{destaddr}\n";
  }
  if($_->{destportmin} !~ /^\d+$/) {
    die "Invalid destination port specification $_->{destportmin}\n";
  }
  if($_->{destportmax} !~ /^\d+$/) {
    die "Invalid destination port specification $_->{destportmax}\n";
  }
  if($_->{destportmin} > $_->{destportmax}) {
    die
      "Invalid destination port range $_->{destportmin} => $_->{destportmax}\n";
  }
  if($_->{outproto} !~
     /^(?:http[12]|smtp[123]|httpc[123]|socks[123]|raw|banner|deny)$/) {
    die "Invalid protocol $_->{outproto}\n";
  }
}

##### Set up the listening sockets #####
if(@selfaddrs>1 && grep { $_ eq '0.0.0.0' } @selfaddrs) {
  die "\@selfaddrs contains 0.0.0.0 and extra junk\n";
}
if(@selfaddrs==1 && $selfaddrs[0] eq '0.0.0.0') {
  @selfaddrs=();
}
my @tmp=();
for my $inspec (@incoming) {
  my ($inproto, $listenport)=@$inspec;
  if(!@selfaddrs) {
    my $s=new IO::Socket::INET(Listen => 5,
                               LocalPort => $listenport, ReuseAddr => 1);
    print(STDERR "$listenport: $!\n"), next if !$s;
    push(@tmp,
      {
        inproto => $inproto,
        listenport => $listenport,
        listensock => $s,
        listenaddr => ''
      });
  } else {
    for my $a (@selfaddrs) {
      my $s=new IO::Socket::INET(Listen => 5,
                                 LocalAddr => "$a:$listenport", ReuseAddr => 1);
      print(STDERR "$a:$listenport: $!\n"), next if !$s;
      push(@tmp,
        {
          inproto => $inproto,
          listenport => $listenport,
          listensock => $s,
          listenaddr => $a
        });
    }
  }
}
if(!@tmp) {
  die "No listeners, giving up\n";
}
@incoming=@tmp;

##### Switch UID #####
if($<==0) {
  for my $username (@runas_user) {
    my @u=getpwnam($username);
    print(STDERR "$username not found\n"), next if !@u;
    # TODO: supplementary groups (where is perl's initgroups()?)
    my $uid=$u[2];
    my $gid=$u[3];
    $)="$gid gid";
    $(=$gid;
    $<=$>=$uid;
    last;
  }
}

##### Make sure the log works #####
open(LOG, ">>$logfile") or die "$logfile: $!\n"; LOG->autoflush();
LOG->autoflush();
my $mainpid=$$;
my $logstart=time();
$SIG{PIPE}='IGNORE';
# TODO: save up log messages for periodic dumping to the $mbox or $maildir,
# excluding log messages which are already being delivered to the $mbox or
# $maildir as part of a mail message header or body
sub printlog {
  if($$==$mainpid) { # Only the main process rotates the log
    my $now=time();
    if($now > $logstart+$logrotate_seconds) {
      if(rename($logfile, "$logfile.$now")) {
        open(LOG, ">>$logfile") or die "$logfile: $!\n";
        open(STDERR, ">&LOG");
        LOG->autoflush();
        $logstart=$now;
      }
    }
  }
  print LOG scalar(localtime()), ' ', @_, "\n" or die "$logfile: $!\n";
}

##### Set up debugging hook #####
sub debughook;
$SIG{USR1}=\&debughook;
# TODO: handle SIGTERM (In child process, print a "dying" log entry with $id,
# and then exit nicely. In parent, send a SIGTERM to each child, wait for
# them all to go away, then print a "dying" log entry.)

##### Prepare for delivery #####
if(defined($maildir)) {
  chdir($maildir) or die "$maildir: $!\n";
  -d 'new' or mkdir('new') or die "$maildir/new: $!\n";
  -d 'tmp' or mkdir('tmp') or die "$maildir/tmp: $!\n";
  -d 'cur' or mkdir('cur');
}
my $proxypot_hostname=hostname;

printlog "Bubblegum proxypot 20030725a starting";
open(STDERR, ">&LOG"); # in case perl barfs later, save the message

##### Global state #####
my $boottime=time();
my $serial=0;
my %active=(); # $active{$pid}{fd}, $active{$pid}{id}
my %active_connections_byhost=();
my %active_connections_byC=();
my %active_connections_byB=();
my $dumpkid;

### Notice when children exit
my $chld=0;
$SIG{CHLD}=sub { $chld=1; };

##### Main loop #####
while(1)
{
  ### set up select parameters ###
  my @rfds=();
  my @lrfds=();
  for my $in (@incoming) {
    push(@rfds, $in->{listensock});
  }
  for my $kid (values %active) {
    next if !defined $kid->{fd};
    push(@lrfds, $kid->{fd});
  }

  ### wait for event ###
  my $nfound=RBSF::select(\@rfds, \@lrfds, [], []);
  my $saveerrno=$!;
  if($chld) {
    my $kidpid;
    while(1) {
      $kidpid = waitpid(-1,WNOHANG);
      last if $kidpid==-1 || $kidpid==0;
      if($dumpkid && $kidpid==$dumpkid) {
        printlog "Debugging dump finished";
        $dumpkid=undef;
        next;
      }
      my $kid=$active{$kidpid};
      die if !defined $kid->{clientip_C_B} || !defined $kid->{clientip_C_B}[0];
      --$active_connections_byhost{$kid->{clientip_C_B}[0]};
      --$active_connections_byC{$kid->{clientip_C_B}[1]};
      --$active_connections_byB{$kid->{clientip_C_B}[2]};
      delete $active{$kidpid};
      printlog "Cleaned up child process $kidpid";
    }
  }
  $!=$saveerrno;
  if(!defined($nfound) || $nfound==-1) {
    if($!==EINTR && $chld) {
      $chld=0;
      # not an error
    } else {
      printlog "select: $!";
    }
    next;
  }
  $chld=0;

  ### coordinate rate limits among child processes ###
  for my $kid (values %active) {
    next if !defined $kid->{fd};
    if(grep { $_==$kid->{fd} } @lrfds) {
      readfromchild($kid);
    }
  }

  ### accept new connections ###
  for my $in (@incoming) {
    if(grep { $_==$in->{listensock} } @rfds) {
      my ($clientsock, $clientaddr)=$in->{listensock}->accept();
      next if !$clientsock;
      $clientsock->autoflush();
      $clientsock=new RBSF($clientsock);
      my $acceptaddr=$clientsock->sockname();
      $clientsock->close(), next if !$acceptaddr;
      my ($acceptport, $acceptip)=unpack_sockaddr_in($acceptaddr);
      $acceptip=inet_ntoa($acceptip);
      my ($clientport, $clientip)=unpack_sockaddr_in($clientaddr);
      $clientip=inet_ntoa($clientip);
      my $ip_C_B=clientok($clientip);
      $clientsock->close(), next if !$ip_C_B;
      my $now=time();
      my $id=$serial++.",$now";
      my $kid=spawnchild($id, $clientsock, $clientip, $in->{inproto});
      $clientsock->close(); # Either the child has it, or it's screwed anyway.
      if(!$kid) {
        --$active_connections_byhost{$ip_C_B->[0]};
        --$active_connections_byC{$ip_C_B->[1]};
        --$active_connections_byB{$ip_C_B->[2]};
        next;
      }
      printlog "$id: accepted connection on $acceptip:$acceptport from ".
               "$clientip:$clientport, created process $kid->{pid}";
      $kid->{clientip_C_B}=$ip_C_B;
      $active{$kid->{pid}}=$kid;
    }
  }
}

# Return an unambiguous single-line ASCII representation of an arbitrary string
sub cleanstr
{
  my $s=$_[0];
  my $l=length($s);
  my $ret='"';
  my $i;
  for($i=0;$i<$l;++$i) {
    my $c=substr($s, $i, 1);
    my $cc=ord($c);
    if($c eq "\n") {
      $ret .= "\\n";
    } elsif($c eq "\t") {
      $ret .= "\\t";
    } elsif($c eq "\r") {
      $ret .= "\\r";
    } elsif($cc < 32 || $cc > 126) {
      my $nextc=substr($s, $i+1, 1);
      if($nextc =~ /\d/) {
        $ret .= "\\".sprintf("%03o", $cc);
      } else {
        $ret .= "\\".sprintf("%o", $cc);
      }
    } elsif($c eq "\\" || $c eq '"') {
      $ret .= "\\".$c;
    } else {
      $ret .= $c;
    }
  }
  $ret .= '"';
  return $ret;
}

sub clientok
{
  my $ip=$_[0];
  # TODO: Test client reaction to the accept-and-drop behavior. If it looks
  # bad, try closing the listen sockets when the global simul limit is
  # reached.
  if(keys %active >= $max_simultaneous_connections_per_client_any) {
    printlog "Got new connection from $ip with ".scalar(keys %active).
             " already active. Dropping the new connection.";
    return undef;
  }
  $active_connections_byhost{$ip} ||= 0;
  if($active_connections_byhost{$ip} >=
     $max_simultaneous_connections_per_client_host) {
    printlog "Got new connection from $ip with $active_connections_byhost{$ip}".
             " already active from same client. Dropping the new connection.";
    return undef;
  }
  my $C=$ip;
  $C =~ s/\.\d+$//;
  $active_connections_byC{$C} ||= 0;
  if($active_connections_byC{$C} >=
     $max_simultaneous_connections_per_client_C) {
    printlog "Got new connection from $ip with $active_connections_byC{$C}".
             " already active in $C.*. Dropping the new connection.";
    return undef;
  }
  my $B=$C;
  $B =~ s/\.\d+$//;
  $active_connections_byB{$B} ||= 0;
  if($active_connections_byB{$B} >=
     $max_simultaneous_connections_per_client_B) {
    printlog "Got new connection from $ip with $active_connections_byB{$B}".
             " already active in $B.*.*. Dropping the new connection.";
    return undef;
  }
  ++$active_connections_byhost{$ip};
  ++$active_connections_byC{$C};
  ++$active_connections_byB{$B};
  return [ $ip, $C, $B ];
}

##### Shared rate limit management #####

# This is the most unexpectedly complex part of the proxypot. The actual
# proxying is done by child processes, but for the rate limits to be
# effective at least some of them must be global. So whenever a child process
# wants to perform a rate-limited action, it asks the main process for
# permission. The main process keeps track of these requests and when the
# rate limit is exceeded, it calculates the necessary delay before the
# requested action is allowable, and advises the child process to sleep that
# long before continuing. The main process therefore knows that certain
# events will happen at specific times, so in all of this section, read
# "recent" as "recent or future". More recent (or later in the future) events
# are pushed onto the end of the event arrays, so the oldest one is always
# first in the array.
#
my %recent_connects_byhost;
my %recent_connects_byC;
my %recent_connects_byB;
my @recent_sends;
my @recent_recvs;
my @recent_slowsends;
my %recent_rcpts_byhost;
my $lastscrub;BEGIN{$lastscrub=time()};
sub scrub;
sub readfromchild
{
  my $kid=$_[0];
  my $req=$kid->{fd}->readline();
  if(!defined($req) || !length($req)) {
    delete $kid->{fd};
    return;
  }
  my $now=time();
  if($lastscrub<$now-600) {
    scrub($now);
    $lastscrub=$now;
  }
  if($req =~ /^connect (((\d+\.\d+)\.\d+)\.\d+)$/) {
    my ($host, $C, $B)=($1,$2,$3);
    $recent_connects_byhost{$host} ||= [];
    $recent_connects_byC{$C} ||= [];
    $recent_connects_byB{$B} ||= [];
    my $byhost=$recent_connects_byhost{$host};
    my $byC=$recent_connects_byC{$C};
    my $byB=$recent_connects_byB{$B};
    @$byhost=grep { $_->{when} >= $now-600 } @$byhost;
    @$byC=grep { $_->{when} >= $now-600 } @$byC;
    @$byB=grep { $_->{when} >= $now-600 } @$byB;
    my ($sleephost,$sleepC,$sleepB)=(0,0,0);
    my $m=$max_connects_per_destination_host_per_10_minutes;
    if(@$byhost>=$m) {
      $sleephost=600+$byhost->[-$m]{when}-$now;
    }
    $m=$max_connects_per_destination_C_per_10_minutes;
    if(@$byC>=$m) {
      $sleepC=600+$byC->[-$m]{when}-$now;
    }
    $m=$max_connects_per_destination_B_per_10_minutes;
    if(@$byB>=$m) {
      $sleepB=600+$byB->[-$m]{when}-$now;
    }
    my $sleep=$sleephost;
    $sleep=$sleepC if $sleepC>$sleep;
    $sleep=$sleepB if $sleepB>$sleep;
    $sleep=0 if 0>$sleep; # Paranoia
    push(@$byhost, { when=>$now+$sleep, kid=>$kid->{id} });
    push(@$byC, { when=>$now+$sleep, kid=>$kid->{id} });
    push(@$byB, { when=>$now+$sleep, kid=>$kid->{id} });
    $kid->{fd}->print("$sleep\n");
  } elsif($req =~ /^reduceconnect (((\d+\.\d+)\.\d+)\.\d+)$/) {
    my ($host, $C, $B)=($1,$2,$3);
    my $byhost=$recent_connects_byhost{$host};
    my $byC=$recent_connects_byC{$C};
    my $byB=$recent_connects_byB{$B};
    # remove the most recent connect to the given address by this kid
    my $match=undef;
    for my $i (reverse 0..$#$byhost) {
      if($byhost->[$i]{kid} eq $kid->{id}) {
        $match=$i;
        last;
      }
    }
    splice(@$byhost, $match, 1) if defined($match);
    undef $match;
    for my $i (reverse 0..$#$byC) {
      if($byC->[$i]{kid} eq $kid->{id}) {
        $match=$i;
        last;
      }
    }
    splice(@$byC, $match, 1) if defined($match);
    undef $match;
    for my $i (reverse 0..$#$byB) {
      if($byB->[$i]{kid} eq $kid->{id}) {
        $match=$i;
        last;
      }
    }
    splice(@$byB, $match, 1) if defined($match);
  } elsif($req =~ /^(send|recv) (\d+)$/) {
    my ($direction,$size)=($1,$2);
    my $recent;
    if($direction eq 'send') {
      $recent=\@recent_sends;
    } else { # 'recv'
      $recent=\@recent_recvs;
    }
    # 10 seconds is the actual time window used to enforce this limit, since
    # a modem connection can easily take more than a second to send a single
    # 4096-byte chunk
    @$recent=grep { $_->{when} >= $now-10 } @$recent;
    my $sleep=0;
    my $m=$max_kilobytes_per_second;
    if($size >= $m*10000) {
      printlog "$kid->{id}: chunk too big, exceeding rate limit";
    } else {
      my $total=$size;
      my $rec=$#$recent;
      while($total < $m*10000 && $rec>=0) {
        $total+=$recent->[$rec]{size};
        --$rec;
      }
      if($total >= $m*10000) {
        # $rec is now the index of the first record that wasn't used in the
        # total, or -1 if all of them were.
        $sleep=10+$recent->[$rec+1]{when}-$now;
      }
    }
    $sleep=0 if 0>$sleep; # Paranoia
    push(@$recent, { when=>$now+$sleep, size=>$size, kid=>$kid->{id} });
    $kid->{fd}->print("$sleep\n");
  } elsif($req =~ /^reducerecv (\d+)$/) {
    my @recent_recvs_this_kid=grep { $_->{kid} eq $kid->{id} } @recent_recvs;
    if(@recent_recvs_this_kid) {
      $recent_recvs_this_kid[-1]{size}=$1;
    }
  } elsif($req =~ /^rcpt (\d+\.\d+\.\d+\.\d+)$/) {
    # TODO: make this teergrube-style (first fast then slow and slower)
    my $host=$1;
    $recent_rcpts_byhost{$host} ||= [];
    my $byhost=$recent_rcpts_byhost{$host};
    @$byhost =
      grep { $_ >= $now-$seconds_between_rcpts_per_destination_host } @$byhost;
    my $sleep=0;
    my $m=1;
    if(@$byhost>=$m) {
      $sleep=$seconds_between_rcpts_per_destination_host+$byhost->[-$m]-$now;
    }
    $sleep=0 if 0>$sleep; # Paranoia
    push(@$byhost, $now+$sleep);
    $kid->{fd}->print("$sleep\n");
  } elsif($req =~ /^slowsend (\d+)$/) {
    my ($size)=($1);
    my $recent=\@recent_slowsends;
    # 10 seconds is the actual time window used to enforce this limit, since
    # a modem connection can easily take more than a second to send a single
    # 4096-byte chunk
    @recent_slowsends=grep { $_->{when} >= $now-10 } @recent_slowsends;
    my $sleep=0;
    my $m=.5;
    if($size >= $m*10000) {
      printlog "$kid->{id}: chunk too big, exceeding raw rate limit!";
    } else {
      my $total=$size;
      my $rec=$#recent_slowsends;
      while($total < $m*10000 && $rec>=0) {
        $total+=$recent_slowsends[$rec]{size};
        --$rec;
      }
      if($total >= $m*10000) {
        # $rec is now the index of the first record that wasn't used in the
        # total, or -1 if all of them were.
        $sleep=10+$recent_slowsends[$rec+1]{when}-$now;
      }
    }
    $sleep=0 if 0>$sleep; # Paranoia
    push(@recent_slowsends,{ when=>$now+$sleep, size=>$size, kid=>$kid->{id} });
    $kid->{fd}->print("$sleep\n");
  } else {
    printlog "Bad rate limit request from $kid->{id}: ".cleanstr($req);
    delete $kid->{fd};
    return;
  }
}

# Over time, recent_connects_by* and recent_rcpts_byhost build up a lot of
# small arrays. They never get completely cleared out since each one is only
# scrubbed of old entries when a new entry is about to be added. We need to
# periodically do a full sweep and completely delete those arrays which
# contain no new entries, to cut back on memory usage. That's done here:
sub scrub
{
  my $now=$_[0];
  for my $h (\%recent_connects_byhost,
             \%recent_connects_byC,
             \%recent_connects_byB) {
    for my $k (keys %$h) {
      @{$h->{$k}}=grep { $_->{when} > $now-600 } @{$h->{$k}};
      delete $h->{$k} if !@{$h->{$k}};
    }
  }
  for my $k (keys %recent_rcpts_byhost) {
    my $b=$recent_rcpts_byhost{$k};
    @$b=grep { $_ > $now-$seconds_between_rcpts_per_destination_host } @$b;
    delete $recent_rcpts_byhost{$k} if !@$b;
  }
}

##### Child processes #####

sub rlpreread;
sub rlpostread;

my ($id, $clientsock, $clientaddr, $clientproto, $parentsock,
    $serversock, $serverproto, $tmpserversock, @chain);

sub spawnchild
{
  ($id, $clientsock, $clientaddr, $clientproto)=@_;
  $clientsock->set_read_hooks(\&rlpreread, \&rlpostread);
  my $s1=new IO::Handle;
  my $s2=new IO::Handle;
  if(!socketpair($s1, $s2, AF_UNIX, SOCK_STREAM, 0)) {
    return undef;
  }
  $s1->autoflush();
  $s2->autoflush();
  my $pid=fork();
  if(!defined($pid)) {
    return undef;
  }
  if($pid) {
    close($s2);
    return { fd => new RBSF($s1), id => $id, pid => $pid };
  }
  close($s1);
  # TODO: close all unneeded file descriptors (the other children's
  # socketpairs, the listening sockets, others?)
  $parentsock=$s2;
  if($clientproto eq 'http') {
    handle_http_proxyreq();
  } elsif($clientproto eq 'socks') {
    handle_socks_proxyreq();
  } elsif($clientproto eq 'wingate') {
    handle_wingate_proxyreq();
  }
  exit(0);
}

# Sleep whatever length of time the parent suggests
sub rlsleep
{
  my $reading=$_[0];
  my $sleep=<$parentsock>;
  if(!defined($sleep)) {
    printlog "$id: parent seems to have disappeared. Dying now";
    exit(0);
  }
  chomp($sleep);
  return 1 if !$sleep;
  if(!$clientsock || !defined(wantarray())) {
    sleep($sleep);
  } else {
    # If the client hangs up while we're sleeping, return and let the caller
    # know that he doesn't need to do whatever he was going to do. If we're
    # sleeping on a read, we have to tell eofahead() not to actually do a
    # read because that would be violating the limit we are currently
    # enforcing! It will then attempt to read only 1 byte, which will
    # hopefully not throw off the limit too much.
    # TODO: Count those one-byte reads and include them in the next request
    for my $i (0..$sleep/3) {
      return 0 if $clientsock->eofahead(!$reading);
      sleep(3);
    }
    sleep($sleep % 3);
  }
  return 1;
}

# Ask the main process if this connect would exceed a rate limit, and if so
# sleep for the required time.
sub rlconnect
{
  my $dest=$_[0];
  print $parentsock "connect $dest\n";
  if(!rlsleep()) {
    print $parentsock "reduceconnect $dest\n";
    return 0;
  }
  return 1;
}

# Ask the main process if this RCPT would exceed a rate limit, and if so
# sleep for the required time.
sub rlrcpt
{
  my $dest=$_[0];
  print $parentsock "rcpt $dest\n";
  # TODO: could detect hangups and do a reducercpt like reduceconnect
  rlsleep();
}

# print within the global rate limit, log+exit on failure (which will most
# likely be caused by a client which unexpectedly hang up)
sub rlprint
{
  my $fh=shift();
  my $fhname=shift();
  my $l=length join '',@_;
  print $parentsock "send $l\n";
  # TODO: could detect hangups (EPIPE) and do a reducesend like reduceconnect
  rlsleep();
  if(!$fh->print(@_)) {
    printlog("$id: error writing to $fhname ($!), exiting");
    exit(0);
  }
}

# write within an ultra-slow global rate limit, log+exit on failure (which
# will most likely be caused by a client which unexpectedly hang up). This
# tries a single syswrite() only and returns the number of bytes written,
# unlike rlprint which prints the whole thing even if it takes multiple
# writes.
sub rlwrite
{
  my $fh=shift();
  my $fhname=shift();
  my $l=length $_[0];
  print $parentsock "send $l\n";
  rlsleep();
  print $parentsock "slowsend $l\n";
  rlsleep();
  my $ret=$fh->write($_[0]);
  if(!defined($ret)) {
    printlog("$id: error writing to $fhname ($!), exiting");
    exit(0);
  }
  # There will never be a reducesend call here to ease the rate limit because
  # this is used by the raw protocol where we want it to be unreasonably slow
  # anyway.
  return $ret;
}

# print to $clientsock within the global rate limit
sub cliprint
{
  rlprint $clientsock, 'client', @_;
}

# print to $serversock within the global rate limit
sub servprint
{
  rlprint $serversock, 'server', @_;
}

# Callbacks to force RBSF reads to be within the global rate limit. If done
# above the buffering layer, these are either ineffective or way too
# CPU-heavy. There are 2 hooks because the main process needs to know the
# actual size of the read when it is less than requested, or the rate limit
# calculation will be off and everything will go slower than it's supposed to.
# TODO: make the write rate limit work the same way.
sub rlpreread
{
  print $parentsock "recv $_[0]\n";
  if(!rlsleep(1)) {
    print $parentsock "reducerecv 0\n";
    $!=ECONNRESET; # Not perfect error reporting, but close enough.
    return 0;
  }
  return 1;
}
sub rlpostread
{
  print $parentsock "reducerecv $_[1]\n" if $_[1]!=$_[0];
}

# like read() but with a 5-minute timeout. In line mode, reads one line but
# returns undef if the line is too long, unlike readline (the <FH> operator)
# which will keep reading until it runs out of memory (and since perl doesn't
# let you handle memory errors, the whole process dies).
#
# Special case: if the requested number of bytes is negative, then a single
# sysread() will be done instead of a read(), which means that this function
# will return immediately as soon as anything is received rather than waiting
# for the full amount or EOF. This alternate mode is of course incompatible
# with line mode.
#
# TODO: This function should probably be broken up now that the rate-limit
# stuff is handled at a lower level. The various modes don't have much in
# common anymore.
sub timeoutread
{
  my ($fh, $nbytes, $linemode, $partialok)=@_;
  my $buf='';
  my $oneshot=0;
  if($nbytes<0) {
    $oneshot=1;
    $nbytes=-$nbytes;
  }
  $SIG{ALRM}=
    sub {
          printlog "$id: timeout (idle or teergrubing). Closing.";
          exit(0);
        };
  # TODO: use the pre-read hook to do this alarm() only when we're about to
  # do a blocking low-level read. Or do an RBSF::select here instead?
  alarm(300);
  if(!$linemode) {
    my $read=$oneshot ?
             $fh->read($buf, $nbytes) :
             $fh->fullread($buf, $nbytes);
    my $saveerr=$!;
    alarm(0);
    $!=$saveerr;
    if(!defined($read)) {
      return undef;
    } else {
      return $buf;
    }
  } else {
    while(length($buf)<$nbytes) {
      my $byte=$fh->getc();
      if(!defined($byte)) {
        my $saveerr=$!;
        alarm(0);
        $!=$saveerr;
        return undef;
      } else {
        $buf.=$byte;
        if(!length($byte) || substr($buf, length($buf)-1, 1) eq "\n") {
          alarm(0);
          return $buf;
        }
      }
    }
    alarm(0);
    if($partialok) {
      return $buf;
    }
    $!=0; # Let's just pretend this means "Line too long"
    return undef;
  }
}

# Rate-limited, line-length-limited, read on $clientsock
my $clientsockerr;
sub cliread
{
  my ($nbytes, $linemode, $partialok)=@_;
  # We have to make sure the "Line too long" error is persistent. Might as
  # well do other read errors too.
  if(defined $clientsockerr) {
    $!=$clientsockerr;
    return undef;
  }
  my $ret=timeoutread($clientsock, $nbytes, $linemode, $partialok);
  if(!defined($ret)) {
    $clientsockerr=$!;
  }
  return $ret;
}

# Rate-limited, line-length-limited, read on $serversock
my $serversockerr;
sub servread
{
  my ($nbytes, $linemode, $partialok)=@_;
  # We have to make sure the "Line too long" error is persistent. Might as
  # well do other read errors too.
  if(defined $serversockerr) {
    $!=$serversockerr;
    return undef;
  }
  my $ret=timeoutread($serversock, $nbytes, $linemode, $partialok);
  if(!defined($ret)) {
    $serversockerr=$!;
  }
  return $ret;
}

sub iscidr
{
  my $cidr=$_[0];
  my ($base, $bits, $junk)=split /\//, $cidr;
  return wantarray?():undef if defined($junk);
  $bits=32 if !defined($bits);
  return wantarray?():undef if $bits =~ /\D/ || $bits>32;
  my (@octets)=split /\./, $base;
  return wantarray?():undef if @octets!=4;
  my $long=0;
  for my $i (0..3) {
    return wantarray?():undef if $octets[$i] =~ /\D/ || $octets[$i]>255;
    $long+=$octets[$i];
    $long*=256 if $i<3;
  }
  # since perl integers might be 64 or 32 bits, and the perl shift operator
  # thinks 32==0, some funny arithmetic...
  my $mask = ($bits==0) ? 0 : ((0xffffffff<<(32-$bits)) & 0xffffffff);
  return wantarray?($long, $mask):1;
}

sub iscidr_withspecials
{
  my $cidr=$_[0];
  $cidr =~ s@^self/@0.0.0.0/@;
  $cidr =~ s@^client/@0.0.0.0/@;
  return iscidr($cidr);
}

sub iscidrlist_withspecials
{
  my $cidr=$_[0];
  if($cidr =~ m@^self/@) {
    my @selfmatches=();
    if(!@selfaddrs) {
      # TODO: We are listening on all addresses, this should really be a
      # match against all addresses. Where is perl's SIOCGIFCONF?
      my $name=$clientsock->sockname();
      my ($port, $ip) = unpack_sockaddr_in($name);
      @selfmatches=(unpack("N", $ip));
    } else {
      @selfmatches=map { unpack("N", inet_aton($_)) } @selfaddrs;
    }
    my ($junk, $mask) = iscidr_withspecials($cidr);
    return map { [ $_, $mask ] } @selfmatches;
  }
  if($cidr =~ m@^client/@) {
    my $clientmatch=unpack("N", inet_aton($clientaddr));
    my ($junk, $mask) = iscidr_withspecials($cidr);
    return [ $clientmatch, $mask ];
  }
  return [ iscidr($cidr) ];
}

use constant PROXY_REJECTED => 0;
use constant PROXY_FAILED => 1;
use constant PROXY_CONNECTED => 2;
sub proxy_request
{
  my ($desthost, $destport)=@_;
  my $destip=gethostbyname($desthost);
  if(!defined($destip)) {
    printlog "$id: requested host ".cleanstr($desthost)." not found";
    return (PROXY_FAILED, "Host not found");
  }
  my $destiplong=unpack("N", $destip);
  my $clientiplong=unpack("N", inet_aton($clientaddr));
  my $action='deny';
  for my $allow_deny_spec (@allow_deny) {
    my ($client_check_base, $client_check_mask) =
      iscidr($allow_deny_spec->{clientaddr});
    next if ($clientiplong & $client_check_mask) !=
            ($client_check_base & $client_check_mask);

    my @destchecklist=iscidrlist_withspecials($allow_deny_spec->{destaddr});
    my $destmatched=0;
    for my $d (@destchecklist) {
      my ($dest_check_base, $dest_check_mask)=@$d;
      if(($destiplong & $dest_check_mask) ==
         ($dest_check_base & $dest_check_mask)) {
        $destmatched=1;
        last;
      }
    }
    next if !$destmatched;

    next if $destport < $allow_deny_spec->{destportmin};
    next if $destport > $allow_deny_spec->{destportmax};

    $action=$allow_deny_spec->{outproto};
    last;
  }
  if($action eq 'deny') {
    printlog "$id: denying request for connection to ".
             inet_ntoa(pack("N", $destiplong)).":$destport";
    return PROXY_REJECTED;
  }
  printlog "$id: allowing request for connection to ".
           inet_ntoa(pack("N", $destiplong)).":$destport";
  $serverproto=$action;

  # If the action is some sort of proxy protocol, then the chain isn't
  # finished yet. We may be able to determine now that the final length will
  # be too big.
  if($action eq 'httpc1' ||
     $action eq 'httpc2' ||
     $action eq 'httpc3' ||
     $action eq 'socks1' ||
     $action eq 'socks2' ||
     $action eq 'socks3') {
    if(1+@chain > $max_fake_proxy_chain_length) {
      printlog "$id: chain too long";
      return PROXY_REJECTED;
    }
    if(grep
       { $_->{destiplong} == $destiplong && $_->{destport} == $destport }
       @chain) {
      printlog "$id: loop detected";
      return PROXY_REJECTED;
    }
  }
  if($action eq 'httpc2' ||
     $action eq 'httpc3' ||
     $action eq 'socks2' ||
     $action eq 'socks3') {
    if(1+(grep { $_->{type} eq 'real' } @chain) > $max_real_proxy_chain_length) {
      printlog "$id: chain too long";
      return PROXY_REJECTED;
    }
  }

  # If the action requires a real connect(), do it now
  if($action eq 'banner' ||
     $action eq 'raw' ||
     $action eq 'http2' ||
     $action eq 'httpc2' ||
     $action eq 'httpc3' ||
     $action eq 'smtp2' ||
     $action eq 'smtp3' ||
     $action eq 'socks2' ||
     $action eq 'socks3') {
    if($action eq 'raw' && inet_ntoa(pack("N", $destiplong)) ne $clientaddr) {
      # Seriously!
      printlog "$id: rejected";
      return PROXY_REJECTED;
    }
    if(!rlconnect(inet_ntoa(pack("N", $destiplong)))) {
      printlog "$id: Client hung up during connect rate-limit sleep";
      return (PROXY_FAILED, "Client hangup");
    }
    if($action eq 'httpc2' || $action eq 'socks2') {
      # Don't use $serversock for these. We're just going to hang up and it
      # would break the proxy chain.
      my $name=$clientsock->sockname();
      my ($lport, $lip) = unpack_sockaddr_in($name);
      $tmpserversock =
        new IO::Socket::INET(LocalAddr => inet_ntoa($lip),
                             PeerAddr => inet_ntoa(pack("N", $destiplong)),
                             PeerPort => $destport);
      if(!$tmpserversock) {
        my $e="$!";
        printlog "$id: socket/connect: $e";
        return (PROXY_FAILED, $e);
      }
      $tmpserversock->autoflush();
      printlog "$id: connection succeeded";
      push(@chain,
        {
          type => 'fake',
          proxyproto => $action,
          desthost => $desthost,
          destport => $destport,
          destiplong => $destiplong,
          destip => inet_ntoa(pack("N", $destiplong)),
        });
      return PROXY_CONNECTED;
    }
    if($serversock) {
      # We currently have a real proxy in the chain, so ask it to connect
      # instead of doing it directly from the proxypot. This isn't just a
      # byte-for-byte pass-through of the incoming request, because that
      # wouldn't be very safe, and besides that we may be dealing with a fake
      # HTTP proxy after a real SOCKS proxy, in which case we have to parse
      # the incoming SOCKS request and write it out as an HTTP "CONNECT"
      # string.
      my ($p,$err)=passthrough_proxy_request($destiplong, $destport);
      if($p!=PROXY_CONNECTED) {
        return ($p,$err);
      }
    } else {
      my $name=$clientsock->sockname();
      my ($lport, $lip) = unpack_sockaddr_in($name);
      $serversock =
        new IO::Socket::INET(LocalAddr => inet_ntoa($lip),
                             PeerAddr => inet_ntoa(pack("N", $destiplong)),
                             PeerPort => $destport);
      if(!$serversock) {
        my $e="$!";
        printlog "$id: socket/connect: $e";
        return (PROXY_FAILED, $e);
      }
      $serversock->autoflush();
      $serversock=new RBSF($serversock);
      $serversock->set_read_hooks(\&rlpreread, \&rlpostread);
    }
    printlog "$id: connection succeeded";
    push(@chain,
      {
        type => 'real',
        proxyproto => $action,
        desthost => $desthost,
        destport => $destport,
        destiplong => $destiplong,
        destip => inet_ntoa(pack("N", $destiplong)),
      });
    return PROXY_CONNECTED;
  } else {
    push(@chain,
      {
        type => 'fake',
        proxyproto => $action,
        desthost => $desthost,
        destport => $destport,
        destiplong => $destiplong,
        destip => inet_ntoa(pack("N", $destiplong)),
      });
    return PROXY_CONNECTED;
  }
}

sub log_lines_until_blank
{
  my ($readfunc, $maxlinelength, $maxtotallength, $label)=@_;
  my $s='';
  my $line;
  while(defined($line=$readfunc->($maxlinelength, 1)) && length($line)) {
    last if $line =~ /^\r?\n\z/;
    $s.=$line;
    if(length($s)>=$maxtotallength) {
      return undef;
    }
  }
  if(!defined($line) || !length($line)) {
    return undef;
  }
  printlog "$id: $label: ".cleanstr($s) if length($s);
  return $s;
}

# This function is called only after we have already started a proxy chain.
# It asks the current end node on the chain to make the next connection.
sub passthrough_proxy_request
{
  my ($destiplong, $destport)=@_;
  my $destipquad=inet_ntoa(pack("N", $destiplong));
  # Locate the last real proxy on the chain, so we know how to format the
  # request
  my $activeproxy=(reverse grep { $_->{type} eq 'real' } @chain)[0];
  if(!$activeproxy) {
    printlog "$id: passthrough_proxy_request entered with no active proxy";
    exit(0);
  }
  my $activeproto=$activeproxy->{proxyproto};
  if(!rlconnect(inet_ntoa(pack("N", $destiplong)))) {
    printlog "$id: Client hung up during connect rate-limit sleep";
    return (PROXY_FAILED, "Client hangup");
  }
  if($activeproto eq 'httpc3') {
    printlog "$id: sending request: CONNECT $destipquad:$destport HTTP/1.0";
    servprint "CONNECT $destipquad:$destport HTTP/1.0\r\n\r\n";
    my $reply=servread(500, 1);
    if(!defined($reply) || $reply !~ /^HTTP\/1\.[01] \d\d\d/) {
      printlog "$id: error reading reply from HTTP proxy: $!";
      $serversock->close();
      undef $serversock;
      return (PROXY_FAILED, "Read error");
    }
    printlog "$id: got reply: ".cleanstr($reply);
    $reply=substr($reply, 9, 3);
    if(!defined(log_lines_until_blank(\&servread, 500, 10000,
                                      'proxy reply headers'))) {
      printlog "$id: error reading reply headers from HTTP proxy: $!";
      $serversock->close();
      undef $serversock;
      return (PROXY_FAILED, "Read error");
    }
    if($reply==200) {
      return PROXY_CONNECTED;
    }
    # TODO: read the body of the reply and return it back to the client, or
    # if the client is expecting a SOCKS response, convert it to one of the
    # reply strings that handle_socks_proxyreq() recognizes.
    if($reply==403 || $reply==405 || $reply==407) {
      $serversock->close();
      undef $serversock;
      return PROXY_REJECTED;
    } else {
      $serversock->close();
      undef $serversock;
      return (PROXY_FAILED, "Connection failed");
    }
  } elsif($activeproto eq 'socks3') {
    printlog "$id: starting SOCKS5 handshake";
    servprint "\5\1\0";
    my $ver_meth=servread(2);
    if(!defined($ver_meth) || length($ver_meth)!=2) {
      printlog "$id: error reading SOCKS version/auth method: $!";
      $serversock->close();
      undef $serversock;
      return (PROXY_FAILED, "Read error");
    }
    if($ver_meth eq "\5\xff") {
      printlog "$id: SOCKS server demands authentication";
      $serversock->close();
      undef $serversock;
      return PROXY_REJECTED;
    }
    if($ver_meth ne "\5\0") {
      printlog "$id: invalid authentication reply ".cleanstr($ver_meth).
               " from SOCKS server";
      $serversock->close();
      undef $serversock;
      return (PROXY_FAILED, "Protocol error");
    }
    printlog "$id: sending SOCKS5 request: CMD=1 (connect) ATYP=1 (ipv4) ".
             "DST.ADDR=$destipquad DST.PORT=$destport";
    servprint "\5\1\0\1".pack("N",$destiplong).pack("n",$destport);
    my $ver_rep_rsv_atyp=servread(4);
    if(!defined($ver_rep_rsv_atyp) || length($ver_rep_rsv_atyp)!=4) {
      printlog "$id: error reading SOCKS connect reply: $!";
      $serversock->close();
      undef $serversock;
      return (PROXY_FAILED, "Read error");
    }
    if($ver_rep_rsv_atyp !~ /\005(.)\000([\001\003])/) {
      printlog "$id: invalid connect reply ".cleanstr($ver_rep_rsv_atyp).
               " from SOCKS server";
      $serversock->close();
      undef $serversock;
      return (PROXY_FAILED, "Protocol error");
    }
    my ($rep, $atyp)=map {ord} $1,$2;
    if($rep!=0) {
      my $e;
      $serversock->close();
      undef $serversock;
      if($rep==1) {
        $e="General failure";
      } elsif($rep==2) {
        printlog "$id: connection request rejected by SOCKS server";
        return PROXY_REJECTED;
      } elsif($rep==3) {
        $e="Network is unreachable";
      } elsif($rep==4) {
        $e="No route to host";
      } elsif($rep==5) {
        $e="Connection refused";
      } elsif($rep==6) {
        $e="TTL expired";
      } elsif($rep==7) {
        printlog "$id: SOCKS server claims not to support the connect command";
        return PROXY_REJECTED;
      } elsif($rep==8) {
        printlog "$id: SOCKS server claims not to support IPv4 addresses";
        return PROXY_REJECTED;
      } else {
        $e="Protocol error";
      }
      return (PROXY_FAILED, $e);
    }
    # Read and discard the "bind" address - we won't be using it
    if($atyp==1) { # raw IP address
      my $junk=servread(4);
      if(!defined($junk) || length($junk)!=4) {
        printlog "$id: error reading bound address from HTTP proxy: $!";
        $serversock->close();
        undef $serversock;
        return (PROXY_FAILED, "Read error");
      }
    } else { # hostname
      my $hlen=servread(1);
      if(!defined($hlen) || length($hlen)!=1) {
        printlog "$id: error reading bound address from HTTP proxy: $!";
        $serversock->close();
        undef $serversock;
        return (PROXY_FAILED, "Read error");
      }
      $hlen=ord($hlen);
      my $junk=servread($hlen);
      if(!defined($junk) || length($junk)!=$hlen) {
        printlog "$id: error reading bound address from HTTP proxy: $!";
        $serversock->close();
        undef $serversock;
        return (PROXY_FAILED, "Read error");
      }
    }
    return PROXY_CONNECTED;
  } else {
    printlog
      "$id: passthrough_proxy_request entered with bad proxy type $activeproto";
    exit(0);
  }
}

my $generic_empty_200_reply;BEGIN{$generic_empty_200_reply=
"HTTP/1.0 200 OK\r\n".
"Content-Length: 7\r\n".
"Content-Type: text/html; charset=iso-8859-1\r\n".
"Proxy-Connection: close\r\n".
"\r\n".
"&nbsp;\n";
}

my $generic_invalid_400_reply;BEGIN{$generic_invalid_400_reply=
"HTTP/1.0 400 Bad Request\r\n".
"Content-Type: text/html\r\n".
"Content-Length: 24\r\n".
"\r\nThe request is invalid.\n";
}

# This one covers the initial state of the port 3128/8080 listener as well as
# the fake HTTP proxies later in a chain (handle_httpc[12])
sub handle_http_proxyreq
{
  my $request=cliread(500, 1);
  if(!defined($request)) {
    printlog "$id: error reading HTTP command from client: $!";
    exit(0);
  }
  if(!length($request)) {
    printlog "$id: EOF from client";
    exit(0);
  }
  printlog "$id: received HTTP command from client: ".
           cleanstr($request);
  # TODO: send properly formatted replies to pre-HTTP/1.0 requests
  if($request =~ /^CONNECT ([-.a-zA-Z0-9]+):(\d+)(?: ?\/)? HTTP\/1\.[01]\r?\n/) {
    my $i=0;
    if(!defined(log_lines_until_blank(\&cliread, 500, 10000,
                                      'request headers'))) {
      printlog "$id: HTTP request incomplete";
      exit(0);
    }
    my ($host, $port)=($1,$2);
    my ($p,$err)=proxy_request($host, $port);
    if($p==PROXY_CONNECTED) {
      cliprint "HTTP/1.0 200 Connection established\r\n\r\n";
      handle_serverproto();
    } elsif($p==PROXY_FAILED) {
      $err =~ s/\&/\&amp;/g;
      $err =~ s/</\&lt;/g;
      $err =~ s/>/\&gt;/g;
      cliprint "HTTP/1.0 503 Service Unavailable\r\n".
               "Content-Type: text/html\r\n".
               "Content-Length: ", length($err)+1,
               "\r\n\r\n$err\n";
      exit(0);
    } else { # PROXY_REJECTED
      cliprint "HTTP/1.0 403 Forbidden\r\n".
               "Content-Type: text/html\r\n".
               "Content-Length: 32\r\n".
               "\r\nThe destination is not allowed.\n";
      exit(0);
    }
  } elsif($direct_http_commands && $request =~
          /^GET http:\/\/([-.a-zA-Z0-9]+)(?::80)?(\/\~?[-.A-Za-z0-9_\/]*)((?: HTTP\/1\.[01])?)\r?\n/) {
    my ($gethost, $getpath, $getver)=($1,$2,$3);
    if($direct_http_commands==1 ||
       length($getpath)>80 ||
       $getpath =~ /cgi-bin/i ||
       $getpath =~ /\.cgi/i ||
       $getpath =~ /\.pl/i) {
      printlog "$id: faking empty reply";
      if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                       'request headers'))) {
        cliprint $generic_empty_200_reply;
      }
      exit(0);
    } else { # $direct_http_commands==2
      printlog "$id: retrieving URL";
      # TODO: analyze the incoming headers and pass them through if they are
      # safe.
      if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                       'request headers'))) {
        my $name=$clientsock->sockname();
        my ($lport, $lip) = unpack_sockaddr_in($name);
        my $getip=gethostbyname($gethost);
        if(!defined($getip)) {
          my $err="Host not found: $gethost";
          printlog "$id: requested host ".cleanstr($gethost)." not found";
          cliprint "HTTP/1.0 503 Service Unavailable\r\n".
                   "Content-Type: text/html\r\n".
                   "Content-Length: ", length($err)+1,
                   "\r\n\r\n$err\n";
          exit(0);
        }
        if(!rlconnect(inet_ntoa($getip))) {
          printlog "$id: Client hung up during connect rate-limit sleep";
          exit(0);
        }
        my $s=new IO::Socket::INET(LocalAddr => inet_ntoa($lip),
                                   PeerAddr => $gethost, PeerPort => 80);
        if(!$s) {
          my $err="Connection to remote host failed: $!";
          printlog "$id: socket/connect: $!";
          cliprint "HTTP/1.0 503 Service Unavailable\r\n".
                   "Content-Type: text/html\r\n".
                   "Content-Length: ", length($err)+1,
                   "\r\n\r\n$err\n";
          exit(0);
        }
        $s->autoflush();
        $s=new RBSF($s);
        $s->set_read_hooks(\&rlpreread, \&rlpostread);
        rlprint $s, 'server', "GET $getpath HTTP/1.0\r\n".
                              "Host: $gethost\r\n\r\n";
        my $buf;
        my $i=65536;
        while($i>0 && defined($buf=timeoutread($s, 1024, 0)) && length($buf)) {
          printlog "$id: HTTP response data: ".cleanstr($buf);
          cliprint $buf;
          $i-=length($buf);
        }
      }
      exit(0);
    }
  } elsif($direct_http_commands && $request =~ /^GET /) {
    printlog "$id: faking empty reply";
    if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                     'request headers'))) {
      cliprint $generic_empty_200_reply;
    }
    exit(0);
  } elsif($direct_http_commands && $request =~ /^(POST|HEAD) .*?((?: HTTP\/1\.[01])?)\r?\n/) {
    # TODO: pass through safe HEADs like GETs
    my ($method, $ver)=($1,$2);
    printlog "$id: faking empty reply";
    if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                     'request headers'))) {
      cliprint $generic_empty_200_reply;
    }
    exit(0);
  } else {
    printlog "$id: rejecting unknown HTTP command";
    cliprint $generic_invalid_400_reply;
    exit(0);
  }
}

# This one covers the initial state of the port 1080 listener, not the
# pass-through of a socks request along a chain (actually not true anymore,
# it handles both)
sub handle_socks_proxyreq
{
  my $ver=cliread(1);
  if(!defined($ver) || length($ver)!=1) {
    printlog "$id: error reading socks request from client: $!";
    exit(0);
  }
  if(ord($ver)==5) {
    printlog "$id: receiving socks version 5 request";
    my $nmethods=cliread(1);
    if(!defined($nmethods) || length($nmethods)!=1) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    $nmethods=ord($nmethods);
    my $methods=cliread($nmethods);
    if(!defined($methods) || length($methods)!=$nmethods) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    if($methods =~ /\0/) {
      cliprint "\5\0";
    } elsif($methods =~ /\002/) {
      cliprint "\5\2";
      $ver=cliread(1);
      if(!defined($ver) || length($ver)!=1) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      if(ord($ver)!=1) {
        printlog "$id: client tried to use unsupported socks userpass ".
                 "authentication version ".ord($ver);
        exit(0);
      }
      my $ulen=cliread(1);
      if(!defined($ulen) || length($ulen)!=1) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      $ulen=ord($ulen);
      my $username=cliread($ulen);
      if(!defined($username) || length($username)!=$ulen) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      my $plen=cliread(1);
      if(!defined($plen) || length($plen)!=1) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      $plen=ord($plen);
      my $password=cliread($plen);
      if(!defined($password) || length($password)!=$plen) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      printlog "$id: accepting username ".cleanstr($username).
               " with password ".cleanstr($password);
      cliprint "\1\0";
    } else {
      printlog "$id: no suitable socks authentication method available";
      cliprint "\5\xff";
      exit(0);
    }
    # auth done. now read connection request
    $ver=cliread(1);
    if(!defined($ver) || length($ver)!=1) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    if(ord($ver)!=5) {
      printlog "$id: client switched from socks5 to unsupported version ".
               ord($ver);
      cliprint "\5\1\0\1\0\0\0\0\0\0";
      exit(0);
    }
    my $cmd=cliread(1);
    if(!defined($cmd) || length($cmd)!=1) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    if(ord($cmd)!=1) {
      printlog "$id: client tried to use unsupported socks command ".
               ord($cmd);
      cliprint "\5\7\0\1\0\0\0\0\0\0";
      exit(0);
    }
    my $rsv=cliread(1);
    if(!defined($rsv) || length($rsv)!=1) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    my $atyp=cliread(1);
    if(!defined($atyp) || length($atyp)!=1) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    $atyp=ord($atyp);
    my $host;
    if($atyp==1) {
      my $hostraw=cliread(4);
      if(!defined($hostraw) || length($hostraw)!=4) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      $host=inet_ntoa($hostraw);
      $host =~ /^(\d+\.\d+\.\d+\.\d+)$/ and $host=$1; # untaint
    } elsif($atyp==3) {
      my $hostlen=cliread(1);
      if(!defined($hostlen) || length($hostlen)!=1) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      $hostlen=ord($hostlen);
      $host=cliread($hostlen);
      $host =~ /^([-.A-Za-z0-9_]*)$/ and $host=$1; # untaint
      if(!defined($host) || length($host)!=$hostlen) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
    } else {
      printlog "$id: client tried to use unsupported socks address type ".
               ord($atyp);
      cliprint "\5\10\0\1\0\0\0\0\0\0";
      exit(0);
    }
    my $portraw=cliread(2);
    if(!defined($portraw) || length($portraw)!=2) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    my $port=unpack("n", $portraw);
    my ($p,$err)=proxy_request($host, $port);
    if($p==PROXY_CONNECTED) {
      $chain[-1]->{socksversion}=5;
      if($serversock) {
        # TODO: fix this so it uses the address of the last proxy on the chain
        my $name=$serversock->sockname();
        my ($lport, $lip) = unpack_sockaddr_in($name);
        $lport=pack("n", $lport);
        cliprint "\5\0\0\1$lip$lport";
      } else {
        # Make up a fake local bound address
        my $name=$clientsock->sockname();
        my ($lport, $lip) = unpack_sockaddr_in($name);
        $lport=pack("n", int(rand(15000)+4000));
        cliprint "\5\0\0\1$lip$lport";
      }
      handle_serverproto();
    } elsif($p==PROXY_FAILED) {
      # TODO: get proxy_request to remember and return the connect() errno
      if($err =~ /Network is unreachable/) {
        cliprint "\5\3\0\1\0\0\0\0\0\0";
      } elsif($err =~ /No route to host/) {
        cliprint "\5\4\0\1\0\0\0\0\0\0";
      } elsif($err =~ /Connection refused/) {
        cliprint "\5\5\0\1\0\0\0\0\0\0";
      } else {
        cliprint "\5\1\0\1\0\0\0\0\0\0";
      }
      exit(0);
    } else { # PROXY_REJECTED
      cliprint "\5\2\0\1\0\0\0\0\0\0";
      exit(0);
    }
  } elsif(ord($ver)==4) {
    printlog "$id: receiving socks version 4 request";
    my $cd=cliread(1);
    if(!defined($cd) || length($cd)!=1) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    if(ord($cd)!=1) {
      printlog "$id: client tried to use unsupported socks command ".
               ord($cd);
      cliprint "\0\x5b\0\0\0\0\0\0";
      exit(0);
    }
    my $portraw=cliread(2);
    if(!defined($portraw) || length($portraw)!=2) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    my $port=unpack("n", $portraw);
    my $hostraw=cliread(4);
    if(!defined($hostraw) || length($hostraw)!=4) {
      printlog "$id: error reading socks request from client: $!";
      exit(0);
    }
    my $host=inet_ntoa($hostraw);
    $host =~ /^(\d+\.\d+\.\d+\.\d+)$/ and $host=$1; # untaint
    while(1) {
      my $c=cliread(1);
      if(!defined($c) || length($c)!=1) {
        printlog "$id: error reading socks request from client: $!";
        exit(0);
      }
      last if $c eq "\0";
    }
    # TODO: socks 4A - if $host is 0\.0\.0\.\d+, read a NUL-terminated hostname
    my ($p,$err)=proxy_request($host, $port);
    if($p==PROXY_CONNECTED) {
      $chain[-1]->{socksversion}=4;
      cliprint "\0\x5a\0\0\0\0\0\0";
      handle_serverproto();
    } else {
      cliprint "\0\x5b\0\0\0\0\0\0";
      exit(0);
    }
  } else {
    printlog "$id: client tried to use unsupported socks version ".
             ord($ver);
    exit(0);
  }
}

sub handle_wingate_proxyreq
{
  # TODO: I don't actually know where to get specs on this protocol
  printlog "$id: Did someone say McProxy?";
  exit(0);
}

sub handle_banner
{
  printlog "$id: starting banner-only session";
  my $now=time();
  my $endtime=$now+60;
  my $count=0;
  do {
    my @rfds=($clientsock, $serversock);
    # Don't need to select() for writability - we won't be writing enough to
    # fill the local SendQ
    my $nfound=RBSF::select(\@rfds, [], [], [], $endtime-$now);
    if(!defined($nfound) || $nfound==-1) {
      printlog "$id: exiting on select error: $!";
      exit(0);
    }
    if(grep { $_==$clientsock } @rfds) {
      my $clidata=cliread(-1024);
      if(!defined($clidata)) {
        printlog "$id: exiting on read error from client: $!";
        exit(0);
      }
      if(!length($clidata)) {
        # TODO: could try to keep writing in case the client only did a
        # shutdown() for writing instead of a close() - but how likely is
        # that?
        printlog "$id: exiting on EOF from client";
        exit(0);
      }
      printlog "$id: eating data from client: ".cleanstr($clidata);
    }
    if(grep { $_==$serversock } @rfds) {
      my $servdata=servread(-1024);
      if(!defined($servdata)) {
        printlog "$id: exiting on read error from server: $!";
        exit(0);
      }
      if(!length($servdata)) {
        printlog "$id: exiting on EOF from server";
        exit(0);
      }
      printlog "$id: banner data: ".cleanstr($servdata);
      cliprint $servdata;
      $count+=length($servdata);
    }
    $now=time();
  } while($now < $endtime && $count<160);
  printlog "$id: end banner";
}

sub handle_http1
{
  printlog "$id: starting fake HTTP session";
  my $request=cliread(500, 1);
  if(!defined($request)) {
    printlog "$id: error reading HTTP command from client: $!";
    exit(0);
  }
  if(!length($request)) {
    printlog "$id: EOF from client";
    exit(0);
  }
  printlog "$id: received HTTP command from client: ".
           cleanstr($request);
  if($request =~
     /^(?:GET|POST|HEAD) (\/\~?[-.A-Za-z0-9_\/]*)((?: HTTP\/1\.[01])?)\r?\n/) {
    my ($getpath, $getver)=($1,$2);
    printlog "$id: faking empty reply";
    if(!length($getver)) {
      cliprint "&nbsp;\n";
    } elsif(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                     'request headers'))) {
      cliprint $generic_empty_200_reply;
    }
  } else {
    printlog "$id: rejecting unknown HTTP command";
    cliprint $generic_invalid_400_reply;
  }
}

sub handle_http2
{
  printlog "$id: starting HTTP session";
  my $request=cliread(500, 1);
  if(!defined($request)) {
    printlog "$id: error reading HTTP command from client: $!";
    exit(0);
  }
  if(!length($request)) {
    printlog "$id: EOF from client";
    exit(0);
  }
  printlog "$id: received HTTP command from client: ".
           cleanstr($request);
  if($request =~ /^GET (\/\~?[-.A-Za-z0-9_\/]*)((?: HTTP\/1\.[01])?)\r?\n/) {
    my ($getpath, $getver)=($1,$2);
    if(length($getpath)>80 ||
       $getpath =~ /cgi-bin/i ||
       $getpath =~ /\.cgi/i ||
       $getpath =~ /\.pl/i) {
      printlog "$id: faking empty reply";
      if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                       'request headers'))) {
        cliprint $generic_empty_200_reply;
      }
      exit(0);
    } else {
      printlog "$id: retrieving URL";
      # TODO: analyze the incoming headers and pass them through if they are
      # safe. At least Host: should be considered safe, as long as it doesn't
      # contain any funny chars.
      if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                       'request headers'))) {
        servprint "GET $getpath HTTP/1.0\r\n\r\n";
        my $buf;
        my $i=65536;
        while($i>0 && defined($buf=servread(1024)) && length($buf)) {
          printlog "$id: HTTP response data: ".cleanstr($buf);
          cliprint $buf;
          $i-=length($buf);
        }
      }
    }
  } elsif($request =~ /^(GET|POST|HEAD) .*?((?: HTTP\/1\.[01])?)\r?\n/) {
    # TODO: pass through safe HEADs like GETs
    my ($method, $ver)=($1,$2);
    printlog "$id: faking empty reply";
    if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                     'request headers'))) {
      cliprint $generic_empty_200_reply;
    }
    exit(0);
  } else {
    printlog "$id: rejecting unknown HTTP command";
    cliprint $generic_invalid_400_reply;
    exit(0);
  }
}

sub handle_httpc1
{
  printlog "$id: starting fake HTTP proxy session";
  handle_http_proxyreq();
}

sub handle_httpc2
{
  # A server connection exists - we know that the target HTTP proxy exists.
  # Now close it and fake the rest.
  printlog "$id: starting mostly-fake HTTP proxy session";
  close($tmpserversock);
  handle_http_proxyreq();
}

# This one is similar to handle_http_proxyreq, but different enough that it
# can't just be a wrapper
sub handle_httpc3
{
  printlog "$id: starting HTTP proxy session";

  my $request=cliread(500, 1);
  if(!defined($request)) {
    printlog "$id: error reading HTTP command from client: $!";
    exit(0);
  }
  if(!length($request)) {
    printlog "$id: EOF from client";
    exit(0);
  }
  printlog "$id: received HTTP command from client: ".
           cleanstr($request);
  # TODO: send properly formatted replies to pre-HTTP/1.0 requests
  if($request =~ /^CONNECT ([-.a-zA-Z0-9]+):(\d+)(?: ?\/)? HTTP\/1\.[01]\r?\n/) {
    if(!defined(log_lines_until_blank(\&cliread, 500, 10000,
                                      'request headers'))) {
      cliprint "HTTP/1.0 413 Request too long\r\n".
               "Content-Type: text/html\r\n".
               "Content-Length: 17\r\n".
               "\r\nRequest too long\n";
      exit(0);
    }
    my ($host, $port)=($1,$2);
    my ($p,$err)=proxy_request($host, $port);
    if($p==PROXY_CONNECTED) {
      cliprint "HTTP/1.0 200 Connection established\r\n\r\n";
      handle_serverproto();
    } elsif($p==PROXY_FAILED) {
      $err =~ s/\&/\&amp;/g;
      $err =~ s/</\&lt;/g;
      $err =~ s/>/\&gt;/g;
      cliprint "HTTP/1.0 503 Service Unavailable\r\n".
               "Content-Type: text/html\r\n".
               "Content-Length: ", length($err)+1,
               "\r\n\r\n$err\n";
      exit(0);
    } else { # PROXY_REJECTED
      cliprint "HTTP/1.0 403 Forbidden\r\n".
               "Content-Type: text/html\r\n".
               "Content-Length: 32\r\n".
               "\r\nThe destination is not allowed.\n";
      exit(0);
    }
  } elsif($direct_http_commands && $request =~
          /^GET (http:\/\/[-.a-zA-Z0-9]+)(?::80)?(\/\~?[-.A-Za-z0-9_\/]*)((?: HTTP\/1\.[01])?)\r?\n/) {
    my ($gethost, $getpath, $getver)=($1,$2,$3);
    if($direct_http_commands==1 ||
       length($getpath)>80 ||
       $getpath =~ /cgi-bin/i ||
       $getpath =~ /\.cgi/i ||
       $getpath =~ /\.pl/i) {
      printlog "$id: faking empty reply";
      if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                       'request headers'))) {
        cliprint $generic_empty_200_reply;
      }
      exit(0);
    } else { # $direct_http_commands==2
      printlog "$id: retrieving URL";
      # TODO: analyze the incoming headers and pass them through if they are
      # safe.
      if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                       'request headers'))) {
        my $getip=gethostbyname($gethost);
        if(!defined($getip)) {
          my $err="Host not found: $gethost";
          printlog "$id: requested host ".cleanstr($gethost)." not found";
          cliprint "HTTP/1.0 503 Service Unavailable\r\n".
                   "Content-Type: text/html\r\n".
                   "Content-Length: ", length($err)+1,
                   "\r\n\r\n$err\n";
          exit(0);
        }
        if(!rlconnect(inet_ntoa($getip))) {
          printlog "$id: Client hung up during connect rate-limit sleep";
          exit(0);
        }
        servprint "GET $gethost$getpath$getver\r\n".
                  "Host: $gethost\r\n\r\n";
        my $buf;
        my $i=65536;
        while($i>0 && defined($buf=servread(1024)) && length($buf)) {
          printlog "$id: HTTP response data: ".cleanstr($buf);
          cliprint $buf;
          $i-=length($buf);
        }
      }
      exit(0);
    }
  } elsif($direct_http_commands && $request =~ /^GET /) {
    printlog "$id: faking empty reply";
    if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                     'request headers'))) {
      cliprint $generic_empty_200_reply;
    }
  } elsif($direct_http_commands && $request =~ /^(POST|HEAD) http:\/\/.*?((?: HTTP\/1\.[01])?)\r?\n/) {
    # TODO: pass through safe HEADs like GETs
    my ($method, $ver)=($1,$2);
    printlog "$id: faking empty reply";
    if(defined(log_lines_until_blank(\&cliread, 500, 10000,
                                     'request headers'))) {
      cliprint $generic_empty_200_reply;
    }
    exit(0);
  } else {
    printlog "$id: rejecting unknown HTTP command";
    cliprint $generic_invalid_400_reply;
    exit(0);
  }
}

sub handle_raw
{
  printlog "$id: starting raw session";
  my ($clientwbuf, $serverwbuf)=('','');
  while(1) {
    my @rfds=($clientsock, $serversock);
    my @wfds=(length($clientwbuf)?($clientsock):(),
              length($serverwbuf)?($serversock):());
    my $nfound=RBSF::select(\@rfds, [], \@wfds, []);
    if(!defined($nfound) || $nfound==-1) {
      printlog "$id: exiting on select error: $!";
      exit(0);
    }
    if(grep { $_==$clientsock } @rfds) {
      my $clidata=cliread(-1024);
      if(!defined($clidata)) {
        printlog "$id: exiting on read error from client: $!";
        exit(0);
      }
      if(!length($clidata)) {
        # TODO: could try to keep writing in case the client only did a
        # shutdown() for writing instead of a close() - but how likely is
        # that?
        printlog "$id: exiting on EOF from client";
        exit(0);
      }
      printlog "$id: client->proxy ".cleanstr($clidata);
      $serverwbuf.=$clidata;
    }
    if(grep { $_==$serversock } @rfds) {
      my $servdata=servread(-1024);
      if(!defined($servdata)) {
        printlog "$id: exiting on read error from server: $!";
        exit(0);
      }
      if(!length($servdata)) {
        # TODO: could try to keep going here too
        printlog "$id: exiting on EOF from server";
        exit(0);
      }
      printlog "$id: server->proxy ".cleanstr($servdata);
      $clientwbuf.=$servdata;
    }
    if(length($clientwbuf) && grep { $_==$clientsock } @wfds) {
      my $n=rlwrite($clientsock, 'client', $clientwbuf); # exits on write error
      my $wrote=substr($clientwbuf, 0, $n);
      substr($clientwbuf, 0, $n)='';
      printlog "$id: proxy->client ".cleanstr($wrote);
    }
    if(length($serverwbuf) && grep { $_==$serversock } @wfds) {
      my $n=rlwrite($serversock, 'server', $serverwbuf); # exits on write error
      my $wrote=substr($serverwbuf, 0, $n);
      substr($serverwbuf, 0, $n)='';
      printlog "$id: proxy->server ".cleanstr($wrote);
    }
  }
  printlog "$id: end raw proxy";
}

sub randchar
{
  my ($set, $num)=@_;
  my $ret='';
  while($num--) {
    $ret.=substr($set, int(rand(length($set))), 1);
  }
  return $ret;
}

my $strftime_percent_z_ok;
BEGIN
{
  # I want strftime(%z), which is supported by POSIX::strftime if the
  # system's libc supports it (Linux does, others don't), or by
  # Date::Format::strftime if that module is installed (it is not part of the
  # perl distribution). This sets up a strftime() function which accepts 2
  # args (like the first 2 args of Date::Format::strftime), and sets
  # $strftime_percent_z_ok to true if %z will be recognized.

  # Try Date::Format first
  eval {
    require Date::Format;
  };
  if(!$@) {
    *strftime=sub { Date::Format::strftime($_[0], $_[1]) };
    $strftime_percent_z_ok=1;
    return;
  }

  *strftime=sub { POSIX::strftime($_[0], @{$_[1]}) };
  # Try POSIX::strftime. Behavior on an unrecognized format character is
  # undocumented, so assume the worst: it might throw an exception.
  my $zone='';
  eval {
    $zone=POSIX::strftime("%z", localtime());
  };
  if(!$@ && $zone =~ /^[-+]?\d+/) {
    $strftime_percent_z_ok=1;
    return;
  }

  # D'oh!
  $strftime_percent_z_ok=0;
}

sub date822
{
  my $nametz=$_[0];
  # We don't really want to use our own timezone here, as it has nothing to
  # do with the timezone of the target SMTP server which we are pretending to
  # be.
  my $savetz=exists($ENV{TZ}) ? $ENV{TZ} : undef;
  $ENV{TZ}='EST5EDT';
  my $ret;
  my $fakezonename=$nametz ? ' (%Z)' : '';
  my $fakezone=$strftime_percent_z_ok ? '%z' :
               (localtime())[8] ? '-0600' : '-0500';
  $ret=strftime("%a, %d %b %Y %H:%M:%S $fakezone$fakezonename", [localtime()]);
  if(defined($savetz)) {
    $ENV{TZ}=$savetz;
  } else {
    delete $ENV{TZ};
  }
  return $ret;
}

sub localdate822
{
  my $now=$_[0];
  # RFC2822 declares the %Z timezone names obsolete, so we only use it here
  # if %z is unavailable. We really do want the real local time zone here,
  # because it might be used for reporting the client to abuse@wherever
  my $zone=$strftime_percent_z_ok ? '%z' : '%Z';
  return strftime("%a, %d %b %Y %H:%M:%S $zone", [localtime($now)]);
}

my %smtp_servertypes;BEGIN{%smtp_servertypes=(
  aimc => {
    bannermatch => [
      [ qr/Server of AIMC/s, 900 ]
    ],
    banner =>
      sub {
            return "220 $_[0] SMTP Server of AIMC 2.9.5.2; ".date822(0)."\r\n";
          },
    dataend => sub { return "250 Requested mail action ok, completed.\r\n" },
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0], $_[1]<$_[3]> hello\r\n".
            "250-EXPN\r\n".
            "250-HELP\r\n".
            "250-8BITMIME\r\n".
            "250 XTMD\r\n"
          },
    expn => sub { return "250 OK\r\n" },
    helo => sub { return "250 $_[0] $_[1]<$_[3]> okay.\r\n" },
    help => sub { return "214 HELO MAIL RCPT DATA RSET VRFY EXPN QUIT\r\n" },
    hostname => "bta.net.cn",
    mail => sub { return "250 <$_[0]>, sender ok.\r\n" },
    needmail => "503 Bad sequence of commands\r\n",
    needrcpt => sub { return "503 Need RCPT before DATA.\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt =>
      sub {
            my $u=$_[0];
            $u =~ s/\@.*//;
            return "250 <$u:publicf>, Local recipient ok.\r\n"
          },
    rset => sub { return "250 Reset ok.\r\n" },
    syntax => sub { return "500 Syntax error, command unrecognized\r\n" },
    unknown => sub { return "500 Syntax error, command unrecognized\r\n" },
    vrfy => sub { return "500 Syntax error, command unrecognized\r\n" }
  },
  aol => {
    bannermatch => [
      [ qr/America Online/s, 900 ],
      [ qr/\baol\.com ESMTP/s, 900 ]
    ],
    helpmatch => [
      [ qr/America Online/s, 900 ],
      [ qr/\baol\.com/s, 900 ]
    ],
    banner =>
      sub {
            return
            "220-$_[0] ESMTP mail_relay_in-xl3.9; ".date822(0)."\r\n".
            "220-America Online (AOL) and its affiliated companies do not\r\n".
            "220-     authorize the use of its proprietary computers and computer\r\n".
            "220-     networks to accept, transmit, or distribute unsolicited bulk\r\n".
            "220      e-mail sent from the internet.\r\n"
          },
    dataend => sub { return "250 OK\r\n" },
    datastart => sub { return "354 START MAIL INPUT, END WITH \".\" ON A LINE BY ITSELF\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] $_[1]\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "500 SYNTAX ERROR, COMMAND UNRECOGNIZED\r\n" },
    helo => sub { return "250 $_[0] OK\r\n" },
    help =>
      sub {
            return
            "214-This is America Online mail version v89.10\r\n".
            "214-Commands:\r\n".
            "214-  HELO    EHLO    MAIL    RCPT    DATA\r\n".
            "214-  RSET    NOOP    QUIT    HELP\r\n".
            "214-For more information contact postmaster\@aol.com\r\n".
            "214 End of HELP info\r\n"
          },
    hostname => "rly-xl03.mx.aol.com",
    mail => sub { return "250 OK\r\n" },
    needmail => "503 BAD SEQUENCE OF COMMANDS\r\n",
    needrcpt => sub { return "503 BAD SEQUENCE OF COMMANDS\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 SERVICE CLOSING CHANNEL\r\n" },
    rcpt => sub { return "250 OK\r\n" },
    rset => sub { return "250 OK\r\n" },
    syntax => sub { return "501 SYNTAX ERROR IN PARAMETERS OR ARGUMENTS\r\n" },
    unknown => sub { return "500 SYNTAX ERROR, COMMAND UNRECOGNIZED\r\n" },
    vrfy => sub { return "500 SYNTAX ERROR, COMMAND UNRECOGNIZED\r\n" }
  },
  apex => {
    bannermatch => [
      [ qr/Apex ESMTP Ready/s, 900 ],
    ],
    helpmatch => [
      # We really don't want to have to use a helpmatch on this one because
      # the HELP reply is misformatted and will screw up the session. See for
      # example 209.53.145.143
      [ qr/ApexMail/s, 900 ],
    ],
    nostdbanner => 1,
    banner => sub { return "220 Apex ESMTP Ready\r\n" },
    dataend => sub { return "250 Ok.\r\n" }, # TODO: fix this wild guess.
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-Hello\r\n".
            "250-SIZE 10000000\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "500 error\r\n" },
    helo => sub { return "250 Hello\r\n" },
    help =>
      sub {
            return
            "214- ApexMail ESMTP Daemon v3.5.0 a2 By Arthur Lee\r\n".
            "214- CopyRight(C) 1998-2003 ApexMail.Net\r\n".
            "214- All Rights Reserved.\r\n".
            "214- \r\n".
            "214- Supported Commands:\r\n".
            "214- HELO <domain-name/address>\r\n".
            "214- MAIL FROM:<e-mail address>  RCPT TO:<e-mail address>\r\n".
            "214- HELP  DATA  QUIT  NOOP  RSET\r\n".
            "214- \r\n".
            "214- To report a bug with this SMTPd please send E-mail to:\r\n".
            "214- bugs\@apexmail.com\r\n".
            "214- \r\n".
            "214- Thank-You for using ApexMail \r\n".
            "214\r\n" # Yep, the final line is missing the space.
          },
    hostname => "Apex",
    mail => sub { return "250 <$_[0]> Ok.\r\n" },
    needmail => "503 missing MAIL FROM:<>\r\n",
    needrcpt => sub { return "503 missing RCPT TO:<>\r\n" },
    noop => sub { return "250 Ok.\r\n" },
    quit => sub { return "221 bye\r\n" },
    rcpt => sub { return "250 <$_[0]> Ok.\r\n" },
    rset => sub { return "250 Ok.\r\n" },
    syntax => sub { return "500 error\r\n" },
    unknown => sub { return "500 error\r\n" },
    vrfy => sub { return "500 error\r\n" }
  },
  asterisks => {
    bannermatch => [
      [ qr/\*\*\*\*\*/s, 900 ]
    ],
    helpmatch => [
      [ qr/^500/s, 15 ]
    ],
    nostdbanner => 1,
    banner =>
      sub {
            # I don't know which is worse: the thought that this banner full
            # of garbage is random, or that it actually means something and
            # it's deliberately not human-readable.
            return "220 ********************************************************************0*2******2*****************2******2002****0******0*00 \r\n";
          },
    dataend =>
      sub {
            my $msgid;
            if(!defined($_[4])) {
              my $alnum =
               "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
              $msgid="<CPIMSSMTPA".randchar("0123456", 1).
                     randchar("0123456789", 1).randchar($alnum, 7)."00".
                     randchar("0123457", 1).randchar("0123456789abcdef", 5).
                     '@'.$_[0].">";
            } else {
              $msgid=" <$_[4]>"
            }
            return "250 2.6.0 $msgid Queued mail for delivery\r\n";
          },
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo => sub { return "500 5.3.3 Unrecognized command\r\n" },
    expn => sub { return "500 5.3.3 Unrecognized command\r\n" },
    helo => sub { return "250 $_[0] Hello [$_[3]]\r\n" },
    help => sub { return "500 5.3.3 Unrecognized command\r\n" },
    hostname => "mail",
    mail => sub { return "250 2.1.0 $_[0]....Sender OK\r\n" },
    needmail => "503 5.5.2 Need Mail From: first\r\n",
    needrcpt => sub { return "503 5.5.2 Need Rcpt command.\r\n" },
    noop => sub { return "250 2.0.0 OK\r\n" },
    quit =>
      sub { return "221 2.0.0 $_[0] Service closing transmission channel\r\n" },
    rcpt => sub { return "250 2.1.5 $_[0] \r\n" },
    rset => sub { return "250 2.0.0 Resetting\r\n" },
    syntax => sub { return "501 5.5.4 Unrecognized parameter $_[1]\r\n" },
    unknown => sub { return "500 5.3.3 Unrecognized command\r\n" },
    vrfy => sub { return "500 5.3.3 Unrecognized command\r\n" }
  },
  domino => {
    bannermatch => [
      [ qr/Lotus Domino/s, 800 ],
      [ qr/Domino/s, 700 ]
    ],
    banner =>
      sub {
            return "220 $_[0] ESMTP Service ".
                   "(Lotus Domino Release 5.0.9a) ready at ".date822(0)."\r\n";
          },
    dataend => sub { return "250 Message accepted for delivery\r\n" },
    datastart => sub { return "354 Enter message, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1] ([$_[3]]), pleased to meet you\r\n".
            "250-HELP\r\n".
            "250-SIZE\r\n".
            "250 PIPELINING\r\n";
          },
    expn =>
      sub {
            return "252 Unable to EXPN \"$_[0]\",".
                   " but will accept message and attempt delivery\r\n";
          },
    helo =>
      sub { return "250 $_[0] Hello $_[1] ([$_[3]]), pleased to meet you\r\n" },
    help =>
      sub {
            return
            "214-Enter one of the following commands:\r\n".
            "214-HELO EHLO MAIL RCPT DATA RSET NOOP QUIT\r\n".
            "214 HELP \r\n"
          },
    hostname => "mail",
    mail => sub { return "250 $_[0]... Sender OK\r\n" },
    needmail => "503 Issue MAIL FROM: command before RCPT TO: command\r\n",
    needrcpt => sub { return "503 Issue RCPT TO: command before DATA command\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit =>
      sub { return "221 $_[0] SMTP Service closing transmission channel\r\n" },
    rcpt => sub { return "250 recipient <$_[0]> OK\r\n" },
    rset => sub { return "250 Ok\r\n" },
    syntax =>
      sub {
            return {
              MAIL => "501 Syntax error in originator address\r\n",
              DATA => "501 Syntax error, parameters in command ".
                      "\"DATA $_[1]\" unrecognized\r\n",
              HELO => "501 Command \"HELO\" requires an argument\r\n",
            }->{$_[0]} || ("501 Syntax error, parameters in command ".
                           "\"$_[0] $_[1]\" unrecognized or missing\r\n");
          },
    unknown =>
      sub { return "500 Syntax error, command \"$_[0]\" unrecognized\r\n" },
    vrfy =>
      sub {
            return "252 Unable to VRFY \"$_[0]\",".
                   " but will accept message and attempt delivery\r\n";
          }
  },
  earthlink => { # probably just Sendmail with a slightly unusual configuration
    bannermatch => [
      [ qr/EL_.*Earthlink/s, 900 ],
      [ qr/Earthlink/s, 800 ]
    ],
    helpmatch => [
      [ qr/Earthlink/s, 800 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] EL_3_5_14 /EL_3_5_14  ESMTP Earthlink Mail Service ".
            date822(1)."\r\n"
          },
    dataend =>
      sub {
            my $alnum =
              "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
            return "250 1".randchar("78", 1).randchar($alnum, 7).
                   "3Nl3p40 Message accepted for delivery\r\n";
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1] [$_[3]], pleased to meet you\r\n".
            "250-8BITMIME\r\n".
            "250-SIZE 10485760\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "502 Command unrecognized \"EXPN\"" },
    helo => sub { return "250 $_[0] Hello $_[1] [$_[3]], please to meet you\r\n" },
    help =>
      sub {
            return
            "214-Earthlink Mail Service\r\n".
            "214-Commands:\r\n".
            "214-    HELO   EHLO   MAIL   RCPT\r\n".
            "214-    DATA   RSET   NOOP   QUIT\r\n".
            "214 End of HELP Info\r\n"
          },
    hostname => "payne.mail.mindspring.net",
    mail => sub { return "250 <$_[0]>... Sender ok\r\n" },
    needmail => "503 Need MAIL before RCPT\r\n",
    needrcpt => sub { return "503 Need RCPT (recipient)\r\n" },
    noop => sub { return "250 ok\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 <$_[0]>... Recipient ok\r\n" },
    rset => sub { return "250 reset state\r\n" },
    syntax => sub { return "501 Syntax error in parameters\r\n" },
    unknown => sub { return "500 Command unrecognized \"$_[0]\"\r\n" },
    vrfy => sub { return "502 Command unrecognized \"VRFY $_[0]\"\r\n" }
  },
  exchange55 => {
    bannermatch => [
      [ qr/Microsoft SMTP MAIL.*Version: 5\.5/s, 900 ]
    ],
    banner =>
      sub {
            return "220 $_[0] ESMTP Server ".
                   "(Microsoft Exchange Internet Mail Service 5.5.2653.13)".
                   " ready\r\n"
          },
    dataend => sub { return "250 OK\r\n" },
    datastart => sub { return "354 Send data.  End with CRLF.CRLF\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello [$_[1]]\r\n".
            "250-XEXCH50\r\n".
            "250-HELP\r\n".
            "250-ETRN\r\n".
            "250-DSN\r\n".
            "250-SIZE 0\r\n".
            "250-AUTH LOGIN\r\n".
            "250 AUTH=LOGIN\r\n"
          },
    expn => sub { return "502 command not implemented\r\n" },
    helo => sub { return "250 OK\r\n" },
    help =>
      sub {
            return
            "214-Commands:\r\n".
            "214-     HELO     MAIL     RCPT     DATA     RSET\r\n".
            "214-     NOOP     QUIT     HELP     VRFY     ETRN\r\n".
            "214-     XEXCH50  STARTTLS AUTH\r\n".
            "214 End of HELP info\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 OK - mail from <$_[0]>\r\n" },
    needmail => "503 No originator: need MAIL\r\n",
    needrcpt => sub { return "503 No recipients: need RCPT\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 closing connection\r\n" },
    rcpt => sub { return "250 OK - Recipient <$_[0]>\r\n" },
    rset => sub { return "250 OK - Reset\r\n" },
    syntax => sub { return "501 Syntax Error\r\n" },
    unknown =>
      sub { return length($_[0])?"500 Command not recognized.\r\n":"" },
    vrfy => sub { return "252 Cannot verify user\r\n" }
  },
  exim => {
    bannermatch => [
      [ qr/ESMTP Exim \d/s, 1000 ]
    ],
    banner => sub { return "220 $_[0] ESMTP Exim 3.13 #2 ".date822(0)."\r\n" },
    dataend =>
      sub {
            my $alnum =
              "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
            return "250 OK id=18".
                   randchar("01234", 1).
                   randchar($alnum, 3).
                   "-000".
                   randchar("01234567", 1).
                   randchar($alnum, 2).
                   "-00\r\n";
          },
    datastart => sub { return "354 Enter message, ending with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            # TODO: set $ident based on characteristics of last proxy in chain
            my $ident=0?'nobody at ':'';
            return
            "250-$_[0] Hello $ident$_[1] [$_[3]]\r\n".
            "250-SIZE\r\n".
            "250-PIPELINING\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "550 EXPN not available\r\n" },
    helo =>
      sub {
            # TODO: set $ident based on characteristics of last proxy in chain
            my $ident=0?'nobody at ':'';
            return "250 $_[0] Hello $ident$_[1] [$_[3]]\r\n";
          },
    help =>
      sub {
            return
            "214-Commands supported:\r\n".
            "214-    HELO EHLO MAIL RCPT DATA\r\n".
            "214     NOOP QUIT RSET HELP \r\n"
          },
    hostname => "mail",
    mail => sub { return "250 <$_[0]> is syntactically correct\r\n" },
    needmail => "503 No sender yet given\r\n",
    needrcpt => sub { return "503 Valid RCPT TO <recipient> must precede DATA\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 <$_[0]> is syntactically correct\r\n" },
    rset => sub { return "250 Reset OK\r\n" },
    syntax => sub { return "500 Command unrecognized\r\n" },
    unknown => sub { return "500 Command unrecognized\r\n" },
    vrfy => sub { return "252 VRFY not available\r\n" }
  },
  firstclass => {
    bannermatch => [
      [ qr/FirstClass ESMTP Mail Server/s, 900 ],
      [ qr/FirstClass/s, 800 ]
    ],
    helpmatch => [
      [ qr/^500/s, 15 ]
    ],
    banner =>
      sub { return "220 $_[0] FirstClass ESMTP Mail Server v6.1 ready\r\n" },
    dataend =>
      sub {
            return "250 ".randchar("0123456789ABCDEF", 8).
                   " Message accepted, transient identifier was ".
                   int(rand(32768))."\r\n";
          },
    datastart => sub { return "354 Send your message, end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1] ($_[3]), pleased to meet you\r\n".
            "250-PIPELINING\r\n".
            "250 8BITMIME\r\n"
          },
    expn => sub { return "502 I don't do EXPN\r\n" },
    helo => sub { return "250 $_[0] Hello $_[1] ($_[3]), pleased to meet you\r\n" },
    help => sub { return "500 HELP command not supported\r\n" },
    hostname => "mail",
    mail => sub { return "250 $_[0]... Sender ok\r\n" },
    needmail => "503 Must send MAIL FROM before RCPT TO\r\n",
    needrcpt => sub { return "503 Must send at least one RCPT TO\r\n" },
    noop => sub { return "250 NOOP complete\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 $_[0]... Recipient ok\r\n" },
    rset => sub { return "250 Reset state\r\n" },
    syntax =>
      sub {
            return {
              MAIL => "250 Mailer-Daemon... Sender ok\r\n",
              NOOP => "250 NOOP complete\r\n",
              RSET => "250 Reset state\r\n",
              RCPT => "501 Invalid recipient address\r\n",
            }->{$_[0]} || "250 ok\r\n";
          },
    unknown => sub { return "500 Command not recognized: $_[0]\r\n" },
    vrfy =>
      sub {
            my $u=ucfirst(lc($_[0]));
            $u =~ s/\@.*//;
            return "250 $u <$_[0]>\r\n"
          }
  },
  fsmtpd => {
    bannermatch => [
      [ qr/\bfsmtpd ready\b/s, 800 ],
      [ qr/\bfsmtpd\b/s, 700 ]
    ],
    helpmatch => [
      [ qr/See RFC 821, RFC 1123/s, 400 ]
    ],
    banner =>
      sub { return "220 $_[0] ESMTP receiver fsmtpd ready.\r\n" },
    dataend => sub { return "250 Message accepted.\r\n" },
    datastart => sub { return "354 Ok, start with data.\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] ready.\r\n".
            "250-SIZE 33554432\r\n".
            "250-8BITMIME\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "500 Unknown command.\r\n" },
    helo => sub { return "250 Ok.\r\n" },
    help =>
      sub {
            return
            "250-Supported commands:\r\n".
            "250-HELO EHLO MAIL RCPT DATA RSET NOOP QUIT HELP\r\n".
            "250 See RFC 821, RFC 1123, RFC 1869, RFC 1870.\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 Ok.\r\n" },
    needmail => "503 Sender not specified.\r\n",
    needrcpt => sub { return "503 No (valid) recipients specified.\r\n" },
    noop => sub { return "250 Ok.\r\n" },
    quit => sub { return "221 $_[0] closing.\r\n" },
    rcpt => sub { return "250 Ok.\r\n" },
    rset => sub { return "250 Ok.\r\n" },
    syntax => sub { return "500 Unknown command.\r\n" },
    unknown => sub {return "500 Unknown command.\r\n"},
    vrfy => sub { return "252 Unsupported.\r\n" }
  },
  gordano => {
    bannermatch => [
      [ qr/\bGordano\b/s, 700 ]
    ],
    helpmatch => [
      [ qr/Gordano Ltd's Mail Server/s, 1000 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] Gordano Messaging Suite (v8.00.3075/KX0105.01.221c0ea8)".
            "ready for ESMTP transfer   \r\n"
          },
    dataend =>
      sub {
            return "250 Received message ".
                   randchar("abcdefghijklmnopqrstuvwxyz", 5).
                   randchar("bc", 1)."aa OK.\r\n";
          },
    datastart => sub { return "354 3.5.4 Start mail input, end with <CRLF>.<CRLF>.\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1] [$_[3]], pleased to meet you\r\n".
            "250-ENHANCEDSTATUSCODES\r\n".
            "250-8BITMIME\r\n".
            "250-ETRN\r\n".
            "250-DSN\r\n".
            "250-AUTH LOGIN\r\n".
            "250-XRCPTLIMIT 100\r\n".
            "250-XAUD 789229kw472325404083194 0.9\r\n".
            "250 HELP\r\n",
          },
    expn => sub { return "505 5.7.2 Disabled.\r\n" },
    helo => sub { return "250 $_[0] $_[1]\r\n" },
    help =>
      sub {
            return
            "214- This is an NT Server running Gordano Ltd's Mail Server\r\n".
            "214-\r\n".
            "214- A typical mail delivery sequence is:\r\n".
            "214- HELO your-computer-name\r\n".
            "214- MAIL From:<you\@your-machine>\r\n".
            "214- RCPT To:<your-friend\@$_[0]>\r\n".
            "214- DATA\r\n".
            "214- QUIT\r\n".
            "214- also supported are RSET NOOP HELP VRFY & EXPN\r\n".
            "214- \r\n".
            "214- If you have any problems please e-mail:\r\n".
            "214  PostMaster\@$_[0]\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 2.5.0 OK.\r\n" },
    needmail => "503 5.5.1 Bad sequence of commands.\r\n",
    needrcpt => sub { return "503 5.5.1 Bad sequence of commands.\r\n" },
    noop => sub { return "250 2.5.0 Requested mail action ok, completed.\r\n" },
    quit => sub { return "221 Goodbye [$_[2]]\r\n" },
    rcpt => sub { return "250 2.5.0 OK.\r\n" },
    rset => sub { return "250 2.5.0 OK.\r\n" },
    syntax => sub { return "250 2.5.0 OK.\r\n" },
    unknown => sub {return "501 5.5.1 Syntax error, command unrecognised.\r\n"},
    vrfy => sub { return "558 5.5.4 VRFY not allowed.\r\n" }
  },
  groupwise => {
    bannermatch => [
      [ qr/\bGroupWise.*Novell\b/s, 900 ],
      [ qr/\bGroupWise\b/s, 700 ]
    ],
    helpmatch => [
      [ qr/^500/s, 15 ]
    ],
    banner =>
      sub {
            return "220 $_[0] GroupWise Internet Agent 6.0.2".
                   " (C)1993, 2002 Novell, Inc.  Ready\r\n"
          },
    dataend => sub { return "250 Ok\r\n" },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0]\r\n".
            "250-8BITMIME\r\n".
            "250-SIZE\r\n".
            "250-DSN\r\n".
            "250-AUTH LOGIN\r\n".
            "250 AUTH=LOGIN\r\n"
          },
    expn => sub { return "500 Syntax error\r\n" },
    helo => sub { return "250 $_[0] Ok\r\n" },
    help => sub { return "500 Syntax error\r\n" },
    hostname => "mail",
    mail => sub { return "250 Ok\r\n" },
    needmail => "503 Bad command sequence\r\n",
    needrcpt => sub { return "503 Bad command sequence\r\n" },
    noop => sub { return "250 Ok\r\n" },
    quit => sub { return "221 $_[0] Closing transmission channel\r\n" },
    rcpt => sub { return "250 Ok\r\n" },
    rset => sub { return "250 Ok\r\n" },
    syntax => sub { return "501 Syntax error in arguments\r\n" },
    unknown => sub {return "500 Syntax error\r\n"},
    vrfy => sub { return "550 Unable to verify\r\n" }
  },
  # IMail is not only a frequently RFC-ignorant mail server, but also
  # English-ignorant, as seen in the grammatical errors in the reply strings
  # below. Dijkstra was right: "Besides a mathematical inclination, an
  # exceptionally good mastery of one's native tongue is the most vital asset
  # of a competent programmer."
  imail => {
    bannermatch => [
      [ qr/\bIMail \d.*X1/s, 900 ],
      [ qr/X1.*\bIMail \d/s, 900 ]
    ],
    nostdbanner => 1, # Some versions, anyway
    banner =>
      sub { return "220 $_[0] (IMail 7.12 428581-36) NT-ESMTP Server X1\r\n" },
    dataend => sub { return "250 Message queued\r\n" },
    datastart => sub { return "354 ok, send it; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] says hello\r\n".
            "250-SIZE 0\r\n".
            "250-8BITMIME\r\n".
            "250-DSN\r\n".
            "250-ETRN\r\n".
            "250-AUTH LOGIN\r\n".
            "250-AUTH=LOGIN\r\n".
            "250 EXPN\r\n"
          },
    expn => sub { return "550 list not found\r\n" },
    helo => sub { return "250 $_[0]\r\n" },
    help => sub { return "211 DATA EXPN HELO MAIL NOOP QUIT RCPT RSET SAML SEND SOML TURN VRFY\r\n" },
    hostname => "mail",
    mail => sub { return "250 ok\r\n" },
    needmail => "503 must have sender first\r\n",
    needrcpt => sub { return "503 must have sender and recipient first\r\n" },
    noop => sub { return "250 ok\r\n" },
    quit => sub { return "221 Goodbye\r\n" },
    rcpt => sub { return "250 ok its for <$_[0]>\r\n" },
    rset => sub { return "250 ok its reset\r\n" },
    syntax =>
      sub {
            return {
              MAIL => "501 invalid RFC syntax for <me>\r\n",
              RCPT => "550 unknown user <$_[1]>\r\n"
            }->{$_[0]} || "501 Syntax error\r\n";
          },
    unknown => sub { return "502 unimplemented command\r\n" },
    vrfy => sub { return "250 ok its for <$_[0]>\r\n" }
  },
  intermail => {
    bannermatch => [
      [ qr/\bInterMail\b/s, 700 ]
    ],
    helpmatch => [
      [ qr/\bInterMail\b/s, 700 ]
    ],
    banner =>
      sub {
            return "220 $_[0] ESMTP server ".
                   "(InterMail vM.4.01.03.37 201-229-121-137-20020806) ready".
                   date822(0)."\r\n"
          },
    dataend =>
      sub {
            my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime();
            return
              sprintf("250 Message received: %d%02d%02d%02d%02d%02d.",
                      $year+1900, $mon+1, $mday, $hour, $min, $sec,
                      int(rand(32768))).
              randchar("ABCDEFGHIJKLMNOPQRSTUVWXYZ", 5).int(rand(32768)).
              ".$_[0]\@$_[3]\r\n";
          },
    datastart => sub { return "354 Ok Send data ending with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0]\r\n".
            "250-HELP\r\n".
            "250-XREMOTEQUEUE\r\n".
            "250-ETRN\r\n".
            "250-PIPELINING\r\n".
            "250-DSN\r\n".
            "250 SIZE 10485760\r\n"
          },
    expn => sub { return "502 Command is locally disabled\r\n" },
    helo => sub { return "250 $_[0]\r\n" },
    help =>
      sub {
            return
            "214-This SMTP server is a part of the InterMail E-mail system.  For\r\n".
            "214-information about InterMail, please see http://www.software.com\r\n".
            "214-\r\n".
            "214-      Supported commands:\r\n".
            "214-\r\n".
            "214-           EHLO     HELO     MAIL     RCPT     DATA\r\n".
            "214-           VRFY     RSET     NOOP     QUIT\r\n".
            "214-\r\n".
            "214-      SMTP Extensions supported through EHLO:\r\n".
            "214-\r\n".
            "214-           EXPN     HELP     SIZE\r\n".
            "214-\r\n".
            "214-For more information about a listed topic, use \"HELP <topic>\"\r\n".
            "214 Please report mail-related problems to Postmaster at this site.\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 Sender <$_[0]> Ok\r\n" },
    needmail => "503 Bad sequence of commands (specify MAIL first)\r\n",
    needrcpt => sub { return "503 No recipients specified\r\n" },
    noop => sub { return "250 Ok\r\n" },
    quit => sub { return "221 $_[0] ESMTP server closing connection\r\n" },
    rcpt => sub { return "250 Recipient <$_[0]> Ok\r\n" },
    rset => sub { return "250 Ok resetting state\r\n" },
    syntax =>
      sub {
            return {
              MAIL => "501 Usage: MAIL FROM:<sender>\r\n",
              RCPT => "501 Usage: RCPT TO:<recipient>\r\n",
              HELO => "250 Ok\r\n",
              NOOP => "250 Ok\r\n",
              RSET => "250 Ok\r\n",
            }->{$_[0]} || "501 Syntax error\r\n";
          },
    unknown => sub { return "500 Command unknown: '$_[0]'\r\n" },
    vrfy => sub { return "502 Command is locally disabled\r\n" }
  },
  juno => { # probably just Sendmail with a slightly unusual configuration
    helpmatch => [
      [ qr/To report bugs.*smtp\@support\.juno\.com/s, 1000 ],
      [ qr/\bjuno\.com/s, 900 ]
    ],
    banner => sub { return "220 $_[0] ESMTP\r\n" },
    dataend =>
      sub {
            return "250 OK id AAA8".randchar("2345XYZ", 1).
                   randchar("23456789ABCDEFGHJKLMNPQRSTUVWXYZ", 4)."A".
                   randchar("234567ABCDEFGHJKLMNPQRSTUVWXYZ", 1).
                   randchar("23456789ABCDEFGHJKLMNPQRSTUVWXYZ", 4).
                   randchar("2AJS", 1)."\r\n";
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1] pleased to meet you\r\n".
            "250-SIZE\r\n".
            "250-8BITMIME\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "502 Sorry, we do not allow this operation\r\n" },
    helo => sub { return "250 $_[0] Hello $_[1] pleased to meet you\r\n" },
    help =>
      sub {
            return
            "214-To report bugs in the implementation, send mail to smtp\@support.juno.com\r\n".
            "214-If you are not sure they are bugs or for local information,\r\n".
            "214-please send mail to your own postmaster.\r\n".
            "214 End of HELP info\r\n"
          },
    hostname => "mx8.nyc.untd.com",
    mail => sub { return "250 $_[0]... Sender OK\r\n" },
    needmail => "503 Command out of sequence\r\n",
    needrcpt => sub { return "503 Command out of sequence\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] Closing connection\r\n" },
    rcpt => sub { return "250 $_[0]... Recipient OK\r\n" },
    rset => sub { return "250 Reset state\r\n" },
    syntax => sub { return "501 Syntax error in $_[0]\r\n" },
    unknown => sub { return "500 Command unrecognized\r\n" },
    vrfy =>
      sub {
            return "252 Cannot VRFY user;".
                   " try RCPT to attempt delivery (or try finger)\r\n"
          }
  },
  litemail => {
    bannermatch => [
      [ qr/LiteMail v\d+\.\d+/s, 900 ],
      [ qr/LiteMail/s, 700 ],
    ],
    helpmatch => [
      # We really don't want to have to use a helpmatch on this one because
      # the HELP reply is misformatted and will screw up the session. See for
      # example 64.15.239.131
      [ qr/BrickMail/s, 700 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] LiteMail v3.03(BFLITEMAIL2A); ".date822(0)."\r\n"
          },
    dataend => sub { return "250 Message accepted for delivery\r\n" },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello [$_[3]], pleased to meet you\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "500 Command unrecognized\r\n" },
    helo => sub { return "250 $_[0] Hello [$_[3]], pleased to meet you\r\n" },
    help =>
      sub {
            # Yes this misformatted piece of crap is an accurate imitation.
            return
            "214-This is BrickMail version 0.0.1\r\n".
            "214-Commands:\r\n".
            "214-    HELO    MAIL    RCPT    DATA\r\n".
            "214-    RSET    NOOP    QUIT    HELP\r\n".
            "\r\n".
            "214-To report bugs in the implementation send email to\r\n".
            "214-    postmaster\@bigfoot.com\r\n".
            "214-For local information send email to Postmaster at your site.\r\n".
            "214 End of HELP info\r\n".
            "\r\n"
          },
    hostname => "mx.bigfoot.com",
    mail => sub { return "250 <$_[0]>... Sender Ok\r\n" },
    needmail => "503 Need MAIL command\r\n",
    needrcpt => sub { return "503 Need RCPT command\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 Closing connection\r\n" },
    rcpt => sub { return "250 <$_[0]>... Recipient Ok\r\n" },
    rset => sub { return "250 Reset State\r\n" },
    syntax => sub { return "501 Syntax error in parameters scanning \"$_[1]\"\r\n" },
    unknown => sub { return "500 Command unrecognized\r\n" },
    vrfy => sub { return "500 Command unrecognized\r\n" }
  },
  lsmtp => {
    bannermatch => [
      [ qr/LSMTP for Windows/s, 900 ],
      [ qr/\bLSMTP\b/s, 700 ]
    ],
    helpmatch => [
      [ qr/XLICENSE/s, 800 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] (LSMTP for Windows NT v1.1b) ESMTP server ready\r\n"
          },
    dataend =>
      sub {
            return "250 Ok, message queued (".
                   ($_[1]+int(rand(200)+100))." bytes)\r\n";
          },
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] says hello to $_[1]\r\n".
            "250-8BITMIME\r\n".
            "250-PIPELINING\r\n".
            "250-XLSMTP-DATASIZE\r\n".
            "250-XLSMTP-ACKRCPT\r\n".
            "250-XLSMTP-MMERGE\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "502 Command not implemented\r\n" },
    helo => sub { return "250 $_[0] says hello to $_[1]\r\n" },
    help =>
      sub {
            return
            "214- Hello.  I understand many of the commands defined in RFC 821,\r\n".
            "214- and the following extra ones:\r\n".
            "214-   XLICENSE\r\n".
            "214-\r\n".
            "214 Please say HELP <command> for more information.\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 Ok\r\n" },
    needmail => "503 Bad sequence of commands (no active transaction)\r\n",
    needrcpt => sub { return "554 Transaction failed (no recipients specified)\r\n" },
    noop => sub { return "250 Take your time...\r\n" },
    quit => sub { return "221 $_[0] says goodbye\r\n" },
    rcpt => sub { return "250 Ok\r\n" },
    rset => sub { return "250 Ok\r\n" },
    syntax => sub { return "504 Command parameter unrecognized\r\n" },
    unknown => sub { return "500 Syntax error, command unrecognized\r\n" },
    vrfy => sub { return "252 VRFY command disabled\r\n" }
  },
  # Lyris ListManager highlights:
  #   - gets HELO and EHLO backward.
  #   - accepts RCPT without a MAIL command (assumes MAIL FROM:<>).
  # Jesus Tapdancing Christ, get yourself into a drug rehabilitation program
  # before you write more code like this.
  lyris => {
    bannermatch => [
      [ qr/Lyris ListManager/s, 900 ]
    ],
    helpmatch => [
      [ qr/^502/s, 15 ]
    ],
    banner =>
      sub { return "220 $_[0] ESMTP Lyris ListManager service ready\r\n" },
    dataend => sub { return "250 Errormail message accepted.\r\n" },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub { return "250 $_[0] Hello $_[1] [$_[3]], pleased to meet you\r\n" },
    expn => sub { return "500 Command unrecognized\r\n" },
    helo =>
      sub {
            return
            "250-$_[0] Hello $_[1] [$_[3]], pleased to meet you\r\n".
            "250 8BITMIME\r\n"
          },
    help => sub { return "502 HELP not implemented\r\n" },
    hostname => "mail",
    mail => sub { return "250 <$_[0]>... Sender ok\r\n" },
    needmail => "250 OK\r\n",
    needrcpt => sub { return "250 OK\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 <$_[0]>... Recipient ok\r\n" },
    rset => sub { return "250 Reset state\r\n" },
    syntax => sub { return "500 Command unrecognized\r\n" },
    unknown => sub { return "500 Command unrecognized\r\n" },
    vrfy => sub { return "252 Cannot VRFY user\r\n" }
  },
  merak => {
    bannermatch => [
      [ qr/SMTP Merak/s, 900 ]
    ],
    helpmatch => [
      [ qr/This is Merak/s, 900 ]
    ],
    banner => sub { return "220 $_[0] SMTP Merak 4.4.2; ".date822(0)."\r\n" },
    dataend =>
      sub {
            my ($hr,$min,$sec);
            $sec=time()-$_[2];
            $min=int($sec/60);
            $sec %= 60;
            $hr=int($min/60);
            $min %= 60;
            return "250 2.6.0 ".($_[1]+int(rand(200)+100)).
                   " bytes received in $hr:$min:$sec;".
                   " Message accepted for delivery\r\n";
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub { return "502 5.5.1 Sorry, we do not support this operation\r\n" },
    expn =>
      sub { return "502 5.5.1 Sorry, we do not support this operation\r\n" },
    helo =>
      sub { return "250 $_[0] Hello $_[1] [$_[3]], pleased to meet you.\r\n" },
    help =>
      sub {
            return
            "214-2.0.0 This is Merak 4.4.2\r\n".
            "214-2.0.0 Topics:\r\n".
            "214-2.0.0     HELO     EHLO     MAIL     RCPT     DATA\r\n".
            "214-2.0.0     RSET     NOOP     QUIT     HELP     VRFY\r\n".
            "214-2.0.0     EXPN     ETRN     DSN      AUTH     STARTTLS\r\n".
            "214-2.0.0 For more info use \"HELP <topic>\".\r\n".
            "214-2.0.0 To report bugs in the implementation send email to\r\n".
            "214-2.0.0     bugs\@icewarp.com\r\n".
            "214 2.0.0 End of Help info\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 2.1.0 <$_[0]>... Sender ok\r\n" },
    needmail => "503 5.5.1 Incorrect command sequence\r\n",
    needrcpt => sub { return "503 5.5.1 Incorrect command sequence\r\n" },
    noop => sub { return "250 2.0.0 OK\r\n" },
    quit => sub { return "221 2.0.0 $_[0] closing connection\r\n" },
    rcpt =>
      sub {
            my $x=(lc($_[0]) eq "postmaster")?'Postmaster':'Recipient';
            return "250 2.1.5 <$_[0]>... $x ok\r\n"
          },
    rset => sub { return "250 2.0.0 Reset state\r\n" },
    syntax => sub {return "501 5.5.2 Syntax error in parameters scanning\r\n"},
    unknown => sub { return "502 5.5.1 Command unrecognized: \"$_[0]\"\r\n" },
    vrfy =>
      sub { return "502 5.5.1 Sorry, we do not support this operation\r\n" }
  },
  mercury => {
    bannermatch => [
      [ qr/Mercury \d/s, 900 ],
      [ qr/\bMercury\b/s, 800 ]
    ],
    helpmatch => [
      [ qr/Mail server account is/s, 500 ]
    ],
    banner => sub { return "220 $_[0] Mercury 1.48 ESMTP server ready.\r\n" },
    dataend => sub { return "250 Data received OK.\r\n" },
    datastart => sub { return "354 OK, send data, end with CRLF.CRLF\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1]; ESMTPs are:\r\n".
            "250-TIME\r\n".
            "250-SIZE 2000000\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "502 Command not implemented.\r\n" },
    helo => sub { return "250 $_[0] Hi there, $_[1].\r\n" },
    help =>
      sub {
            return
            "214-Recognized SMTP commands are:\r\n".
            "214-   HELO   EHLO   MAIL   RCPT   DATA   RSET   AUTH\r\n".
            "214-   NOOP   QUIT   HELP   VRFY   SOML   TIME\r\n".
            "214 Mail server account is 'Postmaster'.\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 Sender OK - send RCPTs.\r\n" },
    needmail => "503 Bad sequence of commands.\r\n",
    needrcpt => sub { return "503 No valid recipients specified.\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] Service closing channel.\r\n" },
    rcpt => sub { return "250 Recipient OK - send RCPT or DATA.\r\n" },
    rset => sub { return "250 Command processed OK.\r\n" },
    syntax => sub { return "250 Sender OK - send RCPTs.\r\n" },
    unknown => sub { return "503 Bad sequence of commands.\r\n" },
    vrfy =>
      sub { return "251 User exists, but domain may be suspect <$_[0]>\r\n" },
  },
  microsoft50 => {
    bannermatch => [
      [ qr/Microsoft ESMTP MAIL Service.*Version: 5\.0/s, 900 ]
    ],
    banner =>
      sub {
            return "220 $_[0] Microsoft ESMTP MAIL Service, ".
                   "Version: 5.0.2195.4453 ready at  ".date822(0)." \r\n"
          },
    dataend =>
      sub {
            my $msgid;
            if(!defined($_[4])) {
              my $alnum =
               "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
              $msgid="<CPIMSSMTPA".randchar("0123456", 1).
                     randchar("0123456789", 1).randchar($alnum, 7)."00".
                     randchar("0123457", 1).randchar("0123456789abcdef", 5).
                     '@'.$_[0].">";
            } else {
              $msgid=" <$_[4]>"
            }
            return "250 2.6.0 $msgid Queued mail for delivery\r\n";
          },
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello [$_[3]]\r\n".
            "250-SIZE 3145728\r\n".
            "250-PIPELINING\r\n".
            "250-ENHANCEDSTATUSCODES\r\n".
            "250-8bitmime\r\n".
            "250-BINARYMIME\r\n".
            "250-CHUNKING\r\n".
            "250-VRFY\r\n".
            "250 OK\r\n"
          },
    expn => sub { return "500 5.3.3 Unrecognized command\r\n" },
    helo => sub { return "250 $_[0] Hello [$_[3]]\r\n" },
    help =>
      sub {
            return
            "214-This server supports the following commands:\r\n".
            "214 HELO EHLO STARTTLS RCPT DATA RSET MAIL QUIT HELP BDAT\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 2.1.0 $_[0]....Sender OK\r\n" },
    needmail => "503 5.5.2 Need Mail From: first\r\n",
    needrcpt => sub { return "503 5.5.2 Need Rcpt command.\r\n" },
    noop => sub { return "250 2.0.0 OK\r\n" },
    quit =>
      sub {
            return "221 2.0.0 $_[0] Service closing transmission channel\r\n"
          },
    rcpt => sub { return "250 2.1.5 $_[0]\r\n" },
    rset => sub { return "250 2.0.0 Resetting\r\n" },
    syntax => sub { return "501 5.5.4 Unrecognized parameter $_[1]\r\n" },
    unknown =>
      sub { return length($_[0])?"500 5.3.3 Unrecognized command\r\n":"" },
    vrfy =>
      sub {
            return "252 2.1.5 Cannot VRFY user,".
                   " but will accept message for <$_[0]>\r\n"
          }
  },
  microsoft55 => {
    bannermatch => [
      [ qr/Microsoft SMTP MAIL.*Version: 5\.5/s, 900 ]
    ],
    banner =>
      sub {
            return "220-$_[0] Microsoft SMTP MAIL ready at ".date822(0).
                   " Version: 5.5.1877.757.75\r\n".
                   "220 ESMTP spoken here\r\n"
          },
    dataend =>
      sub {
            my $aname=$_[0];
            $aname =~ s/\..*//;
            $aname =~ tr/a-z/A-Z/;
            return "250 0".randchar("0123456789abcdef", 10).randchar("01", 1).
              randchar("0123456789abcdef", 2).
              "2$aname Queued mail for delivery\r\n";
          },
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello [$_[3]]\r\n".
            "250-SIZE 31457280\r\n".
            "250-ETRN\r\n".
            "250-PIPELINING\r\n".
            "250-8bitmime\r\n".
            "250-TURN\r\n".
            "250 ATRN\r\n"
          },
    expn => sub { return "500 Unrecognized command\r\n" },
    helo => sub { return "250 $_[0] Hello [$_[3]]\r\n" },
    help =>
      sub {
            return
            "214-This server supports the following commands:\r\n".
            "214-HELO EHLO STARTTLS RCPT DATA RSET MAIL VRFY QUIT HELP ETRN\r\n".
            "214 End of HELP information\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 $_[0]....Sender OK\r\n" },
    needmail => "503 Need Mail From: first\r\n",
    needrcpt => sub { return "503 Need Rcpt command.\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] Service closing transmission channel\r\n" },
    rcpt => sub { return "250 $_[0]\r\n" },
    rset => sub { return "250 Resetting\r\n" },
    syntax => sub { return "501 Unrecognized parameter $_[1]\r\n" },
    unknown => sub { return "500 Unrecognized command\r\n" },
    vrfy => sub { return "250 <$_[0]>\r\n" }
  },
  navgw => {
    bannermatch => [
      [ qr/NAVGW.*symantec/s, 900 ],
      [ qr/\bNAVGW\b/s, 700 ]
    ],
    helpmatch => [
      [ qr/^500/s, 15 ]
    ],
    banner =>
      sub {
            return "220 $_[0] SMTP NAVGW 2.5.1.6; ".date822(0).
            " http://symantec.com\r\n"
          },
    dataend =>
      sub {
            my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime();
            return sprintf
              "250 M%d%02d%02d%02d%02d%02d%05d Message accepted for delivery",
              $year+1900, $mon+1, $mday, $hour, $min, $sec, int(rand(32768));
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo => sub { return "250 $_[0] Hello\r\n" },
    expn => sub { return "502 Sorry, we do not allow this operation\r\n" },
    helo => sub { return "250 $_[0] Hello\r\n" },
    help => sub { return "500 Syntax error, command unrecognized.\r\n" },
    hostname => "mail",
    mail => sub { return "250 <$_[0]>... Sender ok\r\n" },
    needmail => "503 Need MAIL before RCPT\r\n",
    needrcpt => sub { return "503 Need RCPT (recipient)\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] closing connection.\r\n" },
    rcpt => sub { return "250 <$_[0]>... Recipient ok\r\n" },
    rset => sub { return "250 Reset State\r\n" },
    syntax => sub { return "501 Syntax error in parameters\r\n" },
    unknown => sub { return "500 Syntax error, command unrecognized.\r\n" },
    vrfy => sub { return "250 <$_[0]>\r\n" }
  },
  nplex => {
    bannermatch => [
      [ qr/NPlex \d+\./s, 700 ],
      [ qr/NPlex/s, 500 ]
    ],
    banner => sub { return "220 $_[0] ESMTP Service (NPlex 5.0.047) ready\r\n" },
    dataend =>,
      sub {
            return sprintf "250 <%X%08X> Mail accepted\r\n", $boottime,
                   0x300000+int(rand(0x200000));
          },
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0]\r\n".
            "250-DSN\r\n".
            "250-8BITMIME\r\n".
            "250-PIPELINING\r\n".
            "250-HELP\r\n".
            "250-AUTH\r\n".
            "250 SIZE\r\n"
          },
    expn => sub { return "501 EXPN command unavailable\r\n" },
    helo => sub { return "250 $_[0]\r\n" },
    help =>
      sub {
            return
            "214-Valid SMTP commands:\r\n".
            "214-  HELO, EHLO, NOOP, RSET, QUIT, STARTTLS\r\n".
            "214-  MAIL, RCPT, DATA, VRFY, EXPN, HELP, ETRN\r\n".
            "214-For more info, use HELP <valid SMTP command>\r\n".
            "214 end of help\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 MAIL FROM:<$_[0]> OK\r\n" },
    needmail => "503 RCPT command outside of MAIL transaction\r\n",
    needrcpt => sub { return "554 DATA Transaction failed, no recipients given\r\n" },
    noop => sub { return "250 NOOP\r\n" },
    quit => sub { return "221 $_[0] QUIT\r\n" },
    rcpt => sub { return "250 RCPT TO:<$_[0]> OK\r\n" },
    rset => sub { return "250 RSET\r\n" },
    syntax =>
      sub {
            return "501 Syntax error in parameters or arguments ".
                   "to $_[0] command\r\n";
          },
    unknown =>
      sub {
            return "500 ".substr($_[0],0,4)." command unrecognized\r\n";
          },
    vrfy => sub { return "252 address verification is not available\r\n" }
  },
  pmdf => {
    bannermatch => [
      [ qr/PMDF/s, 500 ]
    ],
    helpmatch => [
      [ qr/Available commands:.*SAML/s, 15 ]
    ],
    banner => sub { return "220 $_[0] Server ESMTP (PMDF V5.2-33 #43876)\r\n" },
    dataend => sub { return "250 2.5.0 Ok.\r\n" },
    datastart => sub { return "354 Enter mail, end with a single \".\".\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0]\r\n".
            "250-8BITMIME\r\n".
            "250-PIPELINING\r\n".
            "250-DSN\r\n".
            "250-ENHANCEDSTATUSCODES\r\n".
            "250-EXPN\r\n".
            "250-HELP\r\n".
            "250-SAML\r\n".
            "250-SEND\r\n".
            "250-SOML\r\n".
            "250-TURN\r\n".
            "250-XADR\r\n".
            "250-XSTA\r\n".
            "250-ETRN\r\n".
            "250-XGEN\r\n".
            "250-RELAY\r\n".
            "250-AUTH CRAM-MD5 LOGIN PLAIN\r\n".
            "250-AUTH=CRAM-MD5 LOGIN PLAIN\r\n".
            "250 SIZE 0\r\n"
          },
    expn => sub { return "550 5.7.2 EXPN command has been disabled.\r\n" },
    helo => sub { return "250 $_[0] OK, [$_[3]].\r\n" },
    help =>
      sub {
            return
            "214-2.3.0 Available commands:\r\n".
            "214-2.3.0 \r\n".
            "214-2.3.0 DATA, EHLO, EXPN, HELO, HELP, MAIL FROM\r\n".
            "214-2.3.0 NOOP, QUIT, RCPT TO, RSET, SAML FROM\r\n".
            "214-2.3.0 SEND FROM, SOML FROM, TICK, TURN\r\n".
            "214-2.3.0 VERB, VRFY, XADR, XSTA, ETRN, XGEN\r\n".
            "214-2.3.0 SUBM, LHLO, AUTH\r\n".
            "214 2.3.0\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 2.5.0 Address Ok.\r\n" },
    needmail => "503 5.5.0 No MAIL FROM command has been issued.\r\n",
    needrcpt => sub { return "554 5.5.0 No recipients have been specified.\r\n" },
    noop => sub { return "250 2.0.0 OK.\r\n" },
    quit => sub { return "221 2.3.0 Bye received. Goodbye.\r\n" },
    rcpt => sub { return "250 2.1.5 $_[0] OK.\r\n" },
    rset => sub { return "250 2.5.0 Ok.\r\n" },
    syntax =>
      sub {
            return {
              MAIL => "501 5.5.4 No FROM: in MAIL/SAML/SEND/SOML.",
              RCPT => "501 5.5.2 RCPT not followed by TO: clause.\r\n",
              HELO => "251 OK.\r\n",
              NOOP => "250 2.0.0 OK",
              RSET => "501 5.5.4 RSET does not accept parameters\r\n",
              DATA => "501 5.5.4 DATA does not accept parameters\r\n"
            }->{$_[0]} || "501 5.5.4 Syntax error\r\n";
          },
    unknown => sub { return "500 5.5.1 Unknown command specified.\r\n" },
    vrfy => sub { return "252 2.5.0 Possible remote address not checked.\r\n" }
  },
  postfix => {
    bannermatch => [
      [ qr/ESMTP Postfix/s, 900 ],
      [ qr/Postfix/s, 800 ]
    ],
    helpmatch => [
      [ qr/^502/s, 15 ]
    ],
    banner => sub { return "220 $_[0] ESMTP Postfix\r\n" },
    dataend =>
      sub {
            # 5 random hex digits plus a hex inode number? inode numbers turn
            # out to be quasi-random in a non-uniform distibution
            return
              "250 Ok: queued as ".randchar("0123456789ABCDEF", 5)."5".
              randchar("012", 1).randchar("0123456789", 1).
              randchar("0123456789ABCDEF", 2)."\r\n";
          },
    datastart => sub { return "354 End data with <CR><LF>.<CR><LF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0]\r\n".
            "250-PIPELINING\r\n".
            "250-SIZE 10240000\r\n".
            "250-VRFY\r\n".
            "250-ETRN\r\n".
            "250-XVERP\r\n".
            "250 8BITMIME\r\n"
          },
    expn => sub { return "502 Error: command not implemented\r\n" },
    helo => sub { return "250 $_[0]\r\n" },
    help => sub { return "502 Error: command not implemented\r\n" },
    hostname => "mail",
    mail => sub { return "250 Ok\r\n" },
    needmail => "503 Error: need MAIL command\r\n",
    needrcpt => sub { return "554 Error: no valid recipients\r\n" },
    noop => sub { return "250 Ok\r\n" },
    quit => sub { return "221 Bye\r\n" },
    rcpt => sub { return "250 Ok\r\n" },
    rset => sub { return "250 Ok\r\n" },
    syntax =>
      sub {
            return {
              AUTH => "501 Syntax: AUTH mechanism\r\n",
              DATA => "501 Syntax: DATA\r\n",
              EHLO => "501 Syntax: EHLO hostname\r\n",
              HELO => "501 Syntax: HELO hostname\r\n",
              MAIL => "501 Syntax: MAIL FROM: <address>\r\n",
              NOOP => "501 Syntax: NOOP\r\n",
              RCPT => "501 Syntax: RCPT TO: <address>\r\n",
              RSET => "501 Syntax: RSET\r\n",
              VRFY => "501 Syntax: VRFY address\r\n"
            }->{$_[0]} || "501 Syntax error\r\n";
          },
    unknown => sub { return "502 Error: command not implemented\r\n" },
    vrfy => sub { return "252 $_[0]\r\n" }
  },
  postini => {
    bannermatch => [
      [ qr/Postini ESMTP/s, 900 ],
      [ qr/Postini/s, 800 ]
    ],
    helpmatch => [
      [ qr/Postini ESMTP/s, 900 ],
      [ qr/Postini/s, 900 ]
    ],
    nostdbanner => 1,
    banner => sub { return "220 Postini ESMTP r2_7_0c6 ready.  CA Business and Professions Code Section 17538.45 forbids use of this system for unsolicited electronic mail advertisements.\r\n" },
    dataend => sub { return "250 Thanks\r\n" },
    datastart => sub { return "354 Feed me\r\n" },
    ehlo =>
      sub {
            return
            "250-Postini says hello back\r\n".
            "250-8BITMIME\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "502 Not allowed - psmtp\r\n" },
    helo => sub { return "250 Postini says hello back\r\n" },
    help =>
      sub {
            return
            "214-Postini ESMTP Server\r\n".
            "214 See RFC 821 and 1651 at www.faqs.org\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 Ok\r\n" },
    needmail => "503 Missing MAIL FROM: - psmtp\r\n",
    needrcpt => sub { return "503 No recipients - psmtp\r\n\0" }, # heheheh.
    noop => sub { return "250 Ok Idling\r\n" },
    quit => sub { return "221 Catch you later\r\n" },
    rcpt => sub { return "250 Ok\r\n" },
    rset => sub { return "250 Ok\r\n" },
    syntax => sub { return "501 Bad parameter - psmtp\r\n" },
    unknown => sub { return "500 PSMTP Unimplemented command: $_[0]\r\n" },
    vrfy => sub { return "252 Try it and see\r\n" }
  },
  qmail => {
    helpmatch => [
      [ qr/214 qmail home page:/s, 1000 ],
      [ qr/qmail/s, 800 ]
    ],
    banner => sub { return "220 $_[0] ESMTP\r\n" },
    dataend =>
      sub {
            return "250 ok ".time()." qp ".(($$+int(rand(500)+10))&65535)."\r\n"
          },
    datastart => sub { return "354 go ahead\r\n" },
    ehlo =>
      sub {
            my $smtpgreeting=($_[2] =~ /^220 (.*) ESMTP$/) ? $1 : $_[0];
            return
            "250-$smtpgreeting\r\n".
            "250-PIPELINING\r\n".
            "250 8BITMIME\r\n"
          },
    expn => sub { return "502 unimplemented (#5.5.1)\r\n" },
    helo =>
      sub {
            my $smtpgreeting=($_[2] =~ /^220 (.*) ESMTP$/) ? $1 : $_[0];
            return "250 $smtpgreeting\r\n";
          },
    help => sub { return "214 qmail home page: http://pobox.com/~djb/qmail.html\r\n" },
    hostname => "mail",
    mail => sub { return "250 ok\r\n" },
    needmail => "503 MAIL first (#5.5.1)\r\n",
    needrcpt => sub { return "503 RCPT first (#5.5.1)\r\n" },
    noop => sub { return "250 ok\r\n" },
    quit =>
      sub {
            my $smtpgreeting=($_[1] =~ /^220 (.*) ESMTP$/) ? $1 : $_[0];
            return "221 $smtpgreeting\r\n";
          },
    rcpt => sub { return "250 ok\r\n" },
    rset => sub { return "250 flushed\r\n" },
    syntax => sub { return "250 ok\r\n" }, # qmail-smtpd never complains
    unknown => sub { return "502 unimplemented (#5.5.1)\r\n" },
    vrfy => sub { return "252 send some mail, i'll try my best\r\n" }
  },
  sendmail8 => {
    bannermatch => [
      [ qr/Sendmail 8\.8\.\d+/s, 1000 ],
      [ qr/\/s8\.8\.\d+/, 500 ]
    ],
    helpmatch => [
      [ qr/Sendmail 8\.8\.\d+/s, 1000 ],
      [ qr/^502/s, 15 ]
    ],
    banner =>
      sub { return "220 $_[0] ESMTP Sendmail 8.8.8/8.8.5; ".date822(0)."\r\n" },
    dataend =>
      sub {
            return "250 ".randchar("ABIJKLMNOPQSTUVWX", 1)."AA".
                   sprintf("%05d", int(rand(32768))).
                   " Message accepted for delivery\r\n"
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            # TODO: set $ident based on characteristics of last proxy in chain
            my $ident=0?'nobody@':'';
            return
            "250-$_[0] Hello $ident$_[1] [$_[3]], pleased to meet you\r\n".
            "250-EXPN\r\n".
            "250-VERB\r\n".
            "250-8BITMIME\r\n".
            "250-SIZE\r\n".
            "250-DSN\r\n".
            "250-ONEX\r\n".
            "250-ETRN\r\n".
            "250-XUSR\r\n".
            "250 HELP\r\n"
          },
    expn =>
      sub {
            my $u=$_[0];
            $u =~ s/\@.*//;
            return "250 $u <$_[0]>\r\n"
          },
    helo =>
      sub {
            # TODO: set $ident based on characteristics of last proxy in chain
            my $ident=0?'nobody@':'';
            return
            "250 $_[0] Hello $ident$_[1] [$_[3]], pleased to meet you\r\n";
          },
    help => sub { return "502 Sendmail 8.8.8 -- HELP not implemented\r\n" },
    hostname => "mail",
    mail => sub { return "250 <$_[0]>... Sender ok\r\n" },
    needmail => "503 Need MAIL before RCPT\r\n",
    needrcpt => sub { return "503 Need RCPT (recipient)\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 <$_[0]>... Recipient ok\r\n" },
    rset => sub { return "250 Reset state\r\n" },
    syntax =>
      sub {
            return "501 Syntax error in parameters scanning \"$_[1]\"\r\n"
          },
    unknown => sub { return "500 Command unrecognized: \"$_[0]\"\r\n" },
    vrfy => sub { return "250 <$_[0]>\r\n" }
  },
  sendmail9 => {
    bannermatch => [
      [ qr/Sendmail 8\.9\.\d+/s, 1000 ],
      [ qr/\/s8\.9\.\d+/, 500 ]
    ],
    helpmatch => [
      [ qr/This is sendmail version 8\.9/s, 1000 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] ESMTP Sendmail 8.9.3 (1.1.20.8/05Apr00-0155PM) ".
            date822(1)."\r\n"
          },
    dataend =>
      sub {
            return "250 ".randchar("EFGHIJKLMNOPQRSTUVW", 1)."AA".
                   sprintf("%010d", int(rand(600000))).
                   " Message accepted for delivery\r\n"
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            # TODO: set $ident based on characteristics of last proxy in chain
            my $ident=0?'nobody@':'';
            return
            "250-$_[0] Hello $ident$_[1] [$_[3]], pleased to meet you\r\n".
            "250-EXPN\r\n".
            "250-VERB\r\n".
            "250-8BITMIME\r\n".
            "250-SIZE\r\n".
            "250-DSN\r\n".
            "250-ONEX\r\n".
            "250-ETRN\r\n".
            "250-XUSR\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "250 <$_[0]>\r\n" },
    helo =>
      sub {
            # TODO: set $ident based on characteristics of last proxy in chain
            my $ident=0?'nobody@':'';
            return
            "250 $_[0] Hello $ident$_[1] [$_[3]], pleased to meet you\r\n";
          },
    help =>
      sub {
            return
            "214-This is Sendmail version 8.9.3\r\n".
            "214-Topics:\r\n".
            "214-	HELO	EHLO	MAIL	RCPT	DATA\r\n".
            "214-	RSET	NOOP	QUIT	HELP	VRFY\r\n".
            "214-	EXPN	VERB	ETRN	DSN\r\n".
            "214-For more info use \"HELP <topic>\".\r\n".
            "214-To report bugs in the implementation send email to\r\n".
            "214-	sendmail-bugs\@sendmail.org.\r\n".
            "214-For local information send email to Postmaster at your site.\r\n".
            "214 End of HELP info\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 <$_[0]>... Sender ok\r\n" },
    needmail => "503 Need MAIL before RCPT\r\n",
    needrcpt => sub { return "503 Need RCPT (recipient)\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 <$_[0]>... Recipient ok\r\n" },
    rset => sub { return "250 Reset state\r\n" },
    syntax =>
      sub {
            return "501 Syntax error in parameters scanning \"$_[1]\"\r\n"
          },
    unknown => sub { return "500 Command unrecognized: \"$_[0]\"\r\n" },
    vrfy => sub { return "250 <$_[0]>\r\n" }
  },
  sendmail12 => {
    bannermatch => [
      [ qr/Sendmail 8\.12\.\d+/s, 1000 ],
      [ qr/\/s8\.12\.\d+/, 500 ]
    ],
    helpmatch => [
      [ qr/This is sendmail version 8\.12/s, 1000 ]
    ],
    banner =>
      sub {
            return "220 $_[0] ESMTP Sendmail 8.12.3/8.12.2; ".date822(1)."\r\n"
          },
    dataend =>
      sub {
            my $alnum =
             "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
            # TODO: I think the first 8 characters in this reply aren't
            # really random, but some weird encoding of a timestamp.
            return
            "250 2.0.0 g".
            randchar("789", 1).
            randchar("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ", 2).
            randchar($alnum, 2).
            randchar("12AERSVlmqtx", 1).
            randchar("37BIQRSXYbcf", 1).
            sprintf("%06d", int(rand(32768))).
            " Message accepted for delivery\r\n"
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1] [$_[3]], pleased to meet you\r\n".
            "250-ENHANCEDSTATUSCODES\r\n".
            "250-PIPELINING\r\n".
            "250-EXPN\r\n".
            "250-VERB\r\n".
            "250-8BITMIME\r\n".
            "250-SIZE\r\n".
            "250-DSN\r\n".
            "250-ETRN\r\n".
            "250-DELIVERBY\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "250 2.1.5 <$_[0]>\r\n" },
    helo => sub { return "250 $_[0] Hello $_[1] pleased to meet you\r\n" },
    help =>
      sub {
            return
            "214-2.0.0 This is sendmail version 8.12.3\r\n".
            "214-2.0.0 Topics:\r\n".
            "214-2.0.0 	HELO	EHLO	MAIL	RCPT	DATA\r\n".
            "214-2.0.0 	RSET	NOOP	QUIT	HELP	VRFY\r\n".
            "214-2.0.0 	EXPN	VERB	ETRN	DSN\r\n".
            "214-2.0.0 For more info use \"HELP <topic>\".\r\n".
            "214-2.0.0 To report bugs in the implementation contact Sun Microsystems\r\n".
            "214-2.0.0 Technical Support.\r\n".
            "214-2.0.0 For local information send email to Postmaster at your site.\r\n".
            "214 2.0.0 End of HELP info\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 2.1.0 <$_[0]>... Sender OK\r\n" },
    needmail => "503 5.0.0 Need MAIL before RCPT\r\n",
    needrcpt => sub { return "503 5.0.0 Need RCPT (recipient)\r\n" },
    noop => sub { return "250 2.0.0 OK\r\n" },
    quit => sub { return "221 2.0.0 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 2.1.5 <$_[0]>... Recipient ok\r\n" },
    rset => sub { return "250 2.0.0 Reset state\r\n" },
    syntax =>
      sub {
            return "501 5.5.2 Syntax error in parameters scanning \"$_[1]\"\r\n"
          },
    unknown => sub { return "500 5.5.1 Command unrecognized: \"$_[0]\"\r\n" },
    vrfy => sub { return "250 2.1.5 <$_[0]>\r\n" }
  },
  smtpprox => {
    bannermatch => [
      [ qr/SMTP Proxy Server Ready/s, 900 ]
    ],
    helpmatch => [
      # We really don't want to have to use a helpmatch on this one because
      # the HELP reply is misformatted and will screw up the session. See for
      # example 65.243.68.152
      [ qr/entry follows, ends in \./s, 800 ]
    ],
    banner => sub { return "220 SMTP Proxy Server Ready\r\n" },
    dataend => sub { return "250 Ok.\r\n" }, # TODO: fix this wild guess.
    datastart => sub { return "354 Start mail input, end with \".<CR><LF>\"\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] ESTMP Server Ready\r\n".
            "250-SIZE 10485760\r\n".
            "250-STARTTLS\r\n".
            "250-TLS\r\n".
            "250 DSN\r\n"
          },
    expn => sub { return "500 Syntax error, Command unrecognized:  expn\r\n" },
    helo => sub { return "250 +OK SMTP server V1.92.2.8 Ready\r\n" },
    help =>
      sub {
            # Here we see why this thing is not an SMTP server (according to
            # the EHLO reply, it's an ESTMP server). The first line of the
            # HELP reply has the wrong numeric code, and is formatted as a
            # final line (digit digit digit space). The last line is not
            # formatted as a final line. And all the lines in between are
            # missing the continuation-line formatting (digit digit digit
            # hyphen). No, this is not SMTP. Not even close. Someone out
            # there is running it on port 25, but that must be a coincidence.
            return
            "250 +OK entry follows, ends in .\r\n".
            "data\r\n".
            "helo\r\n".
            "quit\r\n".
            "rcptto\r\n".
            "samlfrom\r\n".
            "noop\r\n".
            "auth\r\n".
            "somlfrom\r\n".
            "starttls\r\n".
            "sendfrom\r\n".
            "help\r\n".
            "tls\r\n".
            "rset\r\n".
            "mailfrom\r\n".
            "ehlo\r\n".
            ".\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 +OK Sender OK\r\n" },
    needmail => "503 Command sequence error: rcptto\r\n",
    needrcpt => sub { return "503 Command sequence error: data\r\n" },
    noop => sub { return "250 +OK NOOP\r\n" },
    quit => sub { return "221 Service closing transmission channel closing connection\r\n" },
    rcpt => sub { return "250 +OK Recipient OK\r\n" },
    rset => sub { return "250 +OK Reset\r\n" },
    syntax =>
      sub {
            return "500 Syntax error, Command unrecognized:  $_[0]\r\n"
          },
    unknown =>
      sub {
            return "500 Syntax error, Command unrecognized:  $_[0]\r\n"
          },
    vrfy => sub { return "500 Syntax error, Command unrecognized:  vrfy\r\n" }
  },
  smtprcv => {
    bannermatch => [
      [ qr/SMTPRCV SMTP Receiver/s, 1000 ]
    ],
    helpmatch => [
      [ qr/^502.*no help/s, 50 ],
      [ qr/^502/s, 15 ]
    ],
    banner =>
      sub { return "220 $_[0] SMTPRCV SMTP Receiver Version 0.45 Ready\r\n" },
    dataend => sub { return "250 Message received OK\r\n" },
    datastart => sub { return "354 Ready for data\r\n" },
    ehlo =>
      sub { return "500 Syntax Error, Command Unrecognized EHLO $_[0]\r\n" },
    expn => sub { return "550 EXPN Access Denied\r\n" },
    helo =>
      sub {
            return "250 OK $_[1] ($_[1] [$_[3]])\r\n"
          },
    help => sub { return "502 HELP no help available.\r\n" },
    hostname => "mail",
    mail => sub { return "250 OK <$_[0]>\r\n" },
    needmail => "503 MAIL command expected\r\n",
    needrcpt => sub { return "503 No valid recipients specified\r\n" },
    noop => sub { return "250 NOOP Performed\r\n" },
    quit => sub { return "221 $_[0] closing\r\n" },
    rcpt => sub { return "250 OK <$_[0]>\r\n" },
    rset => sub { return "250 OK Reset Completed\r\n" },
    syntax => sub { return "250 OK $_[1]\r\n" },
    unknown => sub {return "500 Syntax Error, Command Unrecognized $_[0]\r\n"},
    vrfy => sub { return "250 OK $_[0]\r\n" }
  },
  stalker => {
    bannermatch => [
      [ qr/Stalker Internet Mail Server/s, 900 ],
      [ qr/\bStalker\b/s, 700 ]
    ],
    helpmatch => [
      [ qr/Stalker/s, 700 ],
      [ qr/stalker/s, 700 ],
    ],
    nostdbanner => 1,
    banner =>
      sub {
            return
            "220-Stalker Internet Mail Server V.1.8b8 is ready.\r\n".
            "220 ESMTP is spoken here. You are welcome\r\n"
          },
    dataend =>
      sub {
            # TODO: This may be another unknown timestamp encoding
            return "250 S.".sprintf("%010d", int(rand(30000000)+10000000)).
                   " message accepted for delivery\r\n";
          },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] is pleased to meet you\r\n".
            "250-HELP\r\n".
            "250-PIPELINING\r\n".
            "250-ETRN\r\n".
            "250-AUTH=LOGIN\r\n".
            "250-AUTH LOGIN PLAIN CRAM-MD5 DIGEST-MD5\r\n".
            "250 EHLO\r\n"
          },
    expn => sub { return "500 Unknown command\r\n" },
    helo => sub { return "250 $_[0] is pleased to meet you\r\n" },
    help =>
      sub {
            return
            "214-Commands Supported are:\r\n".
            "214-HELO EHLO AUTH HELP QUIT MAIL NOOP RSET RCPT DATA ETRN VRFY\r\n".
            "214-Copyright (c) 1997-99, Stalker Software, Inc.\r\n".
            "214-To report problems, send mail to <support\@stalker.com>\r\n".
            "214- \r\n".
            "214 End Of Help\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 <$_[0]> sender accepted\r\n" },
    needmail => "500 Unknown command\r\n",
    needrcpt => sub { return "503 no RCPT address received\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0] closing connection\r\n" },
    rcpt => sub { return "250 <$_[0]> recipient accepted\r\n" },
    rset => sub { return "250 SMTP state reset\r\n" },
    syntax => sub { return "500 Unknown command\r\n" },
    unknown => sub { return "500 Unknown command\r\n" },
    vrfy =>
      sub {
            my $u=ucfirst(lc($_[0]));
            $u =~ s/\@.*//;
            return "250 Postmaster\r\n"
          }
  },
  turbosendmail => {
    bannermatch => [
      [ qr/IntraStore TurboSendmail/s, 800 ],
      [ qr/TurboSendmail/s, 700 ]
    ],
    helpmatch => [
      [ qr/^500/s, 15 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] (IntraStore TurboSendmail) ESMTP Service ready\r\n"
          },
    dataend => sub { return "250 Message received and queued\r\n" },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0]\r\n".
            "250-8BITMIME\r\n".
            "250-PIPELINING\r\n".
            "250-DSN\r\n".
            "250 SIZE 2147483647\r\n"
          },
    expn => sub { return "550 Access denied\r\n" },
    helo => sub { return "250 $_[0] G'day $_[1]!\r\n" },
    help => sub { return "500 Unrecognized command: HELP\r\n" },
    hostname => "mail",
    mail => sub { return "250 sender <$_[0]> OK\r\n" },
    needmail => "503 No originator specified\r\n",
    needrcpt => sub { return "503 No valid recipients specified\r\n" },
    noop => sub { return "250 Ok\r\n" },
    quit => sub { return "221 Until later [$_[2]]\r\n" },
    rcpt => sub { return "250 recipient <$_[0]> OK\r\n" },
    rset => sub { return "250 Ok\r\n" },
    syntax => sub { return "501 Syntax error in originator address\r\n" },
    unknown => sub { return "500 Unrecognized command: $_[0]\r\n" },
    vrfy => sub { return "252 Cannot VRFY user - access denied\r\n" }
  },
  viruswall => {
    bannermatch => [
      [ qr/InterScan VirusWall NT/s, 1000 ],
      [ qr/VirusWall/s, 800 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] InterScan VirusWall NT ESMTP 3.52 (build 1375)".
            " ready at ".date822(0)."\r\n"
          },
    dataend => sub { return "250 $_[0]: Message accepted for delivery\r\n" },
    datastart => sub { return "354 $_[0]: Send data now.  Terminate with \".\"\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] supports the following ESMTP extensions:\r\n".
            "250 SIZE 0\r\n"
          },
    expn => sub { return "502 $_[0]: Command not implemented.\r\n" },
    helo => sub { return "250 $_[0]: Hello $_[1]\r\n" },
    help =>
      sub {
            return
            "214-Commands:\r\n".
            "214-    HELO    MAIL    RCPT    DATA    RSET    VRFY    EXPN\r\n".
            "214-    SAML    SOML    NOOP    EHLO    QUIT\r\n".
            "214 $_[0]: End of HELP info\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 <$_[0]>: Sender OK\r\n" },
    needmail => "503 Need MAIL before RCPT\r\n",
    needrcpt => sub { return "503 $_[0]: Need RCPT recipient\r\n" },
    noop => sub { return "200 $_[0]: Ok\r\n" },
    quit => sub { return "221 $_[0] closing connection. Goodbye!\r\n" },
    rcpt => sub { return "250 $_[0]: Recipient Ok\r\n" },
    rset => sub { return "250 $_[0]: Reset State\r\n" },
    syntax => sub { return "501 $_[0]: Syntax Error\r\n" },
    unknown => sub { return "500 $_[0]: unknown command.\r\n" },
    vrfy => sub { return "502 $_[0]: Command not implemented.\r\n" }
  },
  webshield => {
    bannermatch => [
      [ qr/WebShield/s, 800 ]
    ],
    helpmatch => [
      [ qr/^500/s, 15 ]
    ],
    banner => sub { return "220 $_[0] WebShielde500/SMTP Ready.\r\n" },
    dataend => sub { return "250 Mail accepted\r\n" },
    datastart => sub { return "354 Enter mail, end with \".\" on a line by itself\r\n" },
    ehlo => sub { return "250 Requested mail action okay, completed.\r\n" },
    expn => sub { return "502 Command not implemented, no local users.\r\n" },
    helo => sub { return "250 Requested mail action okay, completed.\r\n" },
    help => sub { return "500 Command unrecognized\r\n" },
    hostname => "webshield",
    mail => sub { return "250 <$_[0]> Sender OK\r\n" },
    needmail => "503 need MAIL From: first.\r\n",
    needrcpt => sub { return "503 need RCPT first.\r\n" },
    noop => sub { return "250 Requested mail action okay, completed.\r\n" },
    quit => sub { return "221 Closing connection\r\n" },
    rcpt => sub { return "250 Requested mail action okay, completed.\r\n" },
    rset => sub { return "250 Requested mail action okay, completed.\r\n" },
    syntax => sub { return "501 Syntax error\r\n" },
    unknown => sub { return "500 Command unrecognized\r\n" },
    vrfy =>
      sub {
            return "252 Cannot VRFY user (no local users), but will take".
                   " messages for this user and attempt to deliver.\r\n"
          }
  },
  yahoo => {
    bannermatch => [
      [ qr/YSmtp.*yahoo/s, 800 ]
    ],
    helpmatch => [
      [ qr/Yahoo\!\s*MTA/s, 1000 ]
    ],
    nostdbanner => 1,
    banner => sub { return "220 YSmtp $_[0] ESMTP service ready\r\n" },
    dataend => sub { return "250 ok dirdel\r\n" },
    datastart => sub { return "354 go ahead\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0]\r\n".
            "250-8BITMIME\r\n".
            "250-SIZE 10485760\r\n".
            "250 PIPELINING\r\n"
          },
    expn => sub { return "502 Command Unimplemented\r\n" },
    helo => sub { return "250 $_[0]\r\n" },
    help => sub { return "250 OK.  Yahoo! MTA\r\n" },
    hostname => "mta626.mail.yahoo.com",
    mail => sub { return "250 sender <$_[0]> ok\r\n" },
    needmail => "503 A single MAIL command is required\r\n",
    needrcpt => sub { return "504 At least one RCPT command is required\r\n" },
    noop => sub { return "250 OK\r\n" },
    quit => sub { return "221 $_[0]\r\n" },
    rcpt => sub { return "250 recipient <$_[0]> ok\r\n" },
    rset => sub { return "250 reset ok\r\n" },
    syntax => sub { return "501 Syntax error in parameters or arguments\r\n" },
    unknown => sub { return "502 Command Unimplemented\r\n" },
    vrfy => sub { return "502 Command Unimplemented\r\n" }
  },
  zmailer => {
    bannermatch => [
      [ qr/ZMailer Server \d+\.\d+/s, 1000 ],
      [ qr/ZMailer Server/s, 900 ]
    ],
    helpmatch => [
      [ qr/Matti Aarnio/s, 900 ]
    ],
    banner =>
      sub {
            return
            "220 $_[0] ZMailer Server 2.99.56-pre3 #24 ESMTP+IDENT ready at ".
            date822(0)."\r\n"
          },
    dataend => sub { return "250 Ok.\r\n" }, # TODO: fix this wild guess.
    datastart => sub { return "354 Start mail input; end with <CRLF>.<CRLF>\r\n" },
    ehlo =>
      sub {
            return
            "250-$_[0] Hello $_[1]\r\n".
            "250-SIZE 10000000\r\n".
            "250-8BITMIME\r\n".
            "250-PIPELINING\r\n".
            "250-CHUNKING\r\n".
            "250-ENHANCEDSTATUSCODES\r\n".
            "250-DSN\r\n".
            "250-X-RCPTLIMIT 10000\r\n".
            "250-STARTTLS\r\n".
            "250-ETRN\r\n".
            "250 HELP\r\n"
          },
    expn => sub { return "502 5.4.0 Command not implemented\r\n" },
    helo => sub { return "250 $_[0] Hello $_[1]\r\n" },
    help =>
      sub {
            return
            "214-Copyright 1990 Rayan S. Zachariassen\r\n".
            "214-Copyright 1991-2000 Matti Aarnio\r\n".
            "214-\r\n".
            "214-The following commands are recognized:\r\n".
            "214-    EHLO, HELO, MAIL, RCPT, DATA, BDAT, RSET, VRFY, EXPN\r\n".
            "214-    NOOP, QUIT, TURNME, ETRN, AUTH, VERB, ONEX, SEND, SOML\r\n".
            "214-    TURN, TICK, EMAL, ESND, ESOM, ESAM, EVFY, IDENT, DEBUG\r\n".
            "214-\r\n".
            "214-The normal sequence is: EHLO/HELO (MAIL RCPT+ DATA)+ QUIT.\r\n".
            "214-\r\n".
            "214-This mailer will always accept 8-bit and binary message data\r\n".
            "214-though you are better to use MIME format!\r\n".
            "214-\r\n".
            "214-For local information contact: postmaster\@$_[0]\r\n".
            "214 SMTP server comments and bug reports to: <zmhacks\@nic.funet.fi>\r\n"
          },
    hostname => "mail",
    mail => sub { return "250 2.1.0 Sender syntax Ok\r\n" },
    needmail => "503 5.5.1 Waiting for MAIL command\r\n",
    needrcpt => sub { return "503 5.5.2 Waiting for RCPT command\r\n" },
    noop => sub { return "250 2.0.0 Ok\r\n" },
    quit => sub { return "221 2.0.0 $_[0] Out\r\n" },
    rcpt =>
      sub { return "250 2.1.5 Recipient address syntax Ok; rcpt=<$_[0]>\r\n" },
    rset =>
      sub {
            return "250 2.0.0 Reset processed, now waiting for MAIL command\r\n"
          },
    syntax => sub { return "501 5.5.2 where is From: in that?\r\n" },
    unknown => sub { return "550 5.5.2 Unknown command '$_[0]'\r\n" },
    vrfy =>
      sub {
            return "252 2.5.2 Cannot VRFY user, but will accept message and".
                   " attempt delivery\r\n"
          }
  }
);
}

# servread lines until one is found that starts with 3 digits and a space,
# the return them all as one string, or undef if the terminating line wasn't
# found. Line length and overall reply length are both limited.
sub read_smtp_reply
{
  my $ret='';
  while(1) {
    my $line=servread(1200, 1);
    if(!defined($line)) {
      return undef;
    }
    $ret.=$line;
    last if $line =~ /^\d\d\d / || !length($line);
    if(length($ret)>5000) {
      $!=0;
      return undef;
    }
  }
  return $ret;
}

# Take an arbitrary string and mangle it until it meets the RFC2821
# definition of a Domain (suitable for use in the Recieved header).
sub domain
{
  my $domain=$_[0];
  # Domain = (sub-domain 1*("." sub-domain)) / address-literal
  if($domain =~ /^\[(\d+)\.(\d+)\.(\d+)\.(\d+)\]\z/ &&
     $1<256 && $2<256 && $3<256 && $4<256) {
    # It's an IPv4 address-literal
    return $domain;
  }
  if($domain =~ /^\[IPv6(?::[0-9a-fA-F]{1,4}){8}\]\z/) {
    # It's an IPv6 address-literal in IPv6-full format
    return $domain;
  }
  IPV6_COMP: {
    last IPV6_COMP if $domain !~ /^\[IPv6:(.*)::(.*)\]\z/;
    my ($before, $after) = ($1, $2);
    last IPV6_COMP if $before =~ /::/ || $before =~ /^:/ || $before =~ /:$/ ||
                      $after =~ /::/  || $after =~ /^:/  || $after =~ /:$/;
    my @before=split /:/, $before;
    my @after=split /:/, $after;
    last IPV6_COMP if @before+@after > 6;
    for my $ipv6_hex (@before, @after) {
      last IPV6_COMP if $ipv6_hex !~ /^[0-9a-fA-F]{4}\z/;
    }
    # It's an IPv6 address-literal in IPv6-comp format
    return $domain
  }
  if($domain =~
     /^\[IPv6(?::[0-9a-fA-F]{1,4}){6}:(\d+)\.(\d+)\.(\d+)\.(\d+)\]\z/ &&
     $1<256 && $2<256 && $3<256 && $4<256) {
    # It's an IPv6 address-literal in IPv6v4-full format
    return $domain;
  }
  IPV6V4_COMP: {
    last IPV6V4_COMP if $domain !~
                        /^\[IPv6:(.*)::(|.+:)(\d+)\.(\d+)\.(\d+)\.(\d+)\]\z/ ||
                        $3>255 || $4>255 || $5>255 || $6>255;
    my ($before, $after) = ($1, $2);
    $after =~ s/:$//;
    last IPV6V4_COMP if $before =~ /::/ || $before =~ /^:/ || $before =~ /:$/ ||
                        $after =~ /::/  || $after =~ /^:/  || $after =~ /:$/;
    my @before=split /:/, $before;
    my @after=split /:/, $after;
    last IPV6V4_COMP if @before+@after > 4;
    for my $ipv6_hex (@before, @after) {
      last IPV6V4_COMP if $ipv6_hex !~ /^[0-9a-fA-F]{4}\z/;
    }
    # It's an IPv6 address-literal in IPv6v4-comp format
    return $domain
  }

  # Not an address-literal, hope it's a (sub-domain 1*("." sub-domain))
  my @sub_domains=split /\./, $domain, -1;
  # sub-domain = Let-dig [Ldh-str]
  my $good=1;
  for my $sub_domain (@sub_domains) {
    if($sub_domain !~ /^[A-Za-z0-9](?:[-A-Za-z0-9]*[A-Za-z0-9])\z/) {
      $good=0;
      last;
    }
  }
  return $domain if $good;

  # It's invalid. We must mangle it. Cover up all the bad spots with
  # underscores. Since underscore itself is an illegal character, the result
  # will still not be a valid domain, but it'll be close enough. Underscores
  # in domain names are a common mistake, so MUAs need to be prepared to
  # handle them. The underscores can therefore be considered a gentle hint
  # that there was a more complex forgery attempted. Look in the main log.
  for (@sub_domains) {
    s/^(-+)/'_' x length($1)/e;
    s/(-+)\z/'_' x length($1)/e;
  }
  $domain=join '.', @sub_domains;
  $domain =~ s/^(\.+)/'_' x length($1)/e;
  $domain =~ s/(\.+)\z/'_' x length($1)/e;
  $domain =~ s/(\.+)\./('_' x length($1)).'.'/ge;
  $domain =~ s/[^-A-Za-z0-9\.]/_/g;
  return $domain;
}

# Take an arbitrary string and apply quoting if necessary to meet the RFC2822
# definition of an addr-spec (suitable for use in the Return-Path header, and
# some other places). If the given address has no domain, just return it as
# an RFC2822 local-part.
sub addrspec
{
  my $addr_spec=$_[0];

  # addr-spec = local-part "@" domain
  my ($local_part, $domain);
  if($addr_spec =~ /(.*)\@(.*)/s) {
    ($local_part, $domain)=($1, $2);
  } else {
    ($local_part, $domain)=($addr_spec, undef);
  }

  # local-part      =       dot-atom / quoted-string / obs-local-part
  # dot-atom        =       [CFWS] dot-atom-text [CFWS]
  # dot-atom-text   =       1*atext *("." 1*atext)
  if($local_part =~ /[^^a-zA-Z0-9!#\$\%&'*+-\/=?_`{|}~.]/ ||
     $local_part =~ /^\./ ||
     $local_part =~ /\.$/ ||
     $local_part =~ /\.\./) {
    # Not a dot-atom, hope it's a quoted-string.
    # qcontent        =       qtext / quoted-pair
    # quoted-string   =       [CFWS]
    #                         DQUOTE *([FWS] qcontent) [FWS] DQUOTE
    #                         [CFWS]
    # (Approximating CFWS and FWS both as \s)
    if($local_part !~ /^\s*"(?:\s*(?:[^\s"\\]|\\[^\r\n\0\200-\377]))*"\s*$/) {
      # Not a quoted-string either, we have an invalid (or obsolete)
      # local-part. Mangle it to something reasonable.
      $local_part =~ s/^\s*//;
      $local_part =~ s/\s*$//;
      if($local_part !~ s/^\s*"(.*)"\s*$/$1/) {
        $local_part =~ s/\s//g;
      }
      $local_part =~ s/([\s"\200-\377\\])/\\$1/g;
      $local_part = qq/"$local_part"/;
    }
  }

  return $local_part if !defined($domain);

  # domain          =       dot-atom / domain-literal / obs-domain
  if($domain =~ /[^^a-zA-Z0-9!#\$\%&'*+-\/=?_`{|}~.]/ ||
     $domain =~ /^\./ ||
     $domain =~ /\.$/ ||
     $domain =~ /\.\./) {
    # Not a dot-atom, hope it's a domain-literal.
    # domain-literal  =       [CFWS] "[" *([FWS] dcontent) [FWS] "]" [CFWS]
    # dcontent        =       dtext / quoted-pair
    # (Approximating CFWS and FWS both as \s)
    if($domain !~ /^\s*\[(?:\s*[^\s\[\]\\]|\\[^\r\n\0\200-\377])*\s*\]\s*$/) {
      # Not a domain-literal either, we have an invalid (or obsolete)
      # domain. Mangle it to something reasonable.
      $domain=domain($domain);
    }
  }
  return "$local_part\@$domain";
}

# Make a set of headers for use in mbox or maildir delivery
sub localheader
{
  my ($helo, $esmtp, $msgnum, $rpath, $rcpts, $recvtime)=@_;
  my $ret="Return-Path: <".addrspec($rpath).">\n";
  $ret.="Delivered-To: <".addrspec($_).">\n" for @$rcpts;
  $helo="MISSING-HELO" if !defined $helo; # TODO: use alternate Received
                                          # line format for this case
  # TODO: include reverse DNS of the client
  $ret.="Received: from ".domain($helo).
        " ([$clientaddr]) by $proxypot_hostname\n";
  my $e=$esmtp?'E':'';
  # "via" shows the only initial protocol, not the whole chain
  my $via = uc($clientproto);
  $via .= $chain[0]->{socksversion} if $via eq 'SOCKS';
  $ret.="          with ${e}SMTP via $via id \"$id,$msgnum\"";
  $ret.="\n          (attempted proxy to $_->{destip})" for @chain;
  $ret.=";\n          ".localdate822($recvtime)."\n";
  return $ret;
}

sub smtp_data
{
  my ($servertype, $hostname, $helo, $esmtp, $msgnum, $rpath, $rcpts)=@_;
  $rpath="MISSING-MAIL-FROM" if !defined $rpath; # This should never happen
  printlog "$id: msg $msgnum: DATA beginning";
  my $maildirfile=undef;
  if(defined($maildir)) {
    my $recvtime=time();
    $maildirfile="$recvtime.${$}_$msgnum.$proxypot_hostname";
    for my $attempt (1..10) {
      last if !stat("tmp/$maildirfile") && $! == ENOENT;
      if($attempt==10) {
        $maildirfile=undef;
        last;
      }
      sleep(2);
    }
    if(!$maildirfile) {
      printlog "$id: msg $msgnum: not writing to maildir ".
               "(couldn't get a file in $maildir/tmp)";
    } else {
      # TODO: The Maildir specification requires a 24-hour death timer to
      # start here, for safe cleanup (any tmp file older than 1 day can be
      # deleted).
      if(!open(MAILDIRFILE, ">tmp/$maildirfile")) {
        printlog "$id: failed writing to $maildir/tmp/$maildirfile. ".
                 "maildir output disabled. Error was $!";
        $maildir=undef;
        $maildirfile=undef;
      }
      if(!print MAILDIRFILE
                localheader($helo, $esmtp, $msgnum, $rpath, $rcpts, $recvtime)){
        printlog "$id: failed writing to $maildir/tmp/$maildirfile. ".
                 "maildir output disabled. Error was $!";
        close(MAILDIRFILE);
        unlink("tmp/$maildirfile");
        $maildir=undef;
        $maildirfile=undef;
      }
    }
  }
  cliprint $servertype->{datastart}->($hostname);
  my $datastarttime=time();
  my $datasize=0;
  my $bodychunk='';
  my $inheaders=1;
  my $msgid=undef;
  my $bodyline;
  my $inlongline=0;
  my $bodyfull='';
  # TODO: cliread can exit() if the client is idle. If it does, make sure
  # $maildirfile gets unlinked.
  while(defined($bodyline=cliread(1200, 1, 1)) && length($bodyline)) {
    if(!$inlongline) {
      last if $bodyline =~ /^\.\r?\n/;
      $bodyline =~ s/^\.//;
    }
    # TODO: if $bodyfull gets too big, use a temp file
    $bodyfull.=$bodyline if defined($mbox);
    if($maildirfile) {
      my $stripline=$bodyline;
      $stripline =~ s/\r\n/\n/g;
      if(!print MAILDIRFILE $stripline) {
        printlog "$id: failed writing to $maildir/tmp/$maildirfile. ".
                 "maildir output disabled. Error was $!";
        close(MAILDIRFILE);
        unlink("tmp/$maildirfile");
        $maildir=undef;
        $maildirfile=undef;
      }
    }
    if($inheaders) {
      if($bodyline =~ /^\r?\n/) {
        $inheaders=0;
      } elsif($bodyline =~ /^\s*Message-Id\s*:\s*<?(.*?)>?\r?\n/) {
        $msgid=$1;
      }
    }
    if(!$inlongline) {
      if($bodyline =~ /\r?\n\z/) {
        $bodychunk.=$bodyline;
        if(length($bodychunk)>500) {
          printlog "$id: msg $msgnum: data: ".cleanstr($bodychunk);
          $datasize+=length($bodychunk);
          $bodychunk='';
        }
      } else {
        $inlongline=1;
        if(length($bodychunk)) {
          printlog "$id: msg $msgnum: data: ".cleanstr($bodychunk);
          $datasize+=length($bodychunk);
          $bodychunk='';
        }
      }
    }
    if($inlongline) {
      if($bodyline =~ /\r?\n\z/) {
        $bodychunk.=$bodyline;
        printlog "$id: msg $msgnum: data: ".cleanstr($bodychunk);
        $datasize+=length($bodychunk);
        $bodychunk='';
        $inlongline=0;
      } else {
        # This looks strange in isolation, but it's written this way
        # for consistency with the other branches.
        $bodychunk=$bodyline;
        printlog "$id: msg $msgnum: data: ".cleanstr($bodychunk);
        $datasize+=length($bodychunk);
        $bodychunk='';
      }
    }
  }
  my $saveerr=$!;
  if(length($bodychunk)) {
    printlog "$id: msg $msgnum: data: ".cleanstr($bodychunk);
    $datasize+=length($bodychunk);
    $bodychunk='';
  }
  $!=$saveerr;
  if(!defined($bodyline)) {
    printlog "$id: msg $msgnum: error reading message body: $!";
    unlink("tmp/$maildirfile") if $maildirfile;
    exit(0);
  } elsif(!length($bodyline)) {
    printlog "$id: msg $msgnum: premature EOF reading message body";
    unlink("tmp/$maildirfile") if $maildirfile;
    exit(0);
  }
  if($maildirfile) {
    # The Maildir specification requires an fsync here. Seems like that would
    # be going overboard.
    if(!close(MAILDIRFILE)) {
      printlog "$id: failed writing to $maildir/tmp/$maildirfile. ".
               "maildir output disabled. Error was $!";
      $maildir=undef;
    } elsif(!link("tmp/$maildirfile", "new/$maildirfile")) {
      printlog "$id: msg $msgnum: couldn't link to ".
               "$maildir/new/$maildirfile: $!";
    }
    unlink("tmp/$maildirfile");
  }
  printlog "$id: msg $msgnum: DATA completed";
  cliprint $servertype->{dataend}->($hostname, $datasize,
                                    $datastarttime, $helo, $msgid);
  if(defined($mbox)) {
    if(!open(MBOX, ">>$mbox")) {
      printlog "$id: open($mbox): $!";
      return;
    }
    if(!flock(MBOX, LOCK_EX)) {
      printlog "$id: flock($mbox, LOCK_EX): $!";
      close(MBOX);
      return;
    }
    my $recvtime=time();
    print MBOX "From $rpath ", scalar(localtime($recvtime)), "\n",
               localheader($helo, $esmtp, $msgnum, $rpath, $rcpts, $recvtime);
    $bodyfull =~ s/\r\n/\n/g;
    $bodyfull =~ s/^(>*From )/>$1/mg;
    print MBOX $bodyfull, "\n";
    if(!close(MBOX)) {
      printlog "$id: failed writing to $mbox. mbox output disabled. ".
               "Error was $!";
      $mbox=undef;
      # TODO: truncate the mbox back to its previous size
    }
  }
}

sub fake_smtp_session
{
  my ($servertype, $banner, $help, $hostname)=@_;
  if(!defined($hostname)) {
    $hostname=$chain[-1]{desthost};
    if($hostname =~ /^\d+\.\d+\.\d+\.\d+$/) {
      $hostname=gethostbyaddr(inet_aton($chain[-1]{desthost}), AF_INET);
    }
  }
  if(!defined($hostname)) {
    $hostname=$servertype->{hostname};
  }
  if(!defined($banner)) {
    $banner=$servertype->{banner}->($hostname);
  }
  if(!defined($help)) {
    $help=$servertype->{help}->($hostname);
  }

  # The client thinks that the SMTP server was connected to by the last proxy
  # in the chain, so we need to use that proxy's IP address in any replies
  # that require one.
  my $clientipstr;
  if(@chain>1) {
    $clientipstr=$chain[-2]{destip};
  } else {
    my $name=$clientsock->sockname();
    my ($lport, $lip) = unpack_sockaddr_in($name);
    $clientipstr=inet_ntoa($lip);
  }

  cliprint $banner;
  my $cmd;
  my $msgnum=0;
  my ($seenmailfrom,$seenrcptto)=(undef,[]);
  my $helo=gethostbyaddr(inet_aton($clientipstr), AF_INET);
  my $esmtp=0;
  while(defined($cmd=cliread(1200, 1)) && length($cmd)) {
    $cmd =~ s/\r?\n\z/\r\n/;
    if($cmd =~ /^\s*HELO\s+([ -~]*?)\r\n/i) {
      $helo=$1;
      printlog "$id: client HELO name: ".cleanstr($helo);
      cliprint $servertype->{helo}->($hostname, $helo, $banner, $clientipstr);
    } elsif($cmd =~ /^\s*EHLO\s+([ -~]*?)\r\n/i) {
      $helo=$1;
      $esmtp=1;
      printlog "$id: client EHLO name: ".cleanstr($helo);
      cliprint $servertype->{ehlo}->($hostname, $helo, $banner, $clientipstr);
    } elsif($cmd =~ /^\s*MAIL FROM\s*:\s*<?([ -~]*?)\s*>?\s*(?:[-a-zA-Z0-9]+(?:=[^=\s]+)?\s*)*\r\n/i) {
      ++$msgnum;
      printlog "$id: starting new message $msgnum with MAIL FROM:<".
               cleanstr($1).">";
      ($seenmailfrom,$seenrcptto)=($1,[]);
      cliprint $servertype->{mail}->($1);
    } elsif($cmd =~ /^\s*RCPT TO\s*:\s*<?([ -~]*?)\s*>?\s*\r\n/i) {
      if(!defined($seenmailfrom)) {
        cliprint $servertype->{needmail};
      } else {
        printlog "$id: msg $msgnum: recipient RCPT TO:<".cleanstr($1).">";
        push(@$seenrcptto, $1);
        cliprint $servertype->{rcpt}->($1);
      }
    } elsif($cmd =~ /^\s*DATA\s*\r\n/i) {
      if(!defined($seenmailfrom)) {
        cliprint $servertype->{needmail};
      } elsif(!@$seenrcptto) {
        cliprint $servertype->{needrcpt}->($hostname);
      } else {
        smtp_data($servertype, $hostname, $helo, $esmtp, $msgnum,
                  $seenmailfrom, $seenrcptto);
        ($seenmailfrom,$seenrcptto)=(undef,[]);
      }
    } elsif($cmd =~ /^\s*RSET\s*\r\n/i) {
      if(defined($seenmailfrom)) {
        printlog "$id: msg $msgnum: cancelled by RSET";
      } else {
        printlog "$id: useless RSET";
      }
      ($seenmailfrom,$seenrcptto)=(undef,[]);
      cliprint $servertype->{rset}->($hostname);
    } elsif($cmd =~ /^\s*NOOP\s*\r\n/i) {
      printlog "$id: NOOP";
      cliprint $servertype->{noop}->($hostname);
    } elsif($cmd =~ /^\s*VRFY\s+([ -~]*?)\s*\r\n/i) {
      printlog "$id: tried to VRFY ".cleanstr($1);
      cliprint $servertype->{vrfy}->($1);
    } elsif($cmd =~ /^\s*EXPN\s+(.*?)\s*\r\n/i) {
      printlog "$id: tried to EXPN ".cleanstr($1);
      cliprint $servertype->{expn}->($1);
    } elsif($cmd =~ /^\s*HELP(?:\s+[ -~]*)?\r\n/i) {
      printlog "$id: HELP";
      cliprint $servertype->{help}->($hostname);
    } elsif($cmd =~ /^\s*QUIT\s*\r\n/i) {
      if(defined($seenmailfrom)) {
        printlog "$id: msg $msgnum: cancelled by QUIT";
      } else {
        printlog "$id: QUIT request from client";
      }
      cliprint $servertype->{quit}->($hostname, $banner, $clientipstr);
      last;
    } elsif($cmd =~ /^\s*(DATA|EHLO|EXPN|HELO|HELP|MAIL|NOOP|QUIT|RCPT|RSET|VRFY)\b\s*(.*)\r\n/) {
      printlog "$id: strange command from client: ".cleanstr($cmd);
      cliprint $servertype->{syntax}->($1, $2);
    } else {
      printlog "$id: strange command from client: ".cleanstr($cmd);
      $cmd =~ s/\s.*//;
      cliprint $servertype->{unknown}->($cmd);
    }
  }
  printlog "$id: ending session";
}

sub identify_smtp_server
{
  my $banner=read_smtp_reply();
  if(!defined($banner)) {
    printlog "$id: error reading SMTP banner from server: $!";
    exit(0);
  }
  if($banner !~ /^220/) {
    # TODO: If the banner indicates that the proxypot is blacklisted, fall
    # back to smtp1. Otherwise assume this a tester being clever (but not
    # clever enough).
    printlog "$id: unfriendly SMTP banner: ".cleanstr($banner);
    cliprint $banner;
    exit(0);
  }
  printlog "$id: SMTP banner: ".cleanstr($banner);
  my $servertype=undef;
  my $help=undef;
  my $hostname=undef;
  my @matches=();
  # To identify the server type, we first match the banner against all the
  # known bannermatch specifications. Then if we still don't have a good
  # answer, we get a HELP response and search again using both banner and
  # help text.
  OUTER: for my $pass(1, 2) {
    for my $checktype (keys %smtp_servertypes) {
      my $match=1;
      my $bannermatchset=$smtp_servertypes{$checktype}{bannermatch};
      if(defined($bannermatchset)) {
        for my $bannermatch (@$bannermatchset) {
          my ($re,$points)=@$bannermatch;
          if($banner =~ /$re/) {
            $match *= $points;
            last;
          }
        }
      }
      if($match>=850) {
        printlog "$id: looks like a $checktype server";
        $servertype=$smtp_servertypes{$checktype};
        last OUTER;
      }
      next if !defined($help);
      my $helpmatchset=$smtp_servertypes{$checktype}{helpmatch};
      if(defined($helpmatchset)) {
        for my $helpmatch (@$helpmatchset) {
          my ($re,$points)=@$helpmatch;
          if($help =~ /$re/) {
            $match *= $points;
            last;
          }
        }
      }
      if($match>=850) {
        printlog "$id: looks like a $checktype server";
        $servertype=$smtp_servertypes{$checktype};
        last OUTER;
      }
      # Not a definite match, save its score for later
      push(@matches, [$checktype, $match]) if $match>1;
    }
    if($pass==1) {
      # Prepare for pass 2
      printlog "$id: sending HELP probe";
      servprint "HELP\r\n";
      $help=read_smtp_reply();
      if(!defined($help)) {
        printlog "$id: error reading HELP reply from server: $!";
        exit(0);
      }
    }
  }
  if(!defined($servertype) && @matches) {
    my $besttype=(sort { $b->[1] <=> $a->[1] } @matches)[0]->[0];
    printlog "$id: looks like a $besttype server";
    $servertype=$smtp_servertypes{$besttype};
  }
  if(!$servertype) {
    printlog "$id: can't determine server type, using $smtp_servertype_default";
    $servertype=$smtp_servertypes{$smtp_servertype_default};
  } else {
    if(!$servertype->{nostdbanner} &&
       $banner =~ /^220[- ]([-._A-Za-z0-9]+)/ && length($1)<64) {
      $hostname=$1;
      printlog "$id: using hostname $hostname";
    }
  }
  # TODO: Cache these server information variables in a local database for
  # reuse the next time a connection is requested to the same host.
  return ($servertype, $banner, $help, $hostname);
}

sub handle_smtp1
{
  printlog "$id: starting fake SMTP session";
  fake_smtp_session($smtp_servertypes{$smtp_servertype_default});
}

# TODO: maintain a database of server information, and downgrade connections
# to known servers to smtp1 (requires lookup in proxy_request and
# passthrough_proxy_request to avoid making unnecessary connections).
sub handle_smtp2
{
  printlog "$id: starting mostly-fake SMTP session";
  my ($servertype, $banner, $help, $hostname)=identify_smtp_server();
  $serversock->close();
  undef $serversock;
  fake_smtp_session($servertype, $banner, $help, $hostname);
}

# TODO: maintain a history of each [client,server] pair, with total
# successful and failed RCPTs, and after a while downgrade smtp3 to smtp2,
# sending random fake RCPT replies with the historical success/fail ratio.
# The servertype table would need a template for failed-rcpt reply string.
sub handle_smtp3
{
  printlog "$id: starting SMTP session";
  my ($servertype, $banner, $help, $hostname)=identify_smtp_server();
  if(!defined($hostname)) {
    $hostname=$chain[-1]{desthost};
    if($hostname =~ /^\d+\.\d+\.\d+\.\d+$/) {
      $hostname=gethostbyaddr(inet_aton($chain[-1]{desthost}), AF_INET);
    }
  }
  if(!defined($hostname)) {
    $hostname=$servertype->{hostname};
  }

  # The client thinks that the SMTP server was connected to by the last proxy
  # in the chain, so we need to use that proxy's IP address in any replies
  # that require one.
  my $clientipstr;
  if(@chain>1) {
    $clientipstr=$chain[-2]{destip};
  } else {
    my $name=$clientsock->sockname();
    my ($lport, $lip) = unpack_sockaddr_in($name);
    $clientipstr=inet_ntoa($lip);
  }

  # The SMTP server was actually connected to by the last *real* proxy in the
  # chain, so we will look for that one's IP address in the server's replies,
  # and change it to the IP address we just chose.
  my $clientrealipstr;
  my @realchain=grep { $_->{type} eq 'real' } @chain[0..$#chain-1];
  if(@realchain>1) {
    $clientrealipstr=$realchain[-1]{destip};
  } else {
    my $name=$clientsock->sockname();
    my ($lport, $lip) = unpack_sockaddr_in($name);
    $clientrealipstr=inet_ntoa($lip);
  }

  cliprint $banner;
  my $cmd;
  my $msgnum=0;
  my ($seenmailfrom,$seenrcptto)=(undef,[]);
  my $helo=gethostbyaddr(inet_aton($clientipstr), AF_INET);
  my $esmtp=0;
  while(defined($cmd=cliread(1200, 1)) && length($cmd)) {
    $cmd =~ s/\r?\n\z/\r\n/;
    if($cmd =~ /^\s*HELO\s+([ -~]*?)\r\n/i) {
      my $arg=$1;
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      if($reply =~ /^2/) {
        $helo=$arg;
        printlog "$id: client HELO name: ".cleanstr($helo);
      } else {
        printlog "$id: rejected client HELO name: ".cleanstr($arg).
                 " (".cleanstr($reply).")";
      }
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
    } elsif($cmd =~ /^\s*EHLO\s+([ -~]*?)\r\n/i) {
      my $arg=$1;
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      if($reply =~ /^2/) {
        $helo=$arg;
        $esmtp=1;
        printlog "$id: client EHLO name: ".cleanstr($helo);
      } else {
        printlog "$id: rejected client EHLO name: ".cleanstr($arg).
                 " (".cleanstr($reply).")";
      }
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
    } elsif($cmd =~ /^\s*MAIL FROM\s*:\s*<?([ -~]*?)\s*>?\s*\r\n/i) {
      my $arg=$1;
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      if($reply =~ /^2/) {
        ++$msgnum;
        printlog "$id: starting new message $msgnum with MAIL FROM:<".
                 cleanstr($arg).">";
        ($seenmailfrom,$seenrcptto)=($arg,[]);
      } else {
        printlog "$id: rejected MAIL FROM: <".cleanstr($arg).">".
                 " (".cleanstr($reply).")";
      }
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
    } elsif($cmd =~ /^\s*RCPT TO\s*:\s*<?([ -~]*?)\s*>?\s*\r\n/i) {
      rlrcpt($chain[-1]{destip});
      my $arg=$1;
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      if($reply =~ /^2/) {
        if(!defined($seenmailfrom)) {
          ++$msgnum;
          printlog "$id: starting new message $msgnum with no MAIL FROM";
        }
        printlog "$id: msg $msgnum: recipient RCPT TO:<".cleanstr($arg).">";
        push(@$seenrcptto, $arg);
      } else {
        printlog "$id: rejected RCPT TO: <".cleanstr($arg).">".
                 " (".cleanstr($reply).")";
      }
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
    } elsif($cmd =~ /^\s*DATA\s*\r\n/i) {
      if(!defined($seenmailfrom)) {
        cliprint $servertype->{needmail};
      } elsif(!@$seenrcptto) {
        cliprint $servertype->{needrcpt}->($hostname);
      } else {
        servprint "RSET\r\n";
        my $reply=read_smtp_reply();
        # TODO: send keepalive NOOPs periodically while reading message body
        smtp_data($servertype, $hostname, $helo, $esmtp, $msgnum,
                  $seenmailfrom, $seenrcptto);
        ($seenmailfrom,$seenrcptto)=(undef,[]);
        if(!defined($reply)) {
          printlog "$id: error reading SMTP reply from server: $!";
          exit(0);
        }
      }
    } elsif($cmd =~ /^\s*RSET\s*\r\n/i) {
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      if($reply =~ /^2/) {
        if(defined($seenmailfrom)) {
          printlog "$id: msg $msgnum: cancelled by RSET";
        } else {
          printlog "$id: useless RSET";
        }
        ($seenmailfrom,$seenrcptto)=(undef,[]);
      } else {
        printlog "$id: rejected RSET".
                 " (".cleanstr($reply).")";
      }
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
    } elsif($cmd =~ /^\s*NOOP\s*\r\n/i) {
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      printlog "$id: NOOP";
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
    } elsif($cmd =~ /^\s*VRFY\s+([ -~]*?)\s*\r\n/i) {
      my $arg=$1;
      rlrcpt($chain[-1]{destip});
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      if($reply =~ /^2/) {
        printlog "$id: VRFY ".cleanstr($arg);
      } else {
        printlog "$id: rejected VRFY ".cleanstr($arg).
                 " (".cleanstr($reply).")";
      }
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
    } elsif($cmd =~ /^\s*EXPN\s+(.*?)\s*\r\n/i) {
      printlog "$id: tried to EXPN ".cleanstr($1);
      cliprint $servertype->{expn}->($1);
    } elsif($cmd =~ /^\s*HELP((?:\s+[ -~]*)?)\r\n/i) {
      my $arg=$1;
      if(defined($help) && $arg =~ /^\s*$/) {
        printlog "$id: HELP";
        cliprint $help;
      } else {
        servprint $cmd;
        my $reply=read_smtp_reply();
        if(!defined($reply)) {
          printlog "$id: error reading SMTP reply from server: $!";
          exit(0);
        }
        printlog "$id: HELP$arg";
        $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
        cliprint $reply;
      }
    } elsif($cmd =~ /^\s*QUIT\s*\r\n/i) {
      servprint $cmd;
      my $reply=read_smtp_reply();
      if(!defined($reply)) {
        printlog "$id: error reading SMTP reply from server: $!";
        exit(0);
      }
      $reply =~ s/\b\Q$clientrealipstr\E\b/$clientipstr/g;
      cliprint $reply;
      if(defined($seenmailfrom)) {
        printlog "$id: msg $msgnum: cancelled by QUIT";
      } else {
        printlog "$id: QUIT request from client";
      }
      last;
    } elsif($cmd =~ /^\s*(DATA|EHLO|EXPN|HELO|HELP|MAIL|NOOP|QUIT|RCPT|RSET|VRFY)\b\s*(.*)\r\n/) {
      printlog "$id: strange command from client: ".cleanstr($cmd);
      cliprint $servertype->{syntax}->($1, $2);
    } else {
      printlog "$id: strange command from client: ".cleanstr($cmd);
      $cmd =~ s/\s.*//;
      cliprint $servertype->{unknown}->($cmd);
    }
    undef $help;
  }
  printlog "$id: ending session";
}

sub handle_socks1
{
  printlog "$id: starting fake SOCKS proxy session";
  handle_socks_proxyreq();
}

sub handle_socks2
{
  # A server connection exists - we know that the target SOCKS proxy exists.
  # Now close it and fake the rest.
  printlog "$id: starting mostly-fake SOCKS proxy session";
  close($tmpserversock);
  handle_socks_proxyreq();
}

# This looks just like handle_socks1, but the call sequence goes like this:
# handle_socks_proxyreq->proxy_request->passthrough_proxy_request
# and passthrough_proxy_request behaves differently when 'socks3' is on the
# chain.
sub handle_socks3
{
  printlog "$id: starting SOCKS proxy session";
  handle_socks_proxyreq();
}

sub handle_serverproto
{
  if($serverproto eq 'banner') {
    handle_banner();
  } elsif($serverproto eq 'http1') {
    $serversock->close() if $serversock;
    undef $serversock;
    handle_http1();
  } elsif($serverproto eq 'http2') {
    handle_http2();
  } elsif($serverproto eq 'httpc1') {
    $serversock->close() if $serversock;
    undef $serversock;
    handle_httpc1();
  } elsif($serverproto eq 'httpc2') {
    handle_httpc2();
  } elsif($serverproto eq 'httpc3') {
    handle_httpc3();
  } elsif($serverproto eq 'raw') {
    handle_raw();
  } elsif($serverproto eq 'smtp1') {
    $serversock->close() if $serversock;
    undef $serversock;
    handle_smtp1();
  } elsif($serverproto eq 'smtp2') {
    handle_smtp2();
  } elsif($serverproto eq 'smtp3') {
    handle_smtp3();
  } elsif($serverproto eq 'socks1') {
    $serversock->close() if $serversock;
    undef $serversock;
    handle_socks1();
  } elsif($serverproto eq 'socks2') {
    handle_socks2();
  } elsif($serverproto eq 'socks3') {
    handle_socks3();
  }
}

# The actual body of the debugging hook. Keep this at the bottom of the file,
# so it can see all the variables. If there are any file-scope "my" variables
# below this function, it can't see them, so it won't dump them!
{
my $once;BEGIN{$once=0;}
sub debughook
{
  if(!defined($debugfile)) {
    printlog "No debug file";
    return;
  }
  if($dumpkid) {
    printlog "Too many SIGUSR1s too fast";
    return;
  }
  if(!$once) {
    $once=1;
    eval {
      require Data::Dumper;
      require PadWalker;
      require Dumpvalue;
    };
    if($@) {
      printlog "Debugging dump failed: $@";
      return;
    }
    Data::Dumper->import();
    PadWalker->import('peek_my');
    Dumpvalue->import();
    $Data::Dumper::Useqq=1;
    $Data::Dumper::Useqq=1; # repeat to defeat warning
  }
  if(!open(DLOG, '>>', $debugfile)) {
    printlog "$debugfile: $!";
    exit(0);
  }
  # Do the dumping in a child process, otherwise it effectively blocks all
  # traffic for a noticeable period of time while the main process is working
  # on the dump and not responding to anything else.
  $dumpkid=fork();
  if(!defined($dumpkid)) {
    close(DLOG);
    printlog "Debugging dump failed: fork: $!";
    return;
  }
  if($dumpkid) {
    close(DLOG);
    printlog "SIGUSR1 received - doing dump to $debugfile";
    return;
  }
  # TODO: close all unneeded file descriptors (the other children's
  # socketpairs, the listening sockets, others?)
  print DLOG "Debugging dump starting ".localtime()."\n";
  print DLOG "Dumping main globals\n";
  # Dumpvalue::dumpvars uses the "currently selected filehandle" instead of
  # just returning the string. Ugh.
  select DLOG;
  Dumpvalue->new->dumpvars("main");
  for(my $i=0;;++$i) {
    my $dump=eval { Dumper(peek_my($i)) };
    last if $@;
    print DLOG "Dumping locals from frame $i\n";
    print DLOG $dump;
  }
  print DLOG "$@\n" if $@ !~ /Not nested deeply enough/;
  print DLOG "\n";
  close(DLOG);
  exit(0);
}
}