merlyn@iWarp.intel.com (Randal L. Schwartz) (05/29/91)
OK, I got select working, and have a demo program using select to have
a Perl process sit between a user and a /bin/sh. Enjoy. interact()
is just around the corner.
(Yes, *still* alpha. But getting closer to the features I want. :-)
#! /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 select.pl
# Wrapped by merlyn@iwarpse on Tue May 28 15:13:54 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'\" \(8344 characters\)
sed "s/^X//" >'chat2.pl' <<'END_OF_FILE'
X## chat.pl: chat with a server
X## V2.01.alpha.6 91/05/27
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## @ready_handles = &chat'select($timeout, @handles)
X## select()'s the handles with a timeout value of $timeout seconds.
X## Returns an array of handles that are ready for I/O.
X## Both user handles and chat handles are supported (but beware of
X## stdio's buffering for user handles).
X
Xsub select { ## public
X local($timeout) = shift;
X local(@handles) = @_;
X local(%handlename) = ();
X local(%ready) = ();
X local($caller) = caller;
X local($rmask) = "";
X for (@handles) {
X if (/$nextpat/o) { # one of ours... see if ready
X local(*SYM) = $_;
X if (length($SYM)) {
X $timeout = 0; # we have a winner
X $ready{$_}++;
X }
X $handlename{fileno($_)} = $_;
X } else {
X $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
X }
X }
X for (sort keys %handlename) {
X vec($rmask, $_, 1) = 1;
X }
X select($rmask, undef, undef, $timeout);
X for (sort keys %handlename) {
X $ready{$handlename{$_}}++ if vec($rmask,$_,1);
X }
X sort keys %ready;
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 8344 -ne `wc -c <'chat2.pl'`; then
echo shar: \"'chat2.pl'\" unpacked with wrong size!
fi
# end of 'chat2.pl'
fi
if test -f 'select.pl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'select.pl'\"
else
echo shar: Extracting \"'select.pl'\" \(365 characters\)
sed "s/^X//" >'select.pl' <<'END_OF_FILE'
X$|++;
X
Xrequire 'chat2.pl';
X
X$SH = &chat'open_proc("/bin/sh");
Xwhile (1) {
X @arr = &chat'select(5, STDIN, $SH);
X (print "{timeout}"), next unless @arr;
X %arr = ();
X for (@arr) {
X $arr{$_}++;
X }
X if ($arr{$SH}) {
X $buf = &chat'expect(0.0,'(.|\n)+','$&');
X print "<$buf>";
X }
X if ($arr{STDIN}) {
X $buf = <STDIN>;
X # print "[$buf]";
X &chat'print($SH, $buf);
X }
X}
END_OF_FILE
if test 365 -ne `wc -c <'select.pl'`; then
echo shar: \"'select.pl'\" unpacked with wrong size!
fi
# end of 'select.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'..."====/frechett@spot.Colorado.EDU (-=Runaway Daemon=-) (05/29/91)
Ack.. I hate ULTRIX.. I have a bit of a problem.. I unpacked the latest
chat2.pl and select.pl and after giving it my include dir and all. ..
When I execute select.pl I get
I made it here..
Segmentation fault (core dumped)
I made it here is right before the call to open_proc....
I then put a comment in open_proc that should be printed when it
gets there.. It isn't. As far as I can tell, it dumps core just because it
tries to use a procedure from chat2.pl. Of course this is really anoying
because it works on our Sparc just fine.. although it does give me a
periodic string of {timeout}'s. So does anyone know what the difference
here is?
And now on the next problem.. I have written a server. It is up to 260
lines or so in a day.. It allows people to browse through a specific
set of directories, namely my hp48sx archives and look at files..
Eventually I will have it allow people to queue up files for mailing
but I have found a small bug (ok one of a few small bugs ;) that is
Annoying me. If at any point someone presses ^C it locks up.. If they
remain on he line it kills the server.. and if they leave it goes
back to normal operation (leave as in just hang up). I can't seem to
trap the ^C in normal reading and when I try to do something with
SIG{'INT'} it only effects what happens when I cook the server from
where I started it.. What does ^C do to my main while loop and what
can be done to trap it and get rid of it?
ian
-=Runaway Daemon=-iglesias@draco.acs.uci.edu (Mike Iglesias) (05/29/91)
In article <1991May29.045434.12039@colorado.edu> frechett@spot.Colorado.EDU (-=Runaway Daemon=-) writes: > >Ack.. I hate ULTRIX.. I have a bit of a problem.. I unpacked the latest >chat2.pl and select.pl and after giving it my include dir and all. .. >When I execute select.pl I get >I made it here.. >Segmentation fault (core dumped) Works fine for me under Ultrix 4.1. Maybe your perl was built wrong? Mike Iglesias University of California, Irvine Internet: iglesias@draco.acs.uci.edu BITNET: iglesias@uci uucp: ...!ucbvax!ucivax!iglesias