xref: /freebsd/contrib/sendmail/contrib/etrn.pl (revision aa0a1e58) 
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
11require 5.005;				# minimal Perl version required
12use strict;
13use English;
14
15# hardcoded constants, should work fine for BSD-based systems
16use Socket;
17use Getopt::Std;
18use vars qw($opt_v);
19my $sockaddr = 'S n a4 x8';
20
21# system requirements:
22# 	must have 'hostname' program.
23
24my $port = 'smtp';
25select(STDERR);
26
27chop(my $name = `hostname || uname -n`);
28
29(my $hostname, my $aliases, my $type, my $len, undef) = gethostbyname($name);
30
31my $usage = "Usage: $PROGRAM_NAME [-v] host [args]";
32getopts('v');
33my $verbose = $opt_v;
34my $server = shift(@ARGV);
35my @hosts = @ARGV;
36die $usage unless $server;
37my @cwfiles = ();
38my $alarm_action = "";
39
40if (!@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
101my $that = pack($sockaddr, &AF_INET, $port, $thataddr);
102socket(S, &AF_INET, &SOCK_STREAM, $proto)
103	|| die "socket: $ERRNO";
104print "server = $server\n" if (defined($verbose));
105&alarm("connect to $server");
106if (! connect(S, $that)) {
107	die "cannot connect to $server: $ERRNO\n";
108}
109alarm(0);
110select((select(S), $OUTPUT_AUTOFLUSH = 1)[0]);	# don't buffer output to S
111
112# read the greeting
113&alarm("greeting with $server");
114while (<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}
134alarm(0);
135
136&alarm("sending ehlo to $server");
137&ps("ehlo $hostname");
138my $etrn_support = 0;
139while (<S>) {
140	if (/^250([- ])ETRN(.+)$/) {
141		$etrn_support = 1;
142	}
143	print if $verbose;
144	last if /^\d+ /;
145}
146alarm(0);
147
148if ($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");
166while (<S>) {
167	print if $verbose;
168	last if /^\d+ /;
169}
170close(S);
171alarm(0);
172
173select(STDOUT);
174exit(0);
175
176# print to the server (also to stdout, if -v)
177sub ps
178{
179	my ($p) = @_;
180	print ">>> $p\n" if $verbose;
181	print S "$p\n";
182}
183
184sub alarm
185{
186	($alarm_action) = @_;
187	alarm(10);
188	$SIG{ALRM} = 'handle_alarm';
189}
190
191sub handle_alarm
192{
193	&giveup($alarm_action);
194}
195
196sub 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)
207sub 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}
219