This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ae6d9a547e2819fc4fec3e1333cd29442dfcf2d0
[perl5.git] / 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.0901";
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 createing pipes between
181 processes.
182
183 =head1 CONSTRCUTOR
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