merlyn@iwarp.intel.com (Randal L. Schwartz) (04/24/91)
I found out that I didn't need to go through hermes to get to the
weather server, so this is faster. And someone asked me for chat2, so
I presume its gone from most people's spools again. So, here's chat2
and a better weather script (as an example of chat2):
#! /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 weather2
# Wrapped by merlyn@iwarpse on Tue Apr 23 16:03:46 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'\" \(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 'weather2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'weather2'\"
else
echo shar: Extracting \"'weather2'\" \(1476 characters\)
sed "s/^X//" >'weather2' <<'END_OF_FILE'
X#!/usr/bin/perl
X
Xpush(@INC, '/local/merlyn/lib/perl');
X
Xrequire 'chat2.pl';
X
X$| = $trace = 1 if @ARGV; # debug mode if any args
X
X$where = "pdx";
X
X&chat'open_port('madlab.sprl.umich.edu', 3000) || die "open: $!";
X
X$_ = &listen(5);
Xif (/(.) to display main menu/i) { # special statement?
X &talk("$1\n");
X $_ = &listen(3);
X}
Xdie "bad stuff" unless /(.)\).*change scrolling/i;
X&talk("$1\n");
Xdie "bad stuff" unless ($_ = &listen(3)) =~ /(.)\).*unlimited/i;
X&talk("$1\n");
Xdie "bad stuff" unless ($_ = &listen(3)) =~ /(.)\).*city/i;
X&talk("$1\n");
Xdie "bad stuff" unless ($_ = &listen(3)) =~ /(.)\).*selected city/i;
X&talk("$1\n");
Xdie "bad stuff" unless ($_ = &listen(3)) =~ /3-letter city code/i;
X&talk("$where\n");
X$_ = &listen(5);
Xif (/special weather statement/i) {
X s/\s*\*(.|\n)+$//;
X $weather = $_;
X &talk("\n");
X $_ = &listen(3);
X die "bad stuff" unless /(.)\).*exit program/i;
X $code = $1;
X s/\s*Select an option(.|\n)+$//;
X $weather .= "\n\n$_";
X} else {
X die "bad stuff" unless /(.)\).*exit program/i;
X $code = $1;
X s/\s*Select an option(.|\n)+$//;
X $weather = $_;
X}
X&talk("$code\n");
X&listen(5); # just to fetch the closing data for trace
X
Xprint "$where weather:\n$weather\n";
X
X&chat'close();
Xexit(0);
X
X
Xsub talk {
X local($text) = @_;
X print "{$text}" if $trace;
X &chat'print($text);
X}
X
Xsub listen {
X local($secs) = @_;
X local($return,$tmp) = "";
X while (length($tmp = &chat'expect($secs, '(.|\n)+', '$&'))) {
X print $tmp if $trace;
X $return .= $tmp;
X }
X $return;
X}
END_OF_FILE
if test 1476 -ne `wc -c <'weather2'`; then
echo shar: \"'weather2'\" unpacked with wrong size!
fi
chmod +x 'weather2'
# end of 'weather2'
fi
echo shar: End of shell archive.
exit 0
print "Just another Perl (and net-) 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'..."====/