merlyn@iwarp.intel.com (Randal L. Schwartz) (04/09/91)
OK, here it is... the all-singing, all-dancing chat2.pl. I've run it
on some test cases, but no production code just yet. See the comments
for a description.
It's sorta like expect.pl, in that it takes a list of regex's and
corresponding actions, but it's also like that chat.pl I posted last
month, in that it can talk to TCP ports. It's also much more
efficient than expect.pl, because it presumes that you cannot get to
the filehandles yourself (to screw up the buffering).
I've included expand-postmaster.pl, which contacts the SMTP port to
find out what Postmaster expands to on your system, and x2.pl, which
runs 20 different /bin/sh's simultaneously, executing a "date; tty;
stty" command on each.
This thing is probably riddled with BSD-type stuff. I'm on SunOS 4.1
on sparcs and stuff if it matters. Scream at me a bit if you have a
fix that makes it more portable.
I'll release a *real* version in a while with more documentation, but
this should be enough to get you started.
#! /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: chat2.pl expand-postmaster.pl x2.pl
# Wrapped by merlyn@iwarpse on Mon Apr 8 16:05:37 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'chat2.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'chat2.pl'\"
else
echo shar: Extracting \"'chat2.pl'\" \(6056 characters\)
sed "s/^X//" >'chat2.pl' <<'END_OF_FILE'
X## chat.pl: chat with a server
X## V2.01.alpha 91/04/08
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 die "gethostbyname: $hostname ($!)" unless @x;
X $serveraddr = $x[4];
X }
X $serverproc = pack($sockaddr, 2, $port, $serveraddr);
X socket(S, 2, 1, 6) || die "socket: $!";
X # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
X # but who the heck would change these anyway? (:-)
X bind(S, $thisproc) || die "bind: $!";
X connect(S, $serverproc) || die "connect: $!";
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 6056 -ne `wc -c <'chat2.pl'`; then
echo shar: \"'chat2.pl'\" unpacked with wrong size!
fi
# end of 'chat2.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 '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'..."====/