240 lines
4.9 KiB
Perl
240 lines
4.9 KiB
Perl
# IO::Pipe.pm
|
|
#
|
|
# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
|
|
# reserved. This program is free software; you can redistribute it and/or
|
|
# modify it under the same terms as Perl itself.
|
|
|
|
package IO::Pipe;
|
|
|
|
require 5.000;
|
|
|
|
use IO::Handle;
|
|
use strict;
|
|
use vars qw($VERSION);
|
|
use Carp;
|
|
use Symbol;
|
|
|
|
$VERSION = "1.0902";
|
|
|
|
sub new {
|
|
my $type = shift;
|
|
my $class = ref($type) || $type || "IO::Pipe";
|
|
@_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
|
|
|
|
my $me = bless gensym(), $class;
|
|
|
|
my($readfh,$writefh) = @_ ? @_ : $me->handles;
|
|
|
|
pipe($readfh, $writefh)
|
|
or return undef;
|
|
|
|
@{*$me} = ($readfh, $writefh);
|
|
|
|
$me;
|
|
}
|
|
|
|
sub handles {
|
|
@_ == 1 or croak 'usage: $pipe->handles()';
|
|
(IO::Pipe::End->new(), IO::Pipe::End->new());
|
|
}
|
|
|
|
my $do_spawn = $^O eq 'os2';
|
|
|
|
sub _doit {
|
|
my $me = shift;
|
|
my $rw = shift;
|
|
|
|
my $pid = $do_spawn ? 0 : fork();
|
|
|
|
if($pid) { # Parent
|
|
return $pid;
|
|
}
|
|
elsif(defined $pid) { # Child or spawn
|
|
my $fh;
|
|
my $io = $rw ? \*STDIN : \*STDOUT;
|
|
my ($mode, $save) = $rw ? "r" : "w";
|
|
if ($do_spawn) {
|
|
require Fcntl;
|
|
$save = IO::Handle->new_from_fd($io, $mode);
|
|
# Close in child:
|
|
fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
|
|
$fh = $rw ? ${*$me}[0] : ${*$me}[1];
|
|
} else {
|
|
shift;
|
|
$fh = $rw ? $me->reader() : $me->writer(); # close the other end
|
|
}
|
|
bless $io, "IO::Handle";
|
|
$io->fdopen($fh, $mode);
|
|
$fh->close;
|
|
|
|
if ($do_spawn) {
|
|
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
|
|
my $err = $!;
|
|
|
|
$io->fdopen($save, $mode);
|
|
$save->close or croak "Cannot close $!";
|
|
croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
|
|
return $pid;
|
|
} else {
|
|
exec @_ or
|
|
croak "IO::Pipe: Cannot exec: $!";
|
|
}
|
|
}
|
|
else {
|
|
croak "IO::Pipe: Cannot fork: $!";
|
|
}
|
|
|
|
# NOT Reached
|
|
}
|
|
|
|
sub reader {
|
|
@_ >= 1 or croak 'usage: $pipe->reader()';
|
|
my $me = shift;
|
|
my $fh = ${*$me}[0];
|
|
my $pid = $me->_doit(0, $fh, @_)
|
|
if(@_);
|
|
|
|
close ${*$me}[1];
|
|
bless $me, ref($fh);
|
|
*$me = *$fh; # Alias self to handle
|
|
bless $fh; # Really wan't un-bless here
|
|
${*$me}{'io_pipe_pid'} = $pid
|
|
if defined $pid;
|
|
|
|
$me;
|
|
}
|
|
|
|
sub writer {
|
|
@_ >= 1 or croak 'usage: $pipe->writer()';
|
|
my $me = shift;
|
|
my $fh = ${*$me}[1];
|
|
my $pid = $me->_doit(1, $fh, @_)
|
|
if(@_);
|
|
|
|
close ${*$me}[0];
|
|
bless $me, ref($fh);
|
|
*$me = *$fh; # Alias self to handle
|
|
bless $fh; # Really wan't un-bless here
|
|
${*$me}{'io_pipe_pid'} = $pid
|
|
if defined $pid;
|
|
|
|
$me;
|
|
}
|
|
|
|
package IO::Pipe::End;
|
|
|
|
use vars qw(@ISA);
|
|
|
|
@ISA = qw(IO::Handle);
|
|
|
|
sub close {
|
|
my $fh = shift;
|
|
my $r = $fh->SUPER::close(@_);
|
|
|
|
waitpid(${*$fh}{'io_pipe_pid'},0)
|
|
if(defined ${*$fh}{'io_pipe_pid'});
|
|
|
|
$r;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
IO::pipe - supply object methods for pipes
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use IO::Pipe;
|
|
|
|
$pipe = new IO::Pipe;
|
|
|
|
if($pid = fork()) { # Parent
|
|
$pipe->reader();
|
|
|
|
while(<$pipe> {
|
|
....
|
|
}
|
|
|
|
}
|
|
elsif(defined $pid) { # Child
|
|
$pipe->writer();
|
|
|
|
print $pipe ....
|
|
}
|
|
|
|
or
|
|
|
|
$pipe = new IO::Pipe;
|
|
|
|
$pipe->reader(qw(ls -l));
|
|
|
|
while(<$pipe>) {
|
|
....
|
|
}
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<IO::Pipe> provides an interface to creating pipes between
|
|
processes.
|
|
|
|
=head1 CONSTRUCTOR
|
|
|
|
=over 4
|
|
|
|
=item new ( [READER, WRITER] )
|
|
|
|
Creates a C<IO::Pipe>, which is a reference to a newly created symbol
|
|
(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
|
|
arguments, which should be objects blessed into C<IO::Handle>, or a
|
|
subclass thereof. These two objects will be used for the system call
|
|
to C<pipe>. If no arguments are given then method C<handles> is called
|
|
on the new C<IO::Pipe> object.
|
|
|
|
These two handles are held in the array part of the GLOB until either
|
|
C<reader> or C<writer> is called.
|
|
|
|
=back
|
|
|
|
=head1 METHODS
|
|
|
|
=over 4
|
|
|
|
=item reader ([ARGS])
|
|
|
|
The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
|
|
handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
|
|
is called and C<ARGS> are passed to exec.
|
|
|
|
=item writer ([ARGS])
|
|
|
|
The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
|
|
handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
|
|
is called and C<ARGS> are passed to exec.
|
|
|
|
=item handles ()
|
|
|
|
This method is called during construction by C<IO::Pipe::new>
|
|
on the newly created C<IO::Pipe> object. It returns an array of two objects
|
|
blessed into C<IO::Pipe::End>, or a subclass thereof.
|
|
|
|
=back
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<IO::Handle>
|
|
|
|
=head1 AUTHOR
|
|
|
|
Graham Barr <bodg@tiuk.ti.com>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
|
|
software; you can redistribute it and/or modify it under the same terms
|
|
as Perl itself.
|
|
|
|
=cut
|