source: trunk/third/sendmail/contrib/etrn.pl @ 19204

Revision 19204, 4.3 KB checked in by zacheiss, 22 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r19203, which included commits to RCS files with non-trunk default branches.
  • Property svn:executable set to *
RevLine 
[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]11require 5.005;                          # minimal Perl version required
12use strict;
13use English;
14
[12553]15# hardcoded constants, should work fine for BSD-based systems
16use Socket;
17use Getopt::Std;
[19203]18use vars qw($opt_v);
19my $sockaddr = 'S n a4 x8';
[12553]20
21# system requirements:
22#       must have 'hostname' program.
23
[19203]24my $port = 'smtp';
[12553]25select(STDERR);
26
[19203]27chop(my $name = `hostname || uname -n`);
[12553]28
[19203]29(my $hostname, my $aliases, my $type, my $len, undef) = gethostbyname($name);
[12553]30
[19203]31my $usage = "Usage: $PROGRAM_NAME [-v] host [args]";
32getopts('v');
33my $verbose = $opt_v;
34my $server = shift(@ARGV);
35my @hosts = @ARGV;
[12553]36die $usage unless $server;
[19203]37my @cwfiles = ();
38my $alarm_action = "";
[12553]39
40if (!@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]101my $that = pack($sockaddr, &AF_INET, $port, $thataddr);
[12553]102socket(S, &AF_INET, &SOCK_STREAM, $proto)
[19203]103        || die "socket: $ERRNO";
104print "server = $server\n" if (defined($verbose));
105&alarm("connect to $server");
[12553]106if (! connect(S, $that)) {
[19203]107        die "cannot connect to $server: $ERRNO\n";
[12553]108}
[19203]109alarm(0);
110select((select(S), $OUTPUT_AUTOFLUSH = 1)[0]);  # don't buffer output to S
[12553]111
112# read the greeting
[19203]113&alarm("greeting with $server");
114while (<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}
134alarm(0);
135       
[19203]136&alarm("sending ehlo to $server");
[12553]137&ps("ehlo $hostname");
[19203]138my $etrn_support = 0;
139while (<S>) {
140        if (/^250([- ])ETRN(.+)$/) {
[12553]141                $etrn_support = 1;
142        }
[19203]143        print if $verbose;
[12553]144        last if /^\d+ /;
145}
146alarm(0);
147
[19203]148if ($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]166while (<S>) {
167        print if $verbose;
[12553]168        last if /^\d+ /;
169}
170close(S);
171alarm(0);
172
173select(STDOUT);
174exit(0);
175
[19203]176# print to the server (also to stdout, if -v)
[12553]177sub ps
178{
[19203]179        my ($p) = @_;
180        print ">>> $p\n" if $verbose;
[12553]181        print S "$p\n";
182}
183
184sub alarm
185{
[19203]186        ($alarm_action) = @_;
187        alarm(10);
[12553]188        $SIG{ALRM} = 'handle_alarm';
189}
190
191sub handle_alarm
192{
[19203]193        &giveup($alarm_action);
[12553]194}
195
[19203]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
[12553]206# read the rest of the current smtp daemon's response (and toss it away)
207sub 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}
Note: See TracBrowser for help on using the repository browser.