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