From 779e71f16ca01a6244b632b95bdb461fec163b34 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 17 Feb 2011 17:56:54 +0000 Subject: New tlperl part XIII git-svn-id: svn://tug.org/texlive/trunk@21435 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/IO/Pipe.pm | 257 +++++++++++++++++++++++++++++++++++++ 1 file changed, 257 insertions(+) create mode 100644 Master/tlpkg/tlperl/lib/IO/Pipe.pm (limited to 'Master/tlpkg/tlperl/lib/IO/Pipe.pm') diff --git a/Master/tlpkg/tlperl/lib/IO/Pipe.pm b/Master/tlpkg/tlperl/lib/IO/Pipe.pm new file mode 100644 index 00000000000..827cc48bfcd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Pipe.pm @@ -0,0 +1,257 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996-8 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. + +package IO::Pipe; + +use 5.006_001; + +use IO::Handle; +use strict; +our($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.13"; + +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' || $^O eq 'MSWin32'; + +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); + my $handle = shift; + # Close in child: + unless ($^O eq 'MSWin32') { + fcntl($handle, 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( [SUB_COMMAND_ARGS] )'; + my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + + my $fh = ${*$me}[0]; + my $pid; + $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"r") + unless defined($me->fileno); + 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( [SUB_COMMAND_ARGS] )'; + my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + + my $fh = ${*$me}[1]; + my $pid; + $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"w") + unless defined($me->fileno); + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +our(@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 provides an interface to creating pipes between +processes. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates an C, which is a reference to a newly created symbol +(see the C package). C optionally takes two +arguments, which should be objects blessed into C, or a +subclass thereof. These two objects will be used for the system call +to C. If no arguments are given then method C is called +on the new C object. + +These two handles are held in the array part of the GLOB until either +C or C is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the reading end of the pipe. If C are given then C +is called and C are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the writing end of the pipe. If C are given then C +is called and C are passed to exec. + +=item handles () + +This method is called during construction by C +on the newly created C object. It returns an array of two objects +blessed into C, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to . + +=head1 COPYRIGHT + +Copyright (c) 1996-8 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 -- cgit v1.2.3