1N/A

1N/Arequire 5.8.4; # minimal Perl version required

1N/Ause strict;

1N/Ause warnings;

1N/Ause English;

1N/A

1N/Ause Socket;

1N/Ause Getopt::Std;

1N/Aour ($opt_v, $opt_b);

1N/A

1N/A

1N/Amy $port = 'smtp';

1N/Aselect(STDERR);

1N/A

1N/Achop(my $name = `hostname || uname -n`);

1N/A

1N/Amy ($hostname) = (gethostbyname($name))[0];

1N/A

1N/Amy $usage = "Usage: $PROGRAM_NAME [-bv] host [args]";

1N/Agetopts('bv');

1N/Amy $verbose = $opt_v;

1N/Amy $boot_check = $opt_b;

1N/Amy $server = shift(@ARGV);

1N/Amy @hosts = @ARGV;

1N/Adie $usage unless $server;

1N/Amy @cwfiles = ();

1N/Amy $alarm_action = "";

1N/A

1N/Aif (!@hosts) {

1N/A push(@hosts, $hostname);

1N/A

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

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

1N/A while (<CF>){

1N/A # look for a line starting with "Fw"

1N/A if (/^Fw.*$/) {

1N/A my $cwfile = $ARG;

1N/A chop($cwfile);

1N/A my $optional = /^Fw-o/;

1N/A # extract the file name

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

1N/A

1N/A # strip the options after the filename

1N/A $cwfile =~ s/ [^ ]+$//;

1N/A

1N/A if (-r $cwfile) {

1N/A push (@cwfiles, $cwfile);

1N/A } else {

1N/A die "$cwfile is not readable" unless $optional;

1N/A }

1N/A }

1N/A # look for a line starting with "Cw"

1N/A if (/^Cw(.*)$/) {

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

1N/A while (@cws) {

1N/A my $thishost = shift(@cws);

1N/A push(@hosts, $thishost)

1N/A unless $thishost =~ "$hostname|localhost";

1N/A }

1N/A }

1N/A }

1N/A close(CF);

1N/A

1N/A for my $cwfile (@cwfiles) {

1N/A if (open(CW, "<$cwfile")) {

1N/A while (<CW>) {

1N/A next if /^\#/;

1N/A my $thishost = $ARG;

1N/A chop($thishost);

1N/A push(@hosts, $thishost)

1N/A unless $thishost =~ $hostname;

1N/A }

1N/A close(CW);

1N/A } else {

1N/A die "open $cwfile: $ERRNO";

1N/A }

1N/A }

1N/A # Do this automatically if no client hosts are specified.

1N/A $boot_check = "yes";

1N/A}

1N/A

1N/Amy ($proto) = (getprotobyname('tcp'))[2];

1N/A($port) = (getservbyname($port, 'tcp'))[2]

1N/A unless $port =~ /^\d+/;

1N/A

1N/Aif ($boot_check) {

1N/A # first connect to localhost to verify that we can accept connections

1N/A print "verifying that localhost is accepting SMTP connections\n"

1N/A if ($verbose);

1N/A my $localhost_ok = 0;

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

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

1N/A

1N/A # get a connection

1N/A my $sinl = sockaddr_in($port, $laddr);

1N/A my $save_errno = 0;

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

1N/A socket(S, &PF_INET, &SOCK_STREAM, $proto)

1N/A || die "socket: $ERRNO";

1N/A if (connect(S, $sinl)) {

1N/A &alarm("sending 'quit' to $server");

1N/A print S "quit\n";

1N/A alarm(0);

1N/A $localhost_ok = 1;

1N/A close(S);

1N/A alarm(0);

1N/A last;

1N/A }

1N/A print STDERR "localhost connect failed ($num_tries)\n";

1N/A $save_errno = $ERRNO;

1N/A sleep(1 << $num_tries);

1N/A close(S);

1N/A alarm(0);

1N/A }

1N/A if (! $localhost_ok) {

1N/A die "could not connect to localhost: $save_errno\n";

1N/A }

1N/A}

1N/A

1N/A

1N/A($name, my $thataddr) = (gethostbyname($server))[0, 4];

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

1N/A

1N/Amy $sinr = sockaddr_in($port, $thataddr);

1N/Asocket(S, &PF_INET, &SOCK_STREAM, $proto)

1N/A || die "socket: $ERRNO";

1N/Aprint "server = $server\n" if (defined($verbose));

1N/A&alarm("connect to $server");

1N/Aif (! connect(S, $sinr)) {

1N/A die "cannot connect to $server: $ERRNO\n";

1N/A}

1N/Aalarm(0);

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

1N/A

1N/A&alarm("greeting with $server");

1N/Awhile (<S>) {

1N/A alarm(0);

1N/A print if $verbose;

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

1N/A # SMTP's initial greeting response code is 220.

1N/A if ($1 != 220) {

1N/A &alarm("giving up after bad response from $server");

1N/A &read_response($2, $verbose);

1N/A alarm(0);

1N/A print STDERR "$server: NOT 220 greeting: $ARG"

1N/A if ($verbose);

1N/A }

1N/A last if ($2 eq " ");

1N/A } else {

1N/A print STDERR "$server: NOT 220 greeting: $ARG"

1N/A if ($verbose);

1N/A close(S);

1N/A }

1N/A &alarm("greeting with $server");

1N/A}

1N/Aalarm(0);

1N/A

1N/A&alarm("sending ehlo to $server");

1N/A&ps("ehlo $hostname");

1N/Amy $etrn_support = 0;

1N/Awhile (<S>) {

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

1N/A $etrn_support = 1;

1N/A }

1N/A print if $verbose;

1N/A last if /^\d+ /;

1N/A}

1N/Aalarm(0);

1N/A

1N/Aif ($etrn_support) {

1N/A print "ETRN supported\n" if ($verbose);

1N/A &alarm("sending etrn to $server");

1N/A while (@hosts) {

1N/A $server = shift(@hosts);

1N/A &ps("etrn $server");

1N/A while (<S>) {

1N/A print if $verbose;

1N/A last if /^\d+ /;

1N/A }

1N/A sleep(1);

1N/A }

1N/A} else {

1N/A print "\nETRN not supported\n\n"

1N/A}

1N/A

1N/A&alarm("sending 'quit' to $server");

1N/A&ps("quit");

1N/Awhile (<S>) {

1N/A print if $verbose;

1N/A last if /^\d+ /;

1N/A}

1N/Aclose(S);

1N/Aalarm(0);

1N/A

1N/Aselect(STDOUT);

1N/Aexit(0);

1N/A

1N/Asub ps

1N/A{

1N/A my ($p) = @_;

1N/A print ">>> $p\n" if $verbose;

1N/A print S "$p\n";

1N/A}

1N/A

1N/Asub alarm

1N/A{

1N/A ($alarm_action) = @_;

1N/A alarm(10);

1N/A $SIG{ALRM} = 'handle_alarm';

1N/A}

1N/A

1N/Asub handle_alarm

1N/A{

1N/A &giveup($alarm_action);

1N/A}

1N/A

1N/Asub giveup

1N/A{

1N/A my $reason = @_;

1N/A (my $pk, my $file, my $line);

1N/A ($pk, $file, $line) = caller;

1N/A

1N/A print "Timed out during $reason\n" if $verbose;

1N/A exit(1);

1N/A}

1N/A

1N/Asub read_response

1N/A{

1N/A (my $done, $verbose) = @_;

1N/A (my @resp);

1N/A print my $s if $verbose;

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

1N/A print $s if $verbose;

1N/A $done = $1;

1N/A push(@resp, $s);

1N/A }

1N/A return @resp;

1N/A}