Move IO from ext/ to dist/
[perl.git] / dist / 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.13";
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