chat2.pl with select(), and a tiny shell "interact"-like test harness 
Author Message
 chat2.pl with select(), and a tiny shell "interact"-like test harness

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

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
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               $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               unpack("S n C C C C x8", getsockname(NS));
X       $S{"needs_accept"} = *NS; # so expect will open it

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
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       }
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               # nope.  make a new one:

X
X               $cases .= <<"EDQ"; # header is funny to make everything elsif's
Xsub $subname {
X       LOOP: {
X               if (0) { ; }
XEDQ


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       }
X       $eof = $timeout = 0;
X       do $subname();
X}
X

X## $handle is from previous &chat'open().

X
Xsub print { ## public
X       if ($_[0] =~ /$nextpat/) {
X               *S = shift;
X       }

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## 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(%handlename) = ();
X       local(%ready) = ();
X       local($caller) = caller;
X       local($rmask) = "";

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       $_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 ...

read more »



Sun, 14 Nov 1993 06:15:47 GMT  
 chat2.pl with select(), and a tiny shell "interact"-like test harness

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=-



Sun, 14 Nov 1993 12:54:34 GMT  
 chat2.pl with select(), and a tiny shell "interact"-like test harness

Quote:

>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


uucp:        ...!ucbvax!ucivax!iglesias



Sun, 14 Nov 1993 13:33:29 GMT  
 
 [ 3 post ] 

 Relevant Pages 

1. Using "chat2.pl" effectively

2. chat2.pl and "client"

3. chat2.pl-"protocol not supported"

4. More fun with chat2.pl and select.pl

5. chat2.pl and expect's interact

6. Perl 5.0005_02 fails "make test", db-btree and db-hash tests

7. "testargex": Learn by testing regular expressions or test thosecomplex ones

8. Of "chat2" and deadlock

9. chat2.pl/select and character-by-character mode

10. Using "select" for precision timing

11. DBI "select" problem

12. select() on a "process" filehandle

 

 
Powered by phpBB® Forum Software