lars@yosemite.berkeley.edu (Lars E. Thon) (06/12/91)
One feature that I have been missing from perl is having a double-ended
pipe. This could be useful f.ex. if you want to feed a lot of commands
to a csh and then analyze output and/or status from the commands. For a
simple (and contrived) example, consider the following:
#! /usr/local/gnu/bin/perl
doublepipe_open(CSH_IN, "| /bin/csh -f |", CSH_OUT);
#Silly way of checking whether user ~blah exists
print CSH_IN "echo ~blah";
$pathname= <CSH_OUT>;
print CSH_IN "echo \$status";
$errcode= <CSH_OUT>;
if ($errcode) {
print "User blah does not exist ...\n";
}
# END
I haven't seen a way to do this in perl, except for the obvious (but
unsatisfactory) method of using a temp file to store the csh output.
Any ideas about this?
--
----------------------------------------------------------------------------
Lars E. Thon, lars@yukon.berkeley.edu, T. 415-642-9350
211-134 Cory Hall, UC Berkeley, CA 94720casper@fwi.uva.nl (Casper H.S. Dik) (06/14/91)
lars@yosemite.berkeley.edu (Lars E. Thon) writes: >One feature that I have been missing from perl is having a double-ended >pipe. This could be useful f.ex. if you want to feed a lot of commands >to a csh and then analyze output and/or status from the commands. For a >simple (and contrived) example, consider the following: >#! /usr/local/gnu/bin/perl >doublepipe_open(CSH_IN, "| /bin/csh -f |", CSH_OUT); >#Silly way of checking whether user ~blah exists >print CSH_IN "echo ~blah"; >$pathname= <CSH_OUT>; >print CSH_IN "echo \$status"; >$errcode= <CSH_OUT>; >if ($errcode) { > print "User blah does not exist ...\n"; >} ># END >I haven't seen a way to do this in perl, except for the obvious (but >unsatisfactory) method of using a temp file to store the csh output. >Any ideas about this? >-- You can easily roll your own: sub double_pipe { local($in,$cmd,$out) = @_; # Create an in and an out pipe. Make them unbuffered. pipe($out,WTMP); pipe(RTMP,$in); select($in); $| = 1; select($out); $| = 1; select(STDOUT); unless (fork) { # close the unused sides in the child. close($in); close($out); open(STDIN,"<&RTMP"); open(STDOUT,">&WTMP"); # Join stdin and stdout. open(STDERR,">&WTMP"); close(RTMP); close(WTMP); exec $cmd; die "Can't execute $cmd\n"; } # close the unused sides in the parent. close(WTMP); close(RTMP); } &double_pipe(SH_IN,"sh",SH_OUT); print SH_IN "ls -l\n"; # NOTE: trailing \n, and no |'s. close(SH_IN); while (<SH_OUT>) { print $_ ; } #Casper -- | Casper H.S. Dik RELIGION KILLS | casper@fwi.uva.nl
merlyn@iWarp.intel.com (Randal L. Schwartz) (06/14/91)
In article <1991Jun14.111448.25093@fwi.uva.nl>, casper@fwi (Casper H.S. Dik) writes: | lars@yosemite.berkeley.edu (Lars E. Thon) writes: | >One feature that I have been missing from perl is having a double-ended | >pipe. This could be useful f.ex. if you want to feed a lot of commands | >to a csh and then analyze output and/or status from the commands. | | >I haven't seen a way to do this in perl, except for the obvious (but | >unsatisfactory) method of using a temp file to store the csh output. | | >Any ideas about this? | >-- | | You can easily roll your own: Or use chat2. Which is pretty much why I wrote it. Here's the current version (unchanged in at least a couple of weeks... if your copy has &chat'select, you've got the latest)... #! /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 Fri Jun 14 09:20:22 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 echo shar: End of shell archive. exit 0 print "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'..."====/
tchrist@convex.COM (Tom Christiansen) (06/16/91)
From the keyboard of lars@yosemite.berkeley.edu.UUCP (Lars E. Thon):
:One feature that I have been missing from perl is having a double-ended
:pipe. This could be useful f.ex. if you want to feed a lot of commands
:to a csh and then analyze output and/or status from the commands. For a
:simple (and contrived) example, consider the following:
From the FAQ. I guess I should s/expect/chat2/.
--tom
[Last changed: $Date: 91/06/02 14:13:23 $ by $Author: tchrist $]
20) How do I open a pipe both to and from a command?
In general, this is a dangerous move because you can find yourself in
deadlock situation. It's better to put one end of the pipe to a file.
For example:
# first write some_cmd's input into a_file, then
open(CMD, "some_cmd its_args < a_file |");
while (<CMD>) {
# or else the other way; run the cmd
open(CMD, "| some_cmd its_args > a_file");
while ($condition) {
print CMD "some output\n";
# other code deleted
}
close CMD || warn "cmd exited $?";
# now read the file
open(FILE,"a_file");
while (<FILE>) {
If you have ptys, you could arrange to run the command on a pty and
avoid the deadlock problem. See the expect.pl package released
by Randal Schwartz <merlyn@iwarp.intel.com> for ways to do this.
At the risk of deadlock, it is theoretically possible to use a
fork, two pipe calls, and an exec to manually set up the two-way
pipe. (BSD system may use socketpair() in place of the two pipes,
but this is not as portable.)
Here's one example of this that assumes it's going to talk to
something like adb, both writing to it and reading from it. This
is presumably safe because you "know" that commands like adb will
read a line at a time and output a line at a time. Programs like
sort that read their entire input stream first, however, are quite
apt to cause deadlock.
Use this way:
require 'open2.pl';
$child = &open2(RDR,WTR,"some cmd to run and its args");
Unqualified filehandles will be interpreted in their caller's package,
although &open2 lives in its open package (to protect its state data).
It returns the child process's pid if successful, and generally
dies if unsuccessful. You may wish to change the dies to warnings,
or trap the call in an eval. You should also flush STDOUT before
calling this.
# &open2: tom christiansen, <tchrist@convex.com>
#
# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
#
# spawn the given $cmd and connect $rdr for
# reading and $wtr for writing. return pid
# of child, or 0 on failure.
#
# WARNING: this is dangerous, as you may block forever
# unless you are very careful.
#
# $wtr is left unbuffered.
#
# abort program if
# rdr or wtr are null
# pipe or fork or exec fails
package open2;
$fh = 'FHOPEN000'; # package static in case called more than once
sub main'open2 {
local($kidpid);
local($dad_rdr, $dad_wtr, $cmd) = @_;
$dad_rdr ne '' || die "open2: rdr should not be null";
$dad_wtr ne '' || die "open2: wtr should not be null";
# force unqualified filehandles into callers' package
local($package) = caller;
$dad_rdr =~ s/^[^']+$/$package'$&/;
$dad_wtr =~ s/^[^']+$/$package'$&/;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!";
pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!";
if (($kidpid = fork) < 0) {
die "open2: fork failed: $!";
} elsif ($kidpid == 0) {
close $dad_rdr; close $dad_wtr;
open(STDIN, ">&$kid_rdr");
open(STDOUT, ">&$kid_wtr");
print STDERR "execing $cmd\n";
exec $cmd;
die "open2: exec of $cmd failed";
}
close $kid_rdr; close $kid_wtr;
select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
$kidpid;
}
1; # so require is happy