This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: Documentation change for IPC::Open*.pm
[perl5.git] / lib / IPC / Open3.pm
1 package IPC::Open3;
2
3 use strict;
4 no strict 'refs'; # because users pass me bareword filehandles
5 our ($VERSION, @ISA, @EXPORT);
6
7 require Exporter;
8
9 use Carp;
10 use Symbol qw(gensym qualify);
11
12 $VERSION        = 1.02;
13 @ISA            = qw(Exporter);
14 @EXPORT         = qw(open3);
15
16 =head1 NAME
17
18 IPC::Open3, open3 - open a process for reading, writing, and error handling
19
20 =head1 SYNOPSIS
21
22     $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR,
23                     'some cmd and args', 'optarg', ...);
24
25     my($wtr, $rdr, $err);
26     $pid = open3($wtr, $rdr, $err,
27                     'some cmd and args', 'optarg', ...);
28
29 =head1 DESCRIPTION
30
31 Extremely similar to open2(), open3() spawns the given $cmd and
32 connects CHLD_OUT for reading from the child, CHLD_IN for writing to
33 the child, and CHLD_ERR for errors.  If CHLD_ERR is false, or the
34 same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child
35 are on the same filehandle.  The CHLD_IN will have autoflush turned
36 on.
37
38 If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the
39 parent, and the child will read from it directly.  If CHLD_OUT or
40 CHLD_ERR begins with C<< >& >>, then the child will send output
41 directly to that filehandle.  In both cases, there will be a dup(2)
42 instead of a pipe(2) made.
43
44 If either reader or writer is the null string, this will be replaced
45 by an autogenerated filehandle.  If so, you must pass a valid lvalue
46 in the parameter slot so it can be overwritten in the caller, or 
47 an exception will be raised.
48
49 The filehandles may also be integers, in which case they are understood
50 as file descriptors.
51
52 open3() returns the process ID of the child process.  It doesn't return on
53 failure: it just raises an exception matching C</^open3:/>.  However,
54 C<exec> failures in the child are not detected.  You'll have to 
55 trap SIGPIPE yourself.
56
57 Note if you specify C<-> as the command, in an analogous fashion to
58 C<open(FOO, "-|")> the child process will just be the forked Perl
59 process rather than an external command.  This feature isn't yet
60 supported on Win32 platforms.
61
62 open3() does not wait for and reap the child process after it exits.  
63 Except for short programs where it's acceptable to let the operating system
64 take care of this, you need to do this yourself.  This is normally as 
65 simple as calling C<waitpid $pid, 0> when you're done with the process.
66 Failing to do this can result in an accumulation of defunct or "zombie"
67 processes.  See L<perlfunc/waitpid> for more information.
68
69 If you try to read from the child's stdout writer and their stderr
70 writer, you'll have problems with blocking, which means you'll want
71 to use select() or the IO::Select, which means you'd best use
72 sysread() instead of readline() for normal stuff.
73
74 This is very dangerous, as you may block forever.  It assumes it's
75 going to talk to something like B<bc>, both writing to it and reading
76 from it.  This is presumably safe because you "know" that commands
77 like B<bc> will read a line at a time and output a line at a time.
78 Programs like B<sort> that read their entire input stream first,
79 however, are quite apt to cause deadlock.
80
81 The big problem with this approach is that if you don't have control
82 over source code being run in the child process, you can't control
83 what it does with pipe buffering.  Thus you can't just open a pipe to
84 C<cat -v> and continually read and write a line from it.
85
86 =head1 WARNING
87
88 The order of arguments differs from that of open2().
89
90 =cut
91
92 # &open3: Marc Horowitz <marc@mit.edu>
93 # derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
94 # fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
95 # ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
96 # fixed for autovivving FHs, tchrist again
97 # allow fd numbers to be used, by Frank Tobin
98 # allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
99 #
100 # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
101 #
102 # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
103 #
104 # spawn the given $cmd and connect rdr for
105 # reading, wtr for writing, and err for errors.
106 # if err is '', or the same as rdr, then stdout and
107 # stderr of the child are on the same fh.  returns pid
108 # of child (or dies on failure).
109
110
111 # if wtr begins with '<&', then wtr will be closed in the parent, and
112 # the child will read from it directly.  if rdr or err begins with
113 # '>&', then the child will send output directly to that fd.  In both
114 # cases, there will be a dup() instead of a pipe() made.
115
116
117 # WARNING: this is dangerous, as you may block forever
118 # unless you are very careful.
119 #
120 # $wtr is left unbuffered.
121 #
122 # abort program if
123 #   rdr or wtr are null
124 #   a system call fails
125
126 our $Me = 'open3 (bug)';        # you should never see this, it's always localized
127
128 # Fatal.pm needs to be fixed WRT prototypes.
129
130 sub xfork {
131     my $pid = fork;
132     defined $pid or croak "$Me: fork failed: $!";
133     return $pid;
134 }
135
136 sub xpipe {
137     pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
138 }
139
140 # I tried using a * prototype character for the filehandle but it still
141 # disallows a bearword while compiling under strict subs.
142
143 sub xopen {
144     open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
145 }
146
147 sub xclose {
148     close $_[0] or croak "$Me: close($_[0]) failed: $!";
149 }
150
151 sub fh_is_fd {
152     return $_[0] =~ /\A=?(\d+)\z/;
153 }
154
155 sub xfileno {
156     return $1 if $_[0] =~ /\A=?(\d+)\z/;  # deal with fh just being an fd
157     return fileno $_[0];
158 }
159
160 my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
161
162 sub _open3 {
163     local $Me = shift;
164     my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
165     my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
166
167     # simulate autovivification of filehandles because
168     # it's too ugly to use @_ throughout to make perl do it for us
169     # tchrist 5-Mar-00
170
171     unless (eval  {
172         $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
173         $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
174         1; }) 
175     {
176         # must strip crud for croak to add back, or looks ugly
177         $@ =~ s/(?<=value attempted) at .*//s;
178         croak "$Me: $@";
179     } 
180
181     $dad_err ||= $dad_rdr;
182
183     $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
184     $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
185     $dup_err = ($dad_err =~ s/^[<>]&//);
186
187     # force unqualified filehandles into caller's package
188     $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr);
189     $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr);
190     $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err);
191
192     my $kid_rdr = gensym;
193     my $kid_wtr = gensym;
194     my $kid_err = gensym;
195
196     xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
197     xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
198     xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
199
200     $kidpid = $do_spawn ? -1 : xfork;
201     if ($kidpid == 0) {         # Kid
202         # A tie in the parent should not be allowed to cause problems.
203         untie *STDIN;
204         untie *STDOUT;
205         # If she wants to dup the kid's stderr onto her stdout I need to
206         # save a copy of her stdout before I put something else there.
207         if ($dad_rdr ne $dad_err && $dup_err
208                 && xfileno($dad_err) == fileno(STDOUT)) {
209             my $tmp = gensym;
210             xopen($tmp, ">&$dad_err");
211             $dad_err = $tmp;
212         }
213
214         if ($dup_wtr) {
215             xopen \*STDIN,  "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
216         } else {
217             xclose $dad_wtr;
218             xopen \*STDIN,  "<&=" . fileno $kid_rdr;
219         }
220         if ($dup_rdr) {
221             xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
222         } else {
223             xclose $dad_rdr;
224             xopen \*STDOUT, ">&=" . fileno $kid_wtr;
225         }
226         if ($dad_rdr ne $dad_err) {
227             if ($dup_err) {
228                 # I have to use a fileno here because in this one case
229                 # I'm doing a dup but the filehandle might be a reference
230                 # (from the special case above).
231                 xopen \*STDERR, ">&" . xfileno($dad_err)
232                     if fileno(STDERR) != xfileno($dad_err);
233             } else {
234                 xclose $dad_err;
235                 xopen \*STDERR, ">&=" . fileno $kid_err;
236             }
237         } else {
238             xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
239         }
240         if ($cmd[0] eq '-') {
241             croak "Arguments don't make sense when the command is '-'"
242               if @cmd > 1;
243             return 0;
244         }
245         local($")=(" ");
246         exec @cmd # XXX: wrong process to croak from
247             or croak "$Me: exec of @cmd failed";
248     } elsif ($do_spawn) {
249         # All the bookkeeping of coincidence between handles is
250         # handled in spawn_with_handles.
251
252         my @close;
253         if ($dup_wtr) {
254           $kid_rdr = \*{$dad_wtr};
255           push @close, $kid_rdr;
256         } else {
257           push @close, \*{$dad_wtr}, $kid_rdr;
258         }
259         if ($dup_rdr) {
260           $kid_wtr = \*{$dad_rdr};
261           push @close, $kid_wtr;
262         } else {
263           push @close, \*{$dad_rdr}, $kid_wtr;
264         }
265         if ($dad_rdr ne $dad_err) {
266             if ($dup_err) {
267               $kid_err = \*{$dad_err};
268               push @close, $kid_err;
269             } else {
270               push @close, \*{$dad_err}, $kid_err;
271             }
272         } else {
273           $kid_err = $kid_wtr;
274         }
275         require IO::Pipe;
276         $kidpid = eval {
277             spawn_with_handles( [ { mode => 'r',
278                                     open_as => $kid_rdr,
279                                     handle => \*STDIN },
280                                   { mode => 'w',
281                                     open_as => $kid_wtr,
282                                     handle => \*STDOUT },
283                                   { mode => 'w',
284                                     open_as => $kid_err,
285                                     handle => \*STDERR },
286                                 ], \@close, @cmd);
287         };
288         die "$Me: $@" if $@;
289     }
290
291     xclose $kid_rdr if !$dup_wtr;
292     xclose $kid_wtr if !$dup_rdr;
293     xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
294     # If the write handle is a dup give it away entirely, close my copy
295     # of it.
296     xclose $dad_wtr if $dup_wtr;
297
298     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
299     $kidpid;
300 }
301
302 sub open3 {
303     if (@_ < 4) {
304         local $" = ', ';
305         croak "open3(@_): not enough arguments";
306     }
307     return _open3 'open3', scalar caller, @_
308 }
309
310 sub spawn_with_handles {
311     my $fds = shift;            # Fields: handle, mode, open_as
312     my $close_in_child = shift;
313     my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
314     require Fcntl;
315
316     foreach $fd (@$fds) {
317         $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
318         $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
319     }
320     foreach $fd (@$fds) {
321         bless $fd->{handle}, 'IO::Handle'
322             unless eval { $fd->{handle}->isa('IO::Handle') } ;
323         # If some of handles to redirect-to coincide with handles to
324         # redirect, we need to use saved variants:
325         $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
326                               $fd->{mode});
327     }
328     unless ($^O eq 'MSWin32') {
329         # Stderr may be redirected below, so we save the err text:
330         foreach $fd (@$close_in_child) {
331             fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
332                 unless $saved{fileno $fd}; # Do not close what we redirect!
333         }
334     }
335
336     unless (@errs) {
337         $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
338         push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
339     }
340
341     foreach $fd (@$fds) {
342         $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
343         $fd->{tmp_copy}->close or croak "Can't close: $!";
344     }
345     croak join "\n", @errs if @errs;
346     return $pid;
347 }
348
349 1; # so require is happy