Merge from vendor branch GDB:
[dragonfly.git] / 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 }