1package IPC::Open3; 2 3use strict; 4no strict 'refs'; # because users pass me bareword filehandles 5our ($VERSION, @ISA, @EXPORT); 6 7require Exporter; 8 9use Carp; 10use Symbol qw(gensym qualify); 11 12$VERSION = 1.02; 13@ISA = qw(Exporter); 14@EXPORT = qw(open3); 15 16=head1 NAME 17 18IPC::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 31Extremely similar to open2(), open3() spawns the given $cmd and 32connects CHLD_OUT for reading from the child, CHLD_IN for writing to 33the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the 34same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child 35are on the same filehandle. The CHLD_IN will have autoflush turned 36on. 37 38If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the 39parent, and the child will read from it directly. If CHLD_OUT or 40CHLD_ERR begins with C<< >& >>, then the child will send output 41directly to that filehandle. In both cases, there will be a dup(2) 42instead of a pipe(2) made. 43 44If either reader or writer is the null string, this will be replaced 45by an autogenerated filehandle. If so, you must pass a valid lvalue 46in the parameter slot so it can be overwritten in the caller, or 47an exception will be raised. 48 49The filehandles may also be integers, in which case they are understood 50as file descriptors. 51 52open3() returns the process ID of the child process. It doesn't return on 53failure: it just raises an exception matching C</^open3:/>. However, 54C<exec> failures in the child are not detected. You'll have to 55trap SIGPIPE yourself. 56 57Note if you specify C<-> as the command, in an analogous fashion to 58C<open(FOO, "-|")> the child process will just be the forked Perl 59process rather than an external command. This feature isn't yet 60supported on Win32 platforms. 61 62open3() does not wait for and reap the child process after it exits. 63Except for short programs where it's acceptable to let the operating system 64take care of this, you need to do this yourself. This is normally as 65simple as calling C<waitpid $pid, 0> when you're done with the process. 66Failing to do this can result in an accumulation of defunct or "zombie" 67processes. See L<perlfunc/waitpid> for more information. 68 69If you try to read from the child's stdout writer and their stderr 70writer, you'll have problems with blocking, which means you'll want 71to use select() or the IO::Select, which means you'd best use 72sysread() instead of readline() for normal stuff. 73 74This is very dangerous, as you may block forever. It assumes it's 75going to talk to something like B<bc>, both writing to it and reading 76from it. This is presumably safe because you "know" that commands 77like B<bc> will read a line at a time and output a line at a time. 78Programs like B<sort> that read their entire input stream first, 79however, are quite apt to cause deadlock. 80 81The big problem with this approach is that if you don't have control 82over source code being run in the child process, you can't control 83what it does with pipe buffering. Thus you can't just open a pipe to 84C<cat -v> and continually read and write a line from it. 85 86=head1 WARNING 87 88The 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.pm,v 1.9 2006/03/28 19:23:07 millert 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 126our $Me = 'open3 (bug)'; # you should never see this, it's always localized 127 128# Fatal.pm needs to be fixed WRT prototypes. 129 130sub xfork { 131 my $pid = fork; 132 defined $pid or croak "$Me: fork failed: $!"; 133 return $pid; 134} 135 136sub 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 143sub xopen { 144 open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!"; 145} 146 147sub xclose { 148 close $_[0] or croak "$Me: close($_[0]) failed: $!"; 149} 150 151sub fh_is_fd { 152 return $_[0] =~ /\A=?(\d+)\z/; 153} 154 155sub xfileno { 156 return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd 157 return fileno $_[0]; 158} 159 160my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; 161 162sub _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 302sub open3 { 303 if (@_ < 4) { 304 local $" = ', '; 305 croak "open3(@_): not enough arguments"; 306 } 307 return _open3 'open3', scalar caller, @_ 308} 309 310sub 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 3491; # so require is happy 350