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