contrib/sendmail-8.13.4/contrib/etrn.pl

   1 #!/usr/local/bin/perl -w
   2 #
   3 # Copyright (c) 1996-2000 by John T. Beck <john@beck.org>
   4 # All rights reserved.
   5 #
   6 # Copyright (c) 2000 by Sun Microsystems, Inc.
   7 # All rights reserved.
   8 #
   9 #ident  "@(#)etrn.pl    1.1     00/09/06 SMI"
  10
  11 require 5.005;                          # minimal Perl version required
  12 use strict;
  13 use English;
  14
  15 # hardcoded constants, should work fine for BSD-based systems
  16 use Socket;
  17 use Getopt::Std;
  18 use vars qw($opt_v);
  19 my $sockaddr = 'S n a4 x8';
  20
  21 # system requirements:
  22 #       must have 'hostname' program.
  23
  24 my $port = 'smtp';
  25 select(STDERR);
  26
  27 chop(my $name = `hostname || uname -n`);
  28
  29 (my $hostname, my $aliases, my $type, my $len, undef) = gethostbyname($name);
  30
  31 my $usage = "Usage: $PROGRAM_NAME [-v] host [args]";
  32 getopts('v');
  33 my $verbose = $opt_v;
  34 my $server = shift(@ARGV);
  35 my @hosts = @ARGV;
  36 die $usage unless $server;
  37 my @cwfiles = ();
  38 my $alarm_action = "";
  39
  40 if (!@hosts) {
  41         push(@hosts, $hostname);
  42
  43         open(CF, "</etc/mail/sendmail.cf") ||
  44             die "open /etc/mail/sendmail.cf: $ERRNO";
  45         while (<CF>){
  46                 # look for a line starting with "Fw"
  47                 if (/^Fw.*$/) {
  48                         my $cwfile = $ARG;
  49                         chop($cwfile);
  50                         my $optional = /^Fw-o/;
  51                         # extract the file name
  52                         $cwfile =~ s,^Fw[^/]*,,;
  53
  54                         # strip the options after the filename
  55                         $cwfile =~ s/ [^ ]+$//;
  56
  57                         if (-r $cwfile) {
  58                                 push (@cwfiles, $cwfile);
  59                         } else {
  60                                 die "$cwfile is not readable" unless $optional;
  61                         }
  62                 }
  63                 # look for a line starting with "Cw"
  64                 if (/^Cw(.*)$/) {
  65                         my @cws = split (' ', $1);
  66                         while (@cws) {
  67                                 my $thishost = shift(@cws);
  68                                 push(@hosts, $thishost)
  69                                     unless $thishost =~ "$hostname|localhost";
  70                         }
  71                 }
  72         }
  73         close(CF);
  74
  75         for my $cwfile (@cwfiles) {
  76                 if (open(CW, "<$cwfile")) {
  77                         while (<CW>) {
  78                                 next if /^\#/;
  79                                 my $thishost = $ARG;
  80                                 chop($thishost);
  81                                 push(@hosts, $thishost)
  82                                     unless $thishost =~ $hostname;
  83                         }
  84                         close(CW);
  85                 } else {
  86                         die "open $cwfile: $ERRNO";
  87                 }
  88         }
  89 }
  90
  91 ($name, $aliases, my $proto) = getprotobyname('tcp');
  92 ($name, $aliases, $port) = getservbyname($port, 'tcp')
  93         unless $port =~ /^\d+/;
  94
  95 # look it up
  96
  97 ($name, $aliases, $type, $len, my $thataddr) = gethostbyname($server);
  98 (!defined($name)) && die "gethostbyname failed, unknown host $server";
  99
 100 # get a connection
 101 my $that = pack($sockaddr, &AF_INET, $port, $thataddr);
 102 socket(S, &AF_INET, &SOCK_STREAM, $proto)
 103         || die "socket: $ERRNO";
 104 print "server = $server\n" if (defined($verbose));
 105 &alarm("connect to $server");
 106 if (! connect(S, $that)) {
 107         die "cannot connect to $server: $ERRNO\n";
 108 }
 109 alarm(0);
 110 select((select(S), $OUTPUT_AUTOFLUSH = 1)[0]);  # don't buffer output to S
 111
 112 # read the greeting
 113 &alarm("greeting with $server");
 114 while (<S>) {
 115         alarm(0);
 116         print if $verbose;
 117         if (/^(\d+)([- ])/) {
 118                 # SMTP's initial greeting response code is 220.
 119                 if ($1 != 220) {
 120                         &alarm("giving up after bad response from $server");
 121                         &read_response($2, $verbose);
 122                         alarm(0);
 123                         print STDERR "$server: NOT 220 greeting: $ARG"
 124                                 if ($verbose);
 125                 }
 126                 last if ($2 eq " ");
 127         } else {
 128                 print STDERR "$server: NOT 220 greeting: $ARG"
 129                         if ($verbose);
 130                 close(S);
 131         }
 132         &alarm("greeting with $server");
 133 }
 134 alarm(0);
 135
 136 &alarm("sending ehlo to $server");
 137 &ps("ehlo $hostname");
 138 my $etrn_support = 0;
 139 while (<S>) {
 140         if (/^250([- ])ETRN(.+)$/) {
 141                 $etrn_support = 1;
 142         }
 143         print if $verbose;
 144         last if /^\d+ /;
 145 }
 146 alarm(0);
 147
 148 if ($etrn_support) {
 149         print "ETRN supported\n" if ($verbose);
 150         &alarm("sending etrn to $server");
 151         while (@hosts) {
 152                 $server = shift(@hosts);
 153                 &ps("etrn $server");
 154                 while (<S>) {
 155                         print if $verbose;
 156                         last if /^\d+ /;
 157                 }
 158                 sleep(1);
 159         }
 160 } else {
 161         print "\nETRN not supported\n\n"
 162 }
 163
 164 &alarm("sending 'quit' to $server");
 165 &ps("quit");
 166 while (<S>) {
 167         print if $verbose;
 168         last if /^\d+ /;
 169 }
 170 close(S);
 171 alarm(0);
 172
 173 select(STDOUT);
 174 exit(0);
 175
 176 # print to the server (also to stdout, if -v)
 177 sub ps
 178 {
 179         my ($p) = @_;
 180         print ">>> $p\n" if $verbose;
 181         print S "$p\n";
 182 }
 183
 184 sub alarm
 185 {
 186         ($alarm_action) = @_;
 187         alarm(10);
 188         $SIG{ALRM} = 'handle_alarm';
 189 }
 190
 191 sub handle_alarm
 192 {
 193         &giveup($alarm_action);
 194 }
 195
 196 sub giveup
 197 {
 198         my $reason = @_;
 199         (my $pk, my $file, my $line);
 200         ($pk, $file, $line) = caller;
 201
 202         print "Timed out during $reason\n" if $verbose;
 203         exit(1);
 204 }
 205
 206 # read the rest of the current smtp daemon's response (and toss it away)
 207 sub read_response
 208 {
 209         (my $done, $verbose) = @_;
 210         (my @resp);
 211         print my $s if $verbose;
 212         while (($done eq "-") && ($s = <S>) && ($s =~ /^\d+([- ])/)) {
 213                 print $s if $verbose;
 214                 $done = $1;
 215                 push(@resp, $s);
 216         }
 217         return @resp;
 218 }