require 5.8.4; # minimal Perl version required

use strict;

use warnings;

use English;

use Socket;

use Getopt::Std;

our ($opt_v, $opt_b);

my $port = 'smtp';

select(STDERR);

chop(my $name = `hostname || uname -n`);

my ($hostname) = (gethostbyname($name))[0];

my $usage = "Usage: $PROGRAM_NAME [-bv] host [args]";

getopts('bv');

my $verbose = $opt_v;

my $boot_check = $opt_b;

my $server = shift(@ARGV);

my @hosts = @ARGV;

die $usage unless $server;

my @cwfiles = ();

my $alarm_action = "";

if (!@hosts) {

push(@hosts, $hostname);

open(CF, "</etc/mail/sendmail.cf") ||

die "open /etc/mail/sendmail.cf: $ERRNO";

while (<CF>){

# look for a line starting with "Fw"

if (/^Fw.*$/) {

my $cwfile = $ARG;

chop($cwfile);

my $optional = /^Fw-o/;

# extract the file name

$cwfile =~ s,^Fw[^/]*,,;

# strip the options after the filename

$cwfile =~ s/ [^ ]+$//;

if (-r $cwfile) {

push (@cwfiles, $cwfile);

} else {

die "$cwfile is not readable" unless $optional;

}

}

# look for a line starting with "Cw"

if (/^Cw(.*)$/) {

my @cws = split (' ', $1);

while (@cws) {

my $thishost = shift(@cws);

push(@hosts, $thishost)

unless $thishost =~ "$hostname|localhost";

}

}

}

close(CF);

for my $cwfile (@cwfiles) {

if (open(CW, "<$cwfile")) {

while (<CW>) {

next if /^\#/;

my $thishost = $ARG;

chop($thishost);

push(@hosts, $thishost)

unless $thishost =~ $hostname;

}

close(CW);

} else {

die "open $cwfile: $ERRNO";

}

}

# Do this automatically if no client hosts are specified.

$boot_check = "yes";

}

my ($proto) = (getprotobyname('tcp'))[2];

($port) = (getservbyname($port, 'tcp'))[2]

unless $port =~ /^\d+/;

if ($boot_check) {

# first connect to localhost to verify that we can accept connections

print "verifying that localhost is accepting SMTP connections\n"

if ($verbose);

my $localhost_ok = 0;

($name, my $laddr) = (gethostbyname('localhost'))[0, 4];

(!defined($name)) && die "gethostbyname failed, unknown host localhost";

# get a connection

my $sinl = sockaddr_in($port, $laddr);

my $save_errno = 0;

for (my $num_tries = 1; $num_tries < 5; $num_tries++) {

socket(S, &PF_INET, &SOCK_STREAM, $proto)

|| die "socket: $ERRNO";

if (connect(S, $sinl)) {

&alarm("sending 'quit' to $server");

print S "quit\n";

alarm(0);

$localhost_ok = 1;

close(S);

alarm(0);

last;

}

print STDERR "localhost connect failed ($num_tries)\n";

$save_errno = $ERRNO;

sleep(1 << $num_tries);

close(S);

alarm(0);

}

if (! $localhost_ok) {

die "could not connect to localhost: $save_errno\n";

}

}

($name, my $thataddr) = (gethostbyname($server))[0, 4];

(!defined($name)) && die "gethostbyname failed, unknown host $server";

my $sinr = sockaddr_in($port, $thataddr);

socket(S, &PF_INET, &SOCK_STREAM, $proto)

|| die "socket: $ERRNO";

print "server = $server\n" if (defined($verbose));

&alarm("connect to $server");

if (! connect(S, $sinr)) {

die "cannot connect to $server: $ERRNO\n";

}

alarm(0);

select((select(S), $OUTPUT_AUTOFLUSH = 1)[0]); # don't buffer output to S

&alarm("greeting with $server");

while (<S>) {

alarm(0);

print if $verbose;

if (/^(\d+)([- ])/) {

# SMTP's initial greeting response code is 220.

if ($1 != 220) {

&alarm("giving up after bad response from $server");

&read_response($2, $verbose);

alarm(0);

print STDERR "$server: NOT 220 greeting: $ARG"

if ($verbose);

}

last if ($2 eq " ");

} else {

print STDERR "$server: NOT 220 greeting: $ARG"

if ($verbose);

close(S);

}

&alarm("greeting with $server");

}

alarm(0);

&alarm("sending ehlo to $server");

&ps("ehlo $hostname");

my $etrn_support = 0;

while (<S>) {

if (/^250([- ])ETRN(.+)$/) {

$etrn_support = 1;

}

print if $verbose;

last if /^\d+ /;

}

alarm(0);

if ($etrn_support) {

print "ETRN supported\n" if ($verbose);

&alarm("sending etrn to $server");

while (@hosts) {

$server = shift(@hosts);

&ps("etrn $server");

while (<S>) {

print if $verbose;

last if /^\d+ /;

}

sleep(1);

}

} else {

print "\nETRN not supported\n\n"

}

&alarm("sending 'quit' to $server");

&ps("quit");

while (<S>) {

print if $verbose;

last if /^\d+ /;

}

close(S);

alarm(0);

select(STDOUT);

exit(0);

sub ps

{

my ($p) = @_;

print ">>> $p\n" if $verbose;

print S "$p\n";

}

sub alarm

{

($alarm_action) = @_;

alarm(10);

$SIG{ALRM} = 'handle_alarm';

}

sub handle_alarm

{

&giveup($alarm_action);

}

sub giveup

{

my $reason = @_;

(my $pk, my $file, my $line);

($pk, $file, $line) = caller;

print "Timed out during $reason\n" if $verbose;

exit(1);

}

sub read_response

{

(my $done, $verbose) = @_;

(my @resp);

print my $s if $verbose;

while (($done eq "-") && ($s = <S>) && ($s =~ /^\d+([- ])/)) {

print $s if $verbose;

$done = $1;

push(@resp, $s);

}

return @resp;

}