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