ext/IO/lib/IO/Pipe.pm

   1 # IO::Pipe.pm
   2 #
   3 # Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
   4 # This program is free software; you can redistribute it and/or
   5 # modify it under the same terms as Perl itself.
   6
   7 package IO::Pipe;
   8
   9 use 5.006_001;
  10
  11 use IO::Handle;
  12 use strict;
  13 our($VERSION);
  14 use Carp;
  15 use Symbol;
  16
  17 $VERSION = "1.122";
  18
  19 sub new {
  20     my $type = shift;
  21     my $class = ref($type) || $type || "IO::Pipe";
  22     @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
  23
  24     my $me = bless gensym(), $class;
  25
  26     my($readfh,$writefh) = @_ ? @_ : $me->handles;
  27
  28     pipe($readfh, $writefh)
  29         or return undef;
  30
  31     @{*$me} = ($readfh, $writefh);
  32
  33     $me;
  34 }
  35
  36 sub handles {
  37     @_ == 1 or croak 'usage: $pipe->handles()';
  38     (IO::Pipe::End->new(), IO::Pipe::End->new());
  39 }
  40
  41 my $do_spawn = $^O eq 'os2';
  42
  43 sub _doit {
  44     my $me = shift;
  45     my $rw = shift;
  46
  47     my $pid = $do_spawn ? 0 : fork();
  48
  49     if($pid) { # Parent
  50         return $pid;
  51     }
  52     elsif(defined $pid) { # Child or spawn
  53         my $fh;
  54         my $io = $rw ? \*STDIN : \*STDOUT;
  55         my ($mode, $save) = $rw ? "r" : "w";
  56         if ($do_spawn) {
  57           require Fcntl;
  58           $save = IO::Handle->new_from_fd($io, $mode);
  59           # Close in child:
  60           fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
  61           $fh = $rw ? ${*$me}[0] : ${*$me}[1];
  62         } else {
  63           shift;
  64           $fh = $rw ? $me->reader() : $me->writer(); # close the other end
  65         }
  66         bless $io, "IO::Handle";
  67         $io->fdopen($fh, $mode);
  68         $fh->close;
  69
  70         if ($do_spawn) {
  71           $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
  72           my $err = $!;
  73
  74           $io->fdopen($save, $mode);
  75           $save->close or croak "Cannot close $!";
  76           croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
  77           return $pid;
  78         } else {
  79           exec @_ or
  80             croak "IO::Pipe: Cannot exec: $!";
  81         }
  82     }
  83     else {
  84         croak "IO::Pipe: Cannot fork: $!";
  85     }
  86
  87     # NOT Reached
  88 }
  89
  90 sub reader {
  91     @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
  92     my $me = shift;
  93
  94     return undef
  95         unless(ref($me) || ref($me = $me->new));
  96
  97     my $fh  = ${*$me}[0];
  98     my $pid = $me->_doit(0, $fh, @_)
  99         if(@_);
 100
 101     close ${*$me}[1];
 102     bless $me, ref($fh);
 103     *$me = *$fh;          # Alias self to handle
 104     $me->fdopen($fh->fileno,"r")
 105         unless defined($me->fileno);
 106     bless $fh;                  # Really wan't un-bless here
 107     ${*$me}{'io_pipe_pid'} = $pid
 108         if defined $pid;
 109
 110     $me;
 111 }
 112
 113 sub writer {
 114     @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
 115     my $me = shift;
 116
 117     return undef
 118         unless(ref($me) || ref($me = $me->new));
 119
 120     my $fh  = ${*$me}[1];
 121     my $pid = $me->_doit(1, $fh, @_)
 122         if(@_);
 123
 124     close ${*$me}[0];
 125     bless $me, ref($fh);
 126     *$me = *$fh;          # Alias self to handle
 127     $me->fdopen($fh->fileno,"w")
 128         unless defined($me->fileno);
 129     bless $fh;                  # Really wan't un-bless here
 130     ${*$me}{'io_pipe_pid'} = $pid
 131         if defined $pid;
 132
 133     $me;
 134 }
 135
 136 package IO::Pipe::End;
 137
 138 our(@ISA);
 139
 140 @ISA = qw(IO::Handle);
 141
 142 sub close {
 143     my $fh = shift;
 144     my $r = $fh->SUPER::close(@_);
 145
 146     waitpid(${*$fh}{'io_pipe_pid'},0)
 147         if(defined ${*$fh}{'io_pipe_pid'});
 148
 149     $r;
 150 }
 151
 152 1;
 153
 154 __END__
 155
 156 =head1 NAME
 157
 158 IO::Pipe - supply object methods for pipes
 159
 160 =head1 SYNOPSIS
 161
 162         use IO::Pipe;
 163
 164         $pipe = new IO::Pipe;
 165
 166         if($pid = fork()) { # Parent
 167             $pipe->reader();
 168
 169             while(<$pipe> {
 170                 ....
 171             }
 172
 173         }
 174         elsif(defined $pid) { # Child
 175             $pipe->writer();
 176
 177             print $pipe ....
 178         }
 179
 180         or
 181
 182         $pipe = new IO::Pipe;
 183
 184         $pipe->reader(qw(ls -l));
 185
 186         while(<$pipe>) {
 187             ....
 188         }
 189
 190 =head1 DESCRIPTION
 191
 192 C<IO::Pipe> provides an interface to creating pipes between
 193 processes.
 194
 195 =head1 CONSTRUCTOR
 196
 197 =over 4
 198
 199 =item new ( [READER, WRITER] )
 200
 201 Creates an C<IO::Pipe>, which is a reference to a newly created symbol
 202 (see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
 203 arguments, which should be objects blessed into C<IO::Handle>, or a
 204 subclass thereof. These two objects will be used for the system call
 205 to C<pipe>. If no arguments are given then method C<handles> is called
 206 on the new C<IO::Pipe> object.
 207
 208 These two handles are held in the array part of the GLOB until either
 209 C<reader> or C<writer> is called.
 210
 211 =back
 212
 213 =head1 METHODS
 214
 215 =over 4
 216
 217 =item reader ([ARGS])
 218
 219 The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
 220 handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
 221 is called and C<ARGS> are passed to exec.
 222
 223 =item writer ([ARGS])
 224
 225 The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
 226 handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
 227 is called and C<ARGS> are passed to exec.
 228
 229 =item handles ()
 230
 231 This method is called during construction by C<IO::Pipe::new>
 232 on the newly created C<IO::Pipe> object. It returns an array of two objects
 233 blessed into C<IO::Pipe::End>, or a subclass thereof.
 234
 235 =back
 236
 237 =head1 SEE ALSO
 238
 239 L<IO::Handle>
 240
 241 =head1 AUTHOR
 242
 243 Graham Barr. Currently maintained by the Perl Porters.  Please report all
 244 bugs to <perl5-porters@perl.org>.
 245
 246 =head1 COPYRIGHT
 247
 248 Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
 249 This program is free software; you can redistribute it and/or
 250 modify it under the same terms as Perl itself.
 251
 252 =cut