home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BURKS 2
/
BURKS_AUG97.ISO
/
SLAKWARE
/
D12
/
PERL1.TGZ
/
perl1.tar
/
usr
/
lib
/
perl5
/
chat2.inter
< prev
next >
Wrap
Text File
|
1996-06-28
|
13KB
|
496 lines
Article 20992 of comp.lang.perl:
Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!cs.utexas.edu!swrinde!ihnp4.ucsd.edu!ames!koriel!male.EBay.Sun.COM!jethro.Corp.Sun.COM!eric
From: eric.arnold@sun.com (Eric Arnold)
Newsgroups: comp.lang.perl
Subject: Re: Need a bidirectional filter for interactive Unix applications
Date: 15 Apr 94 21:24:03 GMT
Organization: Sun Microsystems
Lines: 478
Sender: news@sun.com
Message-ID: <ERIC.94Apr15212403@sun.com>
References: <dgfCo9F2J.Jzw@netcom.com> <1994Apr15.110134.4581@chemabs.uucp>
NNTP-Posting-Host: animus.corp.sun.com
X-Newsreader: prn Ver 1.09
In-reply-to: btf64@cas.org's message of Fri, 15 Apr 1994 11:01:34 GMT
In article <1994Apr15.110134.4581@chemabs.uucp>
btf64@cas.org (Bernard T. French) writes:
>In article <dgfCo9F2J.Jzw@netcom.com> dgf@netcom.com (David Feldman) writes:
>>I need to write a bidirectional filter that would (ideally) sit between a
..
>>program's stdin & stdout to point to a pty pair known to perl. The perl app-
>>lication would talk to the user's crt/keyboard, translate (application-specific)
>>the input & output streams, and pass these as appropriate to/from the pty pair,
..
>
> I'm afraid I can't offer you a perl solution, but err..... there is a
>Tcl solution. There is a Tcl extension called "expect" that is designed to
There *is* an old, established Perl solution: "chat2.pl" which does
everything (well, basically) "expect" does but you get it in the
expressive Perl environment. "chat2.pl" is delivered with the Perl
source.
Randal: "interact()" still hasn't made it into Perl5alpha8
"chat2.pl", so I've included a version which does.
-Eric
## chat.pl: chat with a server
## V2.01.alpha.7 91/06/16
## Randal L. Schwartz
package chat;
$sockaddr = 'S n a4 x8';
chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
$thisproc = pack($sockaddr, 2, 0, $thisaddr);
# *S = symbol for current I/O, gets assigned *chatsymbol....
$next = "chatsymbol000000"; # next one
$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
## $handle = &chat'open_port("server.address",$port_number);
## opens a named or numbered TCP server
sub open_port { ## public
local($server, $port) = @_;
local($serveraddr,$serverproc);
*S = ++$next;
if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
$serveraddr = pack('C4', $1, $2, $3, $4);
} else {
local(@x) = gethostbyname($server);
return undef unless @x;
$serveraddr = $x[4];
}
$serverproc = pack($sockaddr, 2, $port, $serveraddr);
unless (socket(S, 2, 1, 6)) {
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? (:-)
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
unless (bind(S, $thisproc)) {
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
unless (connect(S, $serverproc)) {
($!) = ($!, close(S)); # close S while saving $!
return undef;
}
select((select(S), $| = 1)[0]);
$next; # return symbol for switcharound
}
## ($host, $port, $handle) = &chat'open_listen([$port_number]);
## opens a TCP port on the current machine, ready to be listened to
## if $port_number is absent or zero, pick a default port number
## process must be uid 0 to listen to a low port number
sub open_listen { ## public
*S = ++$next;
local($thisport) = shift || 0;
local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
local(*NS) = "__" . time;
unless (socket(NS, 2, 1, 6)) {
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? (:-)
($!) = ($!, close(NS));
return undef;
}
unless (bind(NS, $thisproc_local)) {
($!) = ($!, close(NS));
return undef;
}
unless (listen(NS, 1)) {
($!) = ($!, close(NS));
return undef;
}
select((select(NS), $| = 1)[0]);
local($family, $port, @myaddr) =
unpack("S n C C C C x8", getsockname(NS));
$S{"needs_accept"} = *NS; # so expect will open it
(@myaddr, $port, $next); # returning this
}
## $handle = &chat'open_proc("command","arg1","arg2",...);
## opens a /bin/sh on a pseudo-tty
sub open_proc { ## public
local(@cmd) = @_;
*S = ++$next;
local(*TTY) = "__TTY" . time;
local($pty,$tty,$pty_handle) = &_getpty(S,TTY);
#local($pty,$tty,$pty_handle) = &getpty(S,TTY);
#$Tty = $tty;
die "Cannot find a new pty" unless defined $pty;
local($pid) = fork;
die "Cannot fork: $!" unless defined $pid;
unless ($pid) {
close STDIN; close STDOUT; close STDERR;
#close($pty_handle);
setpgrp(0,$$);
if (open(DEVTTY, "/dev/tty")) {
ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
close DEVTTY;
}
open(STDIN,"<&TTY");
open(STDOUT,">&TTY");
open(STDERR,">&STDOUT");
die "Oops" unless fileno(STDERR) == 2; # sanity
close(S);
exec @cmd;
die "Cannot exec @cmd: $!";
}
close(TTY);
$PID{$next} = $pid;
$next; # return symbol for switcharound
}
# $S is the read-ahead buffer
## $return = &chat'expect([$handle,] $timeout_time,
## $pat1, $body1, $pat2, $body2, ... )
## $handle is from previous &chat'open_*().
## $timeout_time is the time (either relative to the current time, or
## absolute, ala time(2)) at which a timeout event occurs.
## $pat1, $pat2, and so on are regexs which are matched against the input
## stream. If a match is found, the entire matched string is consumed,
## and the corresponding body eval string is evaled.
##
## Each pat is a regular-expression (probably enclosed in single-quotes
## in the invocation). ^ and $ will work, respecting the current value of $*.
## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
## If pat is 'EOF', the body is executed if the process exits before
## the other patterns are seen.
##
## Pats are scanned in the order given, so later pats can contain
## general defaults that won't be examined unless the earlier pats
## have failed.
##
## The result of eval'ing body is returned as the result of
## the invocation. Recursive invocations are not thought
## through, and may work only accidentally. :-)
##
## undef is returned if either a timeout or an eof occurs and no
## corresponding body has been defined.
## I/O errors of any sort are treated as eof.
$nextsubname = "expectloop000000"; # used for subroutines
sub expect { ## public
if ($_[0] =~ /$nextpat/) {
*S = shift;
}
local($endtime) = shift;
local($timeout,$eof) = (1,1);
local($caller) = caller;
local($rmask, $nfound, $timeleft, $thisbuf);
local($cases, $pattern, $action, $subname);
$endtime += time if $endtime < 600_000_000;
if (defined $S{"needs_accept"}) { # is it a listen socket?
local(*NS) = $S{"needs_accept"};
delete $S{"needs_accept"};
$S{"needs_close"} = *NS;
unless(accept(S,NS)) {
($!) = ($!, close(S), close(NS));
return undef;
}
select((select(S), $| = 1)[0]);
}
# now see whether we need to create a new sub:
unless ($subname = $expect_subname{$caller,@_}) {
# nope. make a new one:
$expect_subname{$caller,@_} = $subname = $nextsubname++;
$cases .= <<"EDQ"; # header is funny to make everything elsif's
sub $subname {
LOOP: {
if (0) { ; }
EDQ
while (@_) {
($pattern,$action) = splice(@_,0,2);
if ($pattern =~ /^eof$/i) {
$cases .= <<"EDQ";
elsif (\$eof) {
package $caller;
$action;
}
EDQ
$eof = 0;
} elsif ($pattern =~ /^timeout$/i) {
$cases .= <<"EDQ";
elsif (\$timeout) {
package $caller;
$action;
}
EDQ
$timeout = 0;
} else {
$pattern =~ s#/#\\/#g;
$cases .= <<"EDQ";
elsif (\$S =~ /$pattern/) {
\$S = \$';
package $caller;
$action;
}
EDQ
}
}
$cases .= <<"EDQ" if $eof;
elsif (\$eof) {
undef;
}
EDQ
$cases .= <<"EDQ" if $timeout;
elsif (\$timeout) {
undef;
}
EDQ
$cases .= <<'ESQ';
else {
$rmask = "";
vec($rmask,fileno(S),1) = 1;
($nfound, $rmask) =
select($rmask, undef, undef, $endtime - time);
if ($nfound) {
$nread = sysread(S, $thisbuf, 1024);
if ($nread > 0) {
$S .= $thisbuf;
} else {
$eof++, redo LOOP; # any error is also eof
}
} else {
$timeout++, redo LOOP; # timeout
}
redo LOOP;
}
}
}
ESQ
eval $cases; die "$cases:\n$@" if $@;
}