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