This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add IO-1.20; mess with t/lib/io_*.t in an attempt to
[perl5.git] / 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 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.12";
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 use vars qw(@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 createing pipes between
193 processes.
194
195 =head1 CONSTRCUTOR
196
197 =over 4
198
199 =item new ( [READER, WRITER] )
200
201 Creates a 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 <gbarr@pobox.com>
244
245 =head1 COPYRIGHT
246
247 Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
248 This program is free software; you can redistribute it and/or
249 modify it under the same terms as Perl itself.
250
251 =cut