merlyn@iwarp.intel.com (Randal L. Schwartz) (05/09/91)
I was lamenting over the poor performance of invocations similar to:
while (something) {
$_ = &chat'expect(10, '.*\n', '$*');
if (/onepat/) {
do something;
last;
} elsif (/twopat/) {
do something else;
last;
}
}
because each time around the loop, expect built up an inner loop just
to eval it and discard it. Sad. So then, it hit me. Have expect
write a subroutine using eval, and call that subroutine whenever the
args are the same as the last call. Then, I got even smarter. Have
expect write a uniquely named subroutine, and remember the name of
that routine as a function of the current caller context and the args!
And it definitely helped.
So here's the new code. (My next step is to put some of the telnet
handling into this package so I can connect to telnet-like entities
using common subroutines instead of copying the telnet code from file
to file as I'm doing now. Watch for that Real Soon Now.)
#! /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
# Wrapped by merlyn@iwarpse on Wed May 8 11:45:56 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'\" \(7409 characters\)
sed "s/^X//" >'chat2.pl' <<'END_OF_FILE'
X## chat.pl: chat with a server
X## V2.01.alpha.5 91/05/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 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## ($host, $port, $handle) = &chat'open_listen();
X## opens a TCP port on the current machine, ready to be listened to
X
Xsub open_listen { ## public
X
X *S = ++$next;
X local(*NS) = "__" . time;
X unless (socket(NS, 2, 1, 6)) {
X # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
X # but who the heck would change these anyway? (:-)
X ($!) = ($!, close(NS));
X return undef;
X }
X unless (bind(NS, $thisproc)) {
X ($!) = ($!, close(NS));
X return undef;
X }
X unless (listen(NS, 1)) {
X ($!) = ($!, close(NS));
X return undef;
X }
X select((select(NS), $| = 1)[0]);
X local($family, $port, @myaddr) =
X unpack("S n C C C C x8", getsockname(NS));
X $S{"needs_accept"} = *NS; # so expect will open it
X (@myaddr, $port, $next); # returning this
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
X$nextsubname = "expectloop000000"; # used for subroutines
X
Xsub expect { ## public
X if ($_[0] =~ /$nextpat/) {
X *S = shift;
X }
X local($endtime) = shift;
X
X local($timeout,$eof) = (1,1);
X local($caller) = caller;
X local($rmask, $nfound, $timeleft, $thisbuf);
X local($cases, $pattern, $action, $subname);
X $endtime += time if $endtime < 600_000_000;
X
X if (defined $S{"needs_accept"}) { # is it a listen socket?
X local(*NS) = $S{"needs_accept"};
X delete $S{"needs_accept"};
X $S{"needs_close"} = *NS;
X unless(accept(S,NS)) {
X ($!) = ($!, close(S), close(NS));
X return undef;
X }
X select((select(S), $| = 1)[0]);
X }
X
X # now see whether we need to create a new sub:
X
X unless ($subname = $expect_subname{$caller,@_}) {
X # nope. make a new one:
X $expect_subname{$caller,@_} = $subname = $nextsubname++;
X
X $cases .= <<"EDQ"; # header is funny to make everything elsif's
Xsub $subname {
X LOOP: {
X if (0) { ; }
XEDQ
X while (@_) {
X ($pattern,$action) = splice(@_,0,2);
X if ($pattern =~ /^eof$/i) {
X $cases .= <<"EDQ";
X elsif (\$eof) {
X package $caller;
X $action;
X }
XEDQ
X $eof = 0;
X } elsif ($pattern =~ /^timeout$/i) {
X $cases .= <<"EDQ";
X elsif (\$timeout) {
X package $caller;
X $action;
X }
XEDQ
X $timeout = 0;
X } else {
X $pattern =~ s#/#\\/#g;
X $cases .= <<"EDQ";
X elsif (\$S =~ /$pattern/) {
X \$S = \$';
X package $caller;
X $action;
X }
XEDQ
X }
X }
X $cases .= <<"EDQ" if $eof;
X elsif (\$eof) {
X undef;
X }
XEDQ
X $cases .= <<"EDQ" if $timeout;
X elsif (\$timeout) {
X undef;
X }
XEDQ
X $cases .= <<'ESQ';
X else {
X $rmask = "";
X vec($rmask,fileno(S),1) = 1;
X ($nfound, $rmask) =
X select($rmask, undef, undef, $endtime - time);
X if ($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 }
X }
X}
XESQ
X eval $cases; die "$cases:\n$@" if $@;
X }
X $eof = $timeout = 0;
X do $subname();
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 if (defined $S{"needs_close"}) { # is it a listen socket?
X local(*NS) = $S{"needs_close"};
X delete $S{"needs_close"};
X close(NS);
X }
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 7409 -ne `wc -c <'chat2.pl'`; then
echo shar: \"'chat2.pl'\" unpacked with wrong size!
fi
# end of 'chat2.pl'
fi
echo shar: End of shell archive.
exit 0
printf "%s %s %s %s,", Just, another, Perl, hacker
--
/=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'..."====/jgreely@morganucodon.cis.ohio-state.edu (J Greely) (05/09/91)
In article <1991May8.184943.12338@iwarp.intel.com> merlyn@iwarp.intel.com (Randal L. Schwartz) writes: [again?!? :-)] I've long since given up on keeping the Perl archives on tut.cis.ohio-state.edu/osu-cis up-to-date, but Randal's unending struggle for the perfect chat package is the last straw: there's now a world-writable "incoming" directory on tut. Put packages, scripts, and anything else Perlish in tut.cis.ohio-state.edu:~/perl/incoming/{scripts,patches,misc} and send me e-mail describing the submission. "What are you going to do with him?" "Nurse him back to health, hold his hand, calm him down-- then watch him fly out the window... same as usual..." -- J Greely (jgreely@cis.ohio-state.edu; osu-cis!jgreely)