1package IPC::Open3; 2 3use strict; 4no strict 'refs'; # because users pass me bareword filehandles 5 6use Exporter 'import'; 7 8use Carp; 9use Symbol qw(gensym qualify); 10 11our $VERSION = '1.22'; 12our @EXPORT = qw(open3); 13 14=head1 NAME 15 16IPC::Open3 - open a process for reading, writing, and error handling using open3() 17 18=head1 SYNOPSIS 19 20 use Symbol 'gensym'; # vivify a separate handle for STDERR 21 my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym, 22 'some', 'cmd', 'and', 'args'); 23 # or pass the command through the shell 24 my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym, 25 'some cmd and args'); 26 27 # read from parent STDIN 28 # send STDOUT and STDERR to already open handle 29 open my $outfile, '>>', 'output.txt' or die "open failed: $!"; 30 my $pid = open3('<&STDIN', $outfile, undef, 31 'some', 'cmd', 'and', 'args'); 32 33 # write to parent STDOUT and STDERR 34 my $pid = open3(my $chld_in, '>&STDOUT', '>&STDERR', 35 'some', 'cmd', 'and', 'args'); 36 37 # reap zombie and retrieve exit status 38 waitpid( $pid, 0 ); 39 my $child_exit_status = $? >> 8; 40 41=head1 DESCRIPTION 42 43Extremely similar to open2(), open3() spawns the given command and 44connects $chld_out for reading from the child, $chld_in for writing to 45the child, and $chld_err for errors. If $chld_err is false, or the 46same file descriptor as $chld_out, then STDOUT and STDERR of the child 47are on the same filehandle. This means that an autovivified lexical 48cannot be used for the STDERR filehandle, but gensym from L<Symbol> can 49be used to vivify a new glob reference, see L</SYNOPSIS>. The $chld_in 50will have autoflush turned on. 51 52If $chld_in begins with C<< <& >>, then $chld_in will be closed in the 53parent, and the child will read from it directly. If $chld_out or 54$chld_err begins with C<< >& >>, then the child will send output 55directly to that filehandle. In both cases, there will be a L<dup(2)> 56instead of a L<pipe(2)> made. 57 58If either reader or writer is the empty string or undefined, this will 59be replaced by an autogenerated filehandle. If so, you must pass a 60valid lvalue in the parameter slot so it can be overwritten in the 61caller, or an exception will be raised. 62 63The filehandles may also be integers, in which case they are understood 64as file descriptors. 65 66open3() returns the process ID of the child process. It doesn't return on 67failure: it just raises an exception matching C</^open3:/>. However, 68C<exec> failures in the child (such as no such file or permission denied), 69are just reported to $chld_err under Windows and OS/2, as it is not possible 70to trap them. 71 72If the child process dies for any reason, the next write to $chld_in is 73likely to generate a SIGPIPE in the parent, which is fatal by default. 74So you may wish to handle this signal. 75 76Note if you specify C<-> as the command, in an analogous fashion to 77C<open(my $fh, "-|")> the child process will just be the forked Perl 78process rather than an external command. This feature isn't yet 79supported on Win32 platforms. 80 81open3() does not wait for and reap the child process after it exits. 82Except for short programs where it's acceptable to let the operating system 83take care of this, you need to do this yourself. This is normally as 84simple as calling C<waitpid $pid, 0> when you're done with the process. 85Failing to do this can result in an accumulation of defunct or "zombie" 86processes. See L<perlfunc/waitpid> for more information. 87 88If you try to read from the child's stdout writer and their stderr 89writer, you'll have problems with blocking, which means you'll want 90to use select() or L<IO::Select>, which means you'd best use 91sysread() instead of readline() for normal stuff. 92 93This is very dangerous, as you may block forever. It assumes it's 94going to talk to something like L<bc(1)>, both writing to it and reading 95from it. This is presumably safe because you "know" that commands 96like L<bc(1)> will read a line at a time and output a line at a time. 97Programs like L<sort(1)> that read their entire input stream first, 98however, are quite apt to cause deadlock. 99 100The big problem with this approach is that if you don't have control 101over source code being run in the child process, you can't control 102what it does with pipe buffering. Thus you can't just open a pipe to 103C<cat -v> and continually read and write a line from it. 104 105=head1 See Also 106 107=over 4 108 109=item L<IPC::Open2> 110 111Like Open3 but without STDERR capture. 112 113=item L<IPC::Run> 114 115This is a CPAN module that has better error handling and more facilities 116than Open3. 117 118=back 119 120=head1 WARNING 121 122The order of arguments differs from that of open2(). 123 124=cut 125 126# &open3: Marc Horowitz <marc@mit.edu> 127# derived mostly from &open2 by tom christiansen, <tchrist@convex.com> 128# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com> 129# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career 130# fixed for autovivving FHs, tchrist again 131# allow fd numbers to be used, by Frank Tobin 132# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org> 133# 134# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); 135# 136# spawn the given $cmd and connect rdr for 137# reading, wtr for writing, and err for errors. 138# if err is '', or the same as rdr, then stdout and 139# stderr of the child are on the same fh. returns pid 140# of child (or dies on failure). 141 142 143# if wtr begins with '<&', then wtr will be closed in the parent, and 144# the child will read from it directly. if rdr or err begins with 145# '>&', then the child will send output directly to that fd. In both 146# cases, there will be a dup() instead of a pipe() made. 147 148 149# WARNING: this is dangerous, as you may block forever 150# unless you are very careful. 151# 152# $wtr is left unbuffered. 153# 154# abort program if 155# rdr or wtr are null 156# a system call fails 157 158our $Me = 'open3 (bug)'; # you should never see this, it's always localized 159 160# Fatal.pm needs to be fixed WRT prototypes. 161 162sub xpipe { 163 pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!"; 164} 165 166# I tried using a * prototype character for the filehandle but it still 167# disallows a bareword while compiling under strict subs. 168 169sub xopen { 170 open $_[0], $_[1], @_[2..$#_] and return; 171 local $" = ', '; 172 carp "$Me: open(@_) failed: $!"; 173} 174 175sub xclose { 176 $_[0] =~ /\A=?(\d+)\z/ 177 ? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); } 178 : close $_[0] 179 or croak "$Me: close($_[0]) failed: $!"; 180} 181 182sub xfileno { 183 return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd 184 return fileno $_[0]; 185} 186 187use constant FORCE_DEBUG_SPAWN => 0; 188use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN; 189 190sub _open3 { 191 local $Me = shift; 192 193 # simulate autovivification of filehandles because 194 # it's too ugly to use @_ throughout to make perl do it for us 195 # tchrist 5-Mar-00 196 197 # Historically, open3(undef...) has silently worked, so keep 198 # it working. 199 splice @_, 0, 1, undef if \$_[0] == \undef; 200 splice @_, 1, 1, undef if \$_[1] == \undef; 201 unless (eval { 202 $_[0] = gensym unless defined $_[0] && length $_[0]; 203 $_[1] = gensym unless defined $_[1] && length $_[1]; 204 1; }) 205 { 206 # must strip crud for croak to add back, or looks ugly 207 $@ =~ s/(?<=value attempted) at .*//s; 208 croak "$Me: $@"; 209 } 210 211 my @handles = ({ mode => '<', handle => \*STDIN }, 212 { mode => '>', handle => \*STDOUT }, 213 { mode => '>', handle => \*STDERR }, 214 ); 215 216 foreach (@handles) { 217 $_->{parent} = shift; 218 $_->{open_as} = gensym; 219 } 220 221 if (@_ > 1 and $_[0] eq '-') { 222 croak "Arguments don't make sense when the command is '-'" 223 } 224 225 $handles[2]{parent} ||= $handles[1]{parent}; 226 $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent}; 227 228 my $package; 229 foreach (@handles) { 230 $_->{dup} = ($_->{parent} =~ s/^[<>]&//); 231 232 if ($_->{parent} !~ /\A=?(\d+)\z/) { 233 # force unqualified filehandles into caller's package 234 $package //= caller 1; 235 $_->{parent} = qualify $_->{parent}, $package; 236 } 237 238 next if $_->{dup} or $_->{dup_of_out}; 239 if ($_->{mode} eq '<') { 240 xpipe $_->{open_as}, $_->{parent}; 241 } else { 242 xpipe $_->{parent}, $_->{open_as}; 243 } 244 } 245 246 my $kidpid; 247 if (!DO_SPAWN) { 248 # Used to communicate exec failures. 249 xpipe my $stat_r, my $stat_w; 250 251 $kidpid = fork; 252 croak "$Me: fork failed: $!" unless defined $kidpid; 253 if ($kidpid == 0) { # Kid 254 eval { 255 # A tie in the parent should not be allowed to cause problems. 256 untie *STDIN; 257 untie *STDOUT; 258 untie *STDERR; 259 260 close $stat_r; 261 require Fcntl; 262 my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0; 263 croak "$Me: fcntl failed: $!" unless $flags; 264 fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC 265 or croak "$Me: fcntl failed: $!"; 266 267 # If she wants to dup the kid's stderr onto her stdout I need to 268 # save a copy of her stdout before I put something else there. 269 if (!$handles[2]{dup_of_out} && $handles[2]{dup} 270 && xfileno($handles[2]{parent}) == fileno \*STDOUT) { 271 my $tmp = gensym; 272 xopen($tmp, '>&', $handles[2]{parent}); 273 $handles[2]{parent} = $tmp; 274 } 275 276 foreach (@handles) { 277 if ($_->{dup_of_out}) { 278 xopen \*STDERR, ">&STDOUT" 279 if defined fileno STDERR && fileno STDERR != fileno STDOUT; 280 } elsif ($_->{dup}) { 281 xopen $_->{handle}, $_->{mode} . '&', $_->{parent} 282 if fileno $_->{handle} != xfileno($_->{parent}); 283 } else { 284 xclose $_->{parent}, $_->{mode}; 285 xopen $_->{handle}, $_->{mode} . '&=', 286 fileno $_->{open_as}; 287 } 288 } 289 return 1 if ($_[0] eq '-'); 290 exec @_ or do { 291 local($")=(" "); 292 croak "$Me: exec of @_ failed: $!"; 293 }; 294 } and do { 295 close $stat_w; 296 return 0; 297 }; 298 299 my $bang = 0+$!; 300 my $err = $@; 301 utf8::encode $err if $] >= 5.008; 302 print $stat_w pack('IIa*', $bang, length($err), $err); 303 close $stat_w; 304 305 eval { require POSIX; POSIX::_exit(255); }; 306 exit 255; 307 } 308 else { # Parent 309 close $stat_w; 310 my $to_read = length(pack('I', 0)) * 2; 311 my $bytes_read = read($stat_r, my $buf = '', $to_read); 312 if ($bytes_read) { 313 (my $bang, $to_read) = unpack('II', $buf); 314 read($stat_r, my $err = '', $to_read); 315 waitpid $kidpid, 0; # Reap child which should have exited 316 if ($err) { 317 utf8::decode $err if $] >= 5.008; 318 } else { 319 $err = "$Me: " . ($! = $bang); 320 } 321 $! = $bang; 322 die($err); 323 } 324 } 325 } 326 else { # DO_SPAWN 327 # All the bookkeeping of coincidence between handles is 328 # handled in spawn_with_handles. 329 330 my @close; 331 332 foreach (@handles) { 333 if ($_->{dup_of_out}) { 334 $_->{open_as} = $handles[1]{open_as}; 335 } elsif ($_->{dup}) { 336 $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/ 337 ? $_->{parent} : \*{$_->{parent}}; 338 push @close, $_->{open_as}; 339 } else { 340 push @close, \*{$_->{parent}}, $_->{open_as}; 341 } 342 } 343 require IO::Pipe; 344 $kidpid = eval { 345 spawn_with_handles(\@handles, \@close, @_); 346 }; 347 die "$Me: $@" if $@; 348 } 349 350 foreach (@handles) { 351 next if $_->{dup} or $_->{dup_of_out}; 352 xclose $_->{open_as}, $_->{mode}; 353 } 354 355 # If the write handle is a dup give it away entirely, close my copy 356 # of it. 357 xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup}; 358 359 select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe 360 $kidpid; 361} 362 363sub open3 { 364 if (@_ < 4) { 365 local $" = ', '; 366 croak "open3(@_): not enough arguments"; 367 } 368 return _open3 'open3', @_ 369} 370 371sub spawn_with_handles { 372 my $fds = shift; # Fields: handle, mode, open_as 373 my $close_in_child = shift; 374 my ($fd, %saved, @errs); 375 376 foreach $fd (@$fds) { 377 $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); 378 $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy}; 379 } 380 foreach $fd (@$fds) { 381 bless $fd->{handle}, 'IO::Handle' 382 unless eval { $fd->{handle}->isa('IO::Handle') } ; 383 # If some of handles to redirect-to coincide with handles to 384 # redirect, we need to use saved variants: 385 my $open_as = $fd->{open_as}; 386 my $fileno = fileno($open_as); 387 $fd->{handle}->fdopen(defined($fileno) 388 ? $saved{$fileno} || $open_as 389 : $open_as, 390 $fd->{mode}); 391 } 392 unless ($^O eq 'MSWin32') { 393 require Fcntl; 394 # Stderr may be redirected below, so we save the err text: 395 foreach $fd (@$close_in_child) { 396 next unless fileno $fd; 397 fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!" 398 unless $saved{fileno $fd}; # Do not close what we redirect! 399 } 400 } 401 402 my $pid; 403 unless (@errs) { 404 if (FORCE_DEBUG_SPAWN) { 405 pipe my $r, my $w or die "Pipe failed: $!"; 406 $pid = fork; 407 die "Fork failed: $!" unless defined $pid; 408 if (!$pid) { 409 { no warnings; exec @_ } 410 print $w 0 + $!; 411 close $w; 412 require POSIX; 413 POSIX::_exit(255); 414 } 415 close $w; 416 my $bad = <$r>; 417 if (defined $bad) { 418 $! = $bad; 419 undef $pid; 420 } 421 } else { 422 $pid = eval { system 1, @_ }; # 1 == P_NOWAIT 423 } 424 if($@) { 425 push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@"; 426 } elsif(!$pid || $pid < 0) { 427 push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!"; 428 } 429 } 430 431 # Do this in reverse, so that STDERR is restored first: 432 foreach $fd (reverse @$fds) { 433 $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode}); 434 } 435 foreach (values %saved) { 436 $_->close or croak "Can't close: $!"; 437 } 438 croak join "\n", @errs if @errs; 439 return $pid; 440} 441 4421; # so require is happy 443