Path: utzoo!utgpu!news-server.csri.toronto.edu!rpi!zaphod.mps.ohio-state.edu!uwm.edu!bionet!agate!ucbvax!iwarp.intel.com!news
From: merlyn@iwarp.intel.com (Randal L. Schwartz)
Newsgroups: comp.lang.perl
Subject: better version of chat2.pl
Message-ID: <1991Apr11.222343.28800@iwarp.intel.com>
Date: 11 Apr 91 22:23:43 GMT
Sender: news@iwarp.intel.com
Reply-To: merlyn@iwarp.intel.com (Randal L. Schwartz)
Organization: Stonehenge; netaccess via Intel, Beaverton, Oregon, USA
Lines: 504

Argh.  Had some problems with filehandles not being closed.  Hmm.
Larry, is it a bug that a failed connect() leaves a filehandle open,
and I have to close the handle (even though the close generates an
error)?  Or is that just the way the underlying system works?  (To
test this, I'd have to *gasp* code in C! :-)

Anyway, here's the stuff I've got so far that I've been playing with.
No new comments, but if you look through this, you might come up with
some interesting stuff.  (WARNING: use this stuff at your own risk.)
(I particularly like the "anon FTP" finder.  You have to have "dig" to
use it, though.)

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  anonftp.pl chat2.pl dbx.pl expand-postmaster.pl
#   findnntp.pl smtp-intel.pl x2.pl
# Wrapped by merlyn@iwarpse on Thu Apr 11 15:21:35 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'anonftp.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'anonftp.pl'\"
else
echo shar: Extracting \"'anonftp.pl'\" \(1408 characters\)
sed "s/^X//" >'anonftp.pl' <<'END_OF_FILE'
X$|++;
X
Xpush(@INC,'/local/merlyn/lib/perl');
Xrequire 'chat2.pl';
X
X$rshr = 'rsh r ' unless `hostname` =~ "iwarpr\n";
X
Xfor $domain (@ARGV) {
X	print "working on $domain...\n";
X	$domain .= '.' unless $domain =~ /\.$/;
X	%nameservers = ();
X	for $line (`$rshr dig $domain ns`) {
X		next if $line =~ /^\s*(;.*)?$/;
X		next unless $line =~ /\s+NS\s+(\S+)$/;
X		print "nameserver = $1\n"; ## trace
X		$nameservers{$1}++;
X	}
X	@nameservers = sort keys nameservers;
X	(warn "no nameservers for $domain?"), next unless @nameservers;
X	%names = ();
X	for $nameserver (@nameservers) {
X		print "using nameserver $nameserver...\n";
X		for $line (`$rshr dig \@$nameserver $domain axfr`) {
X			next if $line =~ /^\s*(;.*)?$/;
X			next unless $line =~ /^(\S+)\s+(\d+\s+)?A/;
X			print "name = $1\n"; ## trace
X			$names{$1}++;
X		}
X		@names = sort keys names;
X		last if @names; # stop when we've seen some!
X	}
X	(warn "no names for $domain?"), next unless @names;
X	for $name (@names) {
X		print "connecting to $name...\n";
X		unless (&chat'open_port($name,21)) {
X			warn "no response from $name: $!";
X			next;
X		}
X		unless (&chat'expect(10,'^220.*\n',1)) {
X			warn "did not get 220";
X			&chat'close();
X			next;
X		}
X		&chat'print("USER anonymous\n");
X		unless(&chat'expect(10,'^331.*\n',1)) {
X			warn "did not get 331";
X			&chat'close();
X			next;
X		}
X		print "$name supports anon FTP.\n";
X		&chat'close(); # don't care about further response
X	}
X}
END_OF_FILE
if test 1408 -ne `wc -c <'anonftp.pl'`; then
    echo shar: \"'anonftp.pl'\" unpacked with wrong size!
fi
# end of 'anonftp.pl'
fi
if test -f 'chat2.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'chat2.pl'\"
else
echo shar: Extracting \"'chat2.pl'\" \(6216 characters\)
sed "s/^X//" >'chat2.pl' <<'END_OF_FILE'
X## chat.pl: chat with a server
X## V2.01.alpha.2 91/04/10
X## Randal L. Schwartz
X
Xpackage chat;
X
X$sockaddr = 'S n a4 x8';
Xchop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
X$thisproc = pack($sockaddr, 2, 0, $thisaddr);
X
X# *S = symbol for current I/O, gets assigned *chatsymbol....
X$next = "chatsymbol000000"; # next one
X$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
X
X
X## $handle = &chat'open_port("server.address",$port_number);
X## opens a named or numbered TCP server
X
Xsub open_port { ## public
X	local($server, $port) = @_;
X
X	local($serveraddr,$serverproc);
X
X	*S = ++$next;
X	if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
X		$serveraddr = pack('C4', $1, $2, $3, $4);
X	} else {
X		local(@x) = gethostbyname($server);
X		return undef unless @x;
X		$serveraddr = $x[4];
X	}
X	$serverproc = pack($sockaddr, 2, $port, $serveraddr);
X	unless (socket(S, 2, 1, 6)) {
X		# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
X		# but who the heck would change these anyway? (:-)
X		($!) = ($!, close(S)); # close S while saving $!
X		return undef;
X	}
X	unless (bind(S, $thisproc)) {
X		($!) = ($!, close(S)); # close S while saving $!
X		return undef;
X	}
X	unless (connect(S, $serverproc)) {
X		($!) = ($!, close(S)); # close S while saving $!
X		return undef;
X	}
X	select((select(S), $| = 1)[0]);
X	$next; # return symbol for switcharound
X}
X
X## $handle = &chat'open_proc("command","arg1","arg2",...);
X## opens a /bin/sh on a pseudo-tty
X
Xsub open_proc { ## public
X	local(@cmd) = @_;
X
X	*S = ++$next;
X	local(*TTY) = "__TTY" . time;
X	local($pty,$tty) = &_getpty(S,TTY);
X	die "Cannot find a new pty" unless defined $pty;
X	local($pid) = fork;
X	die "Cannot fork: $!" unless defined $pid;
X	unless ($pid) {
X		close STDIN; close STDOUT; close STDERR;
X		setpgrp(0,$$);
X		if (open(DEVTTY, "/dev/tty")) {
X		    ioctl(DEVTTY,0x20007471,0);		# XXX s/b &TIOCNOTTY
X		    close DEVTTY;
X		}
X		open(STDIN,"<&TTY");
X		open(STDOUT,">&TTY");
X		open(STDERR,">&STDOUT");
X		die "Oops" unless fileno(STDERR) == 2;	# sanity
X		close(S);
X		exec @cmd;
X		die "Cannot exec @cmd: $!";
X	}
X	close(TTY);
X	$next; # return symbol for switcharound
X}
X
X# $S is the read-ahead buffer
X
X## $return = &chat'expect([$handle,] $timeout_time,
X## 	$pat1, $body1, $pat2, $body2, ... )
X## $handle is from previous &chat'open_*().
X## $timeout_time is the time (either relative to the current time, or
X## absolute, ala time(2)) at which a timeout event occurs.
X## $pat1, $pat2, and so on are regexs which are matched against the input
X## stream.  If a match is found, the entire matched string is consumed,
X## and the corresponding body eval string is evaled.
X##
X## Each pat is a regular-expression (probably enclosed in single-quotes
X## in the invocation).  ^ and $ will work, respecting the current value of $*.
X## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
X## If pat is 'EOF', the body is executed if the process exits before
X## the other patterns are seen.
X##
X## Pats are scanned in the order given, so later pats can contain
X## general defaults that won't be examined unless the earlier pats
X## have failed.
X##
X## The result of eval'ing body is returned as the result of
X## the invocation.  Recursive invocations are not thought
X## through, and may work only accidentally. :-)
X##
X## undef is returned if either a timeout or an eof occurs and no
X## corresponding body has been defined.
X## I/O errors of any sort are treated as eof.
X
Xsub expect { ## public
X	if ($_[0] =~ /$nextpat/) {
X		*S = shift;
X	}
X	local($endtime) = shift;
X
X	$endtime += time if $endtime < 600_000_000;
X	local($rmask, $nfound, $timeleft, $thisbuf);
X	local($timeout,$eof) = (1,1);
X	local($cases,$pattern,$action);
X	local($caller) = caller;
X	local($return,@return);
X	local($returnvar) = wantarray ? '@return' : '$return';
X
X	## strategy: create a giant block inside $cases
X	$cases .= <<'ESQ';
X	LOOP: {
XESQ
X	while (@_) {
X		($pattern,$action) = splice(@_,0,2);
X		if ($pattern =~ /^eof$/i) {
X			$cases .= <<"EDQ";
X		if (\$eof) {
X			$returnvar = do { package $caller; $action; };
X			last LOOP;
X		}
XEDQ
X			$eof = 0;
X		} elsif ($pattern =~ /^timeout$/i) {
X			$cases .= <<"EDQ";
X		if (\$timeout) {
X			$returnvar = do { package $caller; $action; };
X			last LOOP;
X		}
XEDQ
X			$timeout = 0;
X		} else {
X			$pattern =~ s#/#\\/#g;
X			$cases .= <<"EDQ";
X		if (\$S =~ /$pattern/) {
X			\$S = \$';
X			$returnvar = do { package $caller; $action; };
X			last LOOP;
X		}
XEDQ
X		}
X	}
X	$cases .= <<"EDQ" if $eof;
X		if (\$eof) {
X			$returnvar = undef;
X			last LOOP;
X		}
XEDQ
X	$cases .= <<"EDQ" if $timeout;
X		if (\$timeout) {
X			$returnvar = undef;
X			last LOOP;
X		}
XEDQ
X	$eof = $timeout = 0;
X	$cases .= <<'ESQ';
X		$rmask = "";
X		vec($rmask,fileno(S),1) = 1;
X		($nfound, $rmask) =
X		 	select($rmask, undef, undef, $endtime - time);
X		if ($nfound) {
X			"<nfound = $nfound>";
X			$nread = sysread(S, $thisbuf, 1024);
X			if ($nread > 0) {
X				$S .= $thisbuf;
X			} else {
X				$eof++, redo LOOP; # any error is also eof
X			}
X		} else {
X			$timeout++, redo LOOP; # timeout
X		}
X		redo LOOP;
X	}
XESQ
X	eval $cases; die $@ if $@;
X	if (wantarray) {
X		return @return;
X	} else {
X		return $return;
X	}
X}
X
X## &chat'print([$handle,] @data)
X## $handle is from previous &chat'open().
X## like print $handle @data
X
Xsub print { ## public
X	if ($_[0] =~ /$nextpat/) {
X		*S = shift;
X	}
X	print S @_;
X}
X
X## &chat'close([$handle,])
X## $handle is from previous &chat'open().
X## like close $handle
X
Xsub close { ## public
X	if ($_[0] =~ /$nextpat/) {
X	 	*S = shift;
X	}
X	close(S);
X}
X
X# ($pty,$tty) = $chat'_getpty(PTY,TTY):
X# internal procedure to get the next available pty.
X# opens pty on handle PTY, and matching tty on handle TTY.
X# returns undef if can't find a pty.
X
Xsub _getpty { ## private
X	local($_PTY,$_TTY) = @_;
X	$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
X	$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
X	local($pty,$tty);
X	for $bank (112..127) {
X		next unless -e sprintf("/dev/pty%c0", $bank);
X		for $unit (48..57) {
X			$pty = sprintf("/dev/pty%c%c", $bank, $unit);
X			open($_PTY,"+>$pty") || next;
X			select((select($_PTY), $| = 1)[0]);
X			($tty = $pty) =~ s/pty/tty/;
X			open($_TTY,"+>$tty") || next;
X			select((select($_TTY), $| = 1)[0]);
X			system "stty nl>$tty";
X			return ($pty,$tty);
X		}
X	}
X	undef;
X}
X
X1;
END_OF_FILE
if test 6216 -ne `wc -c <'chat2.pl'`; then
    echo shar: \"'chat2.pl'\" unpacked with wrong size!
fi
# end of 'chat2.pl'
fi
if test -f 'dbx.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'dbx.pl'\"
else
echo shar: Extracting \"'dbx.pl'\" \(265 characters\)
sed "s/^X//" >'dbx.pl' <<'END_OF_FILE'
X
Xrequire './chat2.pl';
X
Xchdir "/r2/sbradley/dbx.test" || die "chdir: $!";
X
Xfor (1..20) {
X	system "./a.out";
X	&chat'open_proc("trace dbx ./a.out core");
X	&chat'print("where\nquit\n");
X	1 while &chat'expect(10,TIMEOUT,0,EOF,0,'(.|\n)+','print $&');
X	&chat'close();
X}
END_OF_FILE
if test 265 -ne `wc -c <'dbx.pl'`; then
    echo shar: \"'dbx.pl'\" unpacked with wrong size!
fi
# end of 'dbx.pl'
fi
if test -f 'expand-postmaster.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'expand-postmaster.pl'\"
else
echo shar: Extracting \"'expand-postmaster.pl'\" \(333 characters\)
sed "s/^X//" >'expand-postmaster.pl' <<'END_OF_FILE'
X$| = 1;
Xrequire './chat2.pl';
X
X&chat'open_port("localhost",25);
X
X&chat'expect(10,'^220.*\n',1) || die "No header";
X&chat'print("expn Postmaster\n");
X1 while &chat'expect(10,
X	'^250-(.*[^\r])\r?\n','print "$1\n "; 1',
X	'^250 (.*[^\r])\r?\n','print "$1\n"; 0',
X	'^550.*\n','print "no such user\n"; 0',
X	TIMEOUT,'0'
X);
X
X&chat'close();
X
END_OF_FILE
if test 333 -ne `wc -c <'expand-postmaster.pl'`; then
    echo shar: \"'expand-postmaster.pl'\" unpacked with wrong size!
fi
# end of 'expand-postmaster.pl'
fi
if test -f 'findnntp.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'findnntp.pl'\"
else
echo shar: Extracting \"'findnntp.pl'\" \(545 characters\)
sed "s/^X//" >'findnntp.pl' <<'END_OF_FILE'
X$|++;
X
Xpush(@INC,'/local/merlyn/lib/perl');
Xrequire 'chat2.pl';
X
Xchdir "/nfs/backups/usr.spool.news/comp.mail.maps" || die "cd: $!";
X
X@ARGV=(<u.usa.*>);
Xwhile (<>) {
X	next unless (/^(\S+)\s*=\s*(\S+)/);
X	$name = $2; $name =~ s/,.*//;
X	print "connecting to $name...\n";
X	unless (&chat'open_port($name,119)) {
X		warn "no response from $name: $!";
X		next;
X	}
X	unless (&chat'expect(10,'^20[01].*\n',1)) {
X		warn "did not get 20[01]";
X		&chat'close();
X		next;
X	}
X	print "$name supports NNTP.\n";
X	&chat'close(); # don't care about further response
X}
END_OF_FILE
if test 545 -ne `wc -c <'findnntp.pl'`; then
    echo shar: \"'findnntp.pl'\" unpacked with wrong size!
fi
# end of 'findnntp.pl'
fi
if test -f 'smtp-intel.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'smtp-intel.pl'\"
else
echo shar: Extracting \"'smtp-intel.pl'\" \(472 characters\)
sed "s/^X//" >'smtp-intel.pl' <<'END_OF_FILE'
X$|++;
X
Xpush(@INC,'/local/merlyn/lib/perl');
X
Xrequire 'chat2.pl';
X
Xopen(YC,"ypcat hosts|") || die "cannot open ypcat hosts: $!";
Xwhile (<YC>) {
X	chop;
X	($addr,@names) = split;
X	$name = shift(@names); # canon name is first
X	next unless $name =~ /iwarp/i;
X	print "$name $addr\n";
X	unless (&chat'open_port($addr,25)) {
X		warn "cannot connect to SMTP at $name: $!";
X		next;
X	}
X	&chat'expect(15, '(.*[^\r])\r?\n','print "$1\n"; 1') ||
X		warn "timeout or eof";
X	&chat'close();
X}
END_OF_FILE
if test 472 -ne `wc -c <'smtp-intel.pl'`; then
    echo shar: \"'smtp-intel.pl'\" unpacked with wrong size!
fi
# end of 'smtp-intel.pl'
fi
if test -f 'x2.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'x2.pl'\"
else
echo shar: Extracting \"'x2.pl'\" \(469 characters\)
sed "s/^X//" >'x2.pl' <<'END_OF_FILE'
X$| = 1;
Xrequire './chat2.pl';
X
Xfor (1..20) {
X	push(@a, &chat'open_proc("/bin/sh") || die "Cannot open sh");
X}
Xfor (@a) {
X	&chat'expect($_, 5, '\$ $', 1) || die "no prompt";
X}
Xfor (@a) {
X	&chat'print($_, "date\n");
X}
Xfor (@a) {
X	&chat'expect($_, 10, '\$ $', 'print $`') || die "no prompt";
X}
Xfor (@a) {
X	&chat'print($_, "tty; stty\n");
X}
Xfor (@a) {
X	&chat'expect($_, 10, '\$ $', 'print $`') || die "no prompt";
X}
X
Xfor (@a) {
X	&chat'close($_) || die "cannot close $_";
X}
END_OF_FILE
if test 469 -ne `wc -c <'x2.pl'`; then
    echo shar: \"'x2.pl'\" unpacked with wrong size!
fi
# end of 'x2.pl'
fi
echo shar: End of shell archive.
exit 0
-- 
/=Randal L. Schwartz, Stonehenge Consulting Services (503)777-0095 ==========\
| on contract to Intel's iWarp project, Beaverton, Oregon, USA, Sol III      |
| merlyn@iwarp.intel.com ...!any-MX-mailer-like-uunet!iwarp.intel.com!merlyn |
\=Cute Quote: "Intel: putting the 'backward' in 'backward compatible'..."====/