Open3.pm revision 1.5
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.16'; 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 250 close $stat_r; 251 require Fcntl; 252 my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0; 253 croak "$Me: fcntl failed: $!" unless $flags; 254 fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC 255 or croak "$Me: fcntl failed: $!"; 256 257 # If she wants to dup the kid's stderr onto her stdout I need to 258 # save a copy of her stdout before I put something else there. 259 if (!$handles[2]{dup_of_out} && $handles[2]{dup} 260 && xfileno($handles[2]{parent}) == fileno \*STDOUT) { 261 my $tmp = gensym; 262 xopen($tmp, '>&', $handles[2]{parent}); 263 $handles[2]{parent} = $tmp; 264 } 265 266 foreach (@handles) { 267 if ($_->{dup_of_out}) { 268 xopen \*STDERR, ">&STDOUT" 269 if defined fileno STDERR && fileno STDERR != fileno STDOUT; 270 } elsif ($_->{dup}) { 271 xopen $_->{handle}, $_->{mode} . '&', $_->{parent} 272 if fileno $_->{handle} != xfileno($_->{parent}); 273 } else { 274 xclose $_->{parent}, $_->{mode}; 275 xopen $_->{handle}, $_->{mode} . '&=', 276 fileno $_->{open_as}; 277 } 278 } 279 return 1 if ($_[0] eq '-'); 280 exec @_ or do { 281 local($")=(" "); 282 croak "$Me: exec of @_ failed"; 283 }; 284 } and do { 285 close $stat_w; 286 return 0; 287 }; 288 289 my $bang = 0+$!; 290 my $err = $@; 291 utf8::encode $err if $] >= 5.008; 292 print $stat_w pack('IIa*', $bang, length($err), $err); 293 close $stat_w; 294 295 eval { require POSIX; POSIX::_exit(255); }; 296 exit 255; 297 } 298 else { # Parent 299 close $stat_w; 300 my $to_read = length(pack('I', 0)) * 2; 301 my $bytes_read = read($stat_r, my $buf = '', $to_read); 302 if ($bytes_read) { 303 (my $bang, $to_read) = unpack('II', $buf); 304 read($stat_r, my $err = '', $to_read); 305 waitpid $kidpid, 0; # Reap child which should have exited 306 if ($err) { 307 utf8::decode $err if $] >= 5.008; 308 } else { 309 $err = "$Me: " . ($! = $bang); 310 } 311 $! = $bang; 312 die($err); 313 } 314 } 315 } 316 else { # DO_SPAWN 317 # All the bookkeeping of coincidence between handles is 318 # handled in spawn_with_handles. 319 320 my @close; 321 322 foreach (@handles) { 323 if ($_->{dup_of_out}) { 324 $_->{open_as} = $handles[1]{open_as}; 325 } elsif ($_->{dup}) { 326 $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/ 327 ? $_->{parent} : \*{$_->{parent}}; 328 push @close, $_->{open_as}; 329 } else { 330 push @close, \*{$_->{parent}}, $_->{open_as}; 331 } 332 } 333 require IO::Pipe; 334 $kidpid = eval { 335 spawn_with_handles(\@handles, \@close, @_); 336 }; 337 die "$Me: $@" if $@; 338 } 339 340 foreach (@handles) { 341 next if $_->{dup} or $_->{dup_of_out}; 342 xclose $_->{open_as}, $_->{mode}; 343 } 344 345 # If the write handle is a dup give it away entirely, close my copy 346 # of it. 347 xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup}; 348 349 select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe 350 $kidpid; 351} 352 353sub open3 { 354 if (@_ < 4) { 355 local $" = ', '; 356 croak "open3(@_): not enough arguments"; 357 } 358 return _open3 'open3', @_ 359} 360 361sub spawn_with_handles { 362 my $fds = shift; # Fields: handle, mode, open_as 363 my $close_in_child = shift; 364 my ($fd, $pid, @saved_fh, $saved, %saved, @errs); 365 366 foreach $fd (@$fds) { 367 $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); 368 $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy}; 369 } 370 foreach $fd (@$fds) { 371 bless $fd->{handle}, 'IO::Handle' 372 unless eval { $fd->{handle}->isa('IO::Handle') } ; 373 # If some of handles to redirect-to coincide with handles to 374 # redirect, we need to use saved variants: 375 $fd->{handle}->fdopen(defined fileno $fd->{open_as} 376 ? $saved{fileno $fd->{open_as}} || $fd->{open_as} 377 : $fd->{open_as}, 378 $fd->{mode}); 379 } 380 unless ($^O eq 'MSWin32') { 381 require Fcntl; 382 # Stderr may be redirected below, so we save the err text: 383 foreach $fd (@$close_in_child) { 384 next unless fileno $fd; 385 fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!" 386 unless $saved{fileno $fd}; # Do not close what we redirect! 387 } 388 } 389 390 unless (@errs) { 391 if (FORCE_DEBUG_SPAWN) { 392 pipe my $r, my $w or die "Pipe failed: $!"; 393 $pid = fork; 394 die "Fork failed: $!" unless defined $pid; 395 if (!$pid) { 396 { no warnings; exec @_ } 397 print $w 0 + $!; 398 close $w; 399 require POSIX; 400 POSIX::_exit(255); 401 } 402 close $w; 403 my $bad = <$r>; 404 if (defined $bad) { 405 $! = $bad; 406 undef $pid; 407 } 408 } else { 409 $pid = eval { system 1, @_ }; # 1 == P_NOWAIT 410 } 411 push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0; 412 } 413 414 # Do this in reverse, so that STDERR is restored first: 415 foreach $fd (reverse @$fds) { 416 $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode}); 417 } 418 foreach (values %saved) { 419 $_->close or croak "Can't close: $!"; 420 } 421 croak join "\n", @errs if @errs; 422 return $pid; 423} 424 4251; # so require is happy 426