ext/IO/lib/IO/Pipe.pm

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