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