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 <[email protected]>
|
---|
93 | # derived mostly from &open2 by tom christiansen, <[email protected]>
|
---|
94 | # fixed for 5.001 by Ulrich Kunitz <[email protected]>
|
---|
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 <[email protected]>
|
---|
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
|
---|