1package IPC::Cmd; 2 3use strict; 4 5BEGIN { 6 7 use constant IS_VMS => $^O eq 'VMS' ? 1 : 0; 8 use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0; 9 use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0; 10 use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut'; 11 use constant SPECIAL_CHARS => qw[< > | &]; 12 use constant QUOTE => do { IS_WIN32 ? q["] : q['] }; 13 14 use Exporter (); 15 use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG 16 $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN 17 $INSTANCES $ALLOW_NULL_ARGS 18 $HAVE_MONOTONIC 19 ]; 20 21 $VERSION = '0.92'; 22 $VERBOSE = 0; 23 $DEBUG = 0; 24 $WARN = 1; 25 $USE_IPC_RUN = IS_WIN32 && !IS_WIN98; 26 $USE_IPC_OPEN3 = not IS_VMS; 27 $ALLOW_NULL_ARGS = 0; 28 29 $CAN_USE_RUN_FORKED = 0; 30 eval { 31 require POSIX; POSIX->import(); 32 require IPC::Open3; IPC::Open3->import(); 33 require IO::Select; IO::Select->import(); 34 require IO::Handle; IO::Handle->import(); 35 require FileHandle; FileHandle->import(); 36 require Socket; 37 require Time::HiRes; Time::HiRes->import(); 38 require Win32 if IS_WIN32; 39 }; 40 $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32; 41 42 eval { 43 my $wait_start_time = Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC); 44 }; 45 if ($@) { 46 $HAVE_MONOTONIC = 0; 47 } 48 else { 49 $HAVE_MONOTONIC = 1; 50 } 51 52 @ISA = qw[Exporter]; 53 @EXPORT_OK = qw[can_run run run_forked QUOTE]; 54} 55 56require Carp; 57use File::Spec; 58use Params::Check qw[check]; 59use Text::ParseWords (); # import ONLY if needed! 60use Module::Load::Conditional qw[can_load]; 61use Locale::Maketext::Simple Style => 'gettext'; 62 63=pod 64 65=head1 NAME 66 67IPC::Cmd - finding and running system commands made easy 68 69=head1 SYNOPSIS 70 71 use IPC::Cmd qw[can_run run run_forked]; 72 73 my $full_path = can_run('wget') or warn 'wget is not installed!'; 74 75 ### commands can be arrayrefs or strings ### 76 my $cmd = "$full_path -b theregister.co.uk"; 77 my $cmd = [$full_path, '-b', 'theregister.co.uk']; 78 79 ### in scalar context ### 80 my $buffer; 81 if( scalar run( command => $cmd, 82 verbose => 0, 83 buffer => \$buffer, 84 timeout => 20 ) 85 ) { 86 print "fetched webpage successfully: $buffer\n"; 87 } 88 89 90 ### in list context ### 91 my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) = 92 run( command => $cmd, verbose => 0 ); 93 94 if( $success ) { 95 print "this is what the command printed:\n"; 96 print join "", @$full_buf; 97 } 98 99 ### run_forked example ### 100 my $result = run_forked("$full_path -q -O - theregister.co.uk", {'timeout' => 20}); 101 if ($result->{'exit_code'} eq 0 && !$result->{'timeout'}) { 102 print "this is what wget returned:\n"; 103 print $result->{'stdout'}; 104 } 105 106 ### check for features 107 print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3; 108 print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run; 109 print "Can capture buffer: " . IPC::Cmd->can_capture_buffer; 110 111 ### don't have IPC::Cmd be verbose, ie don't print to stdout or 112 ### stderr when running commands -- default is '0' 113 $IPC::Cmd::VERBOSE = 0; 114 115 116=head1 DESCRIPTION 117 118IPC::Cmd allows you to run commands platform independently, 119interactively if desired, but have them still work. 120 121The C<can_run> function can tell you if a certain binary is installed 122and if so where, whereas the C<run> function can actually execute any 123of the commands you give it and give you a clear return value, as well 124as adhere to your verbosity settings. 125 126=head1 CLASS METHODS 127 128=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] ) 129 130Utility function that tells you if C<IPC::Run> is available. 131If the C<verbose> flag is passed, it will print diagnostic messages 132if L<IPC::Run> can not be found or loaded. 133 134=cut 135 136 137sub can_use_ipc_run { 138 my $self = shift; 139 my $verbose = shift || 0; 140 141 ### IPC::Run doesn't run on win98 142 return if IS_WIN98; 143 144 ### if we don't have ipc::run, we obviously can't use it. 145 return unless can_load( 146 modules => { 'IPC::Run' => '0.55' }, 147 verbose => ($WARN && $verbose), 148 ); 149 150 ### otherwise, we're good to go 151 return $IPC::Run::VERSION; 152} 153 154=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] ) 155 156Utility function that tells you if C<IPC::Open3> is available. 157If the verbose flag is passed, it will print diagnostic messages 158if C<IPC::Open3> can not be found or loaded. 159 160=cut 161 162 163sub can_use_ipc_open3 { 164 my $self = shift; 165 my $verbose = shift || 0; 166 167 ### IPC::Open3 is not working on VMS because of a lack of fork. 168 return if IS_VMS; 169 170 ### IPC::Open3 works on every non-VMS platform, but it can't 171 ### capture buffers on win32 :( 172 return unless can_load( 173 modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| }, 174 verbose => ($WARN && $verbose), 175 ); 176 177 return $IPC::Open3::VERSION; 178} 179 180=head2 $bool = IPC::Cmd->can_capture_buffer 181 182Utility function that tells you if C<IPC::Cmd> is capable of 183capturing buffers in it's current configuration. 184 185=cut 186 187sub can_capture_buffer { 188 my $self = shift; 189 190 return 1 if $USE_IPC_RUN && $self->can_use_ipc_run; 191 return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3; 192 return; 193} 194 195=head2 $bool = IPC::Cmd->can_use_run_forked 196 197Utility function that tells you if C<IPC::Cmd> is capable of 198providing C<run_forked> on the current platform. 199 200=head1 FUNCTIONS 201 202=head2 $path = can_run( PROGRAM ); 203 204C<can_run> takes only one argument: the name of a binary you wish 205to locate. C<can_run> works much like the unix binary C<which> or the bash 206command C<type>, which scans through your path, looking for the requested 207binary. 208 209Unlike C<which> and C<type>, this function is platform independent and 210will also work on, for example, Win32. 211 212If called in a scalar context it will return the full path to the binary 213you asked for if it was found, or C<undef> if it was not. 214 215If called in a list context and the global variable C<$INSTANCES> is a true 216value, it will return a list of the full paths to instances 217of the binary where found in C<PATH>, or an empty list if it was not found. 218 219=cut 220 221sub can_run { 222 my $command = shift; 223 224 # a lot of VMS executables have a symbol defined 225 # check those first 226 if ( $^O eq 'VMS' ) { 227 require VMS::DCLsym; 228 my $syms = VMS::DCLsym->new; 229 return $command if scalar $syms->getsym( uc $command ); 230 } 231 232 require File::Spec; 233 require ExtUtils::MakeMaker; 234 235 my @possibles; 236 237 if( File::Spec->file_name_is_absolute($command) ) { 238 return MM->maybe_command($command); 239 240 } else { 241 for my $dir ( 242 File::Spec->path, 243 File::Spec->curdir 244 ) { 245 next if ! $dir || ! -d $dir; 246 my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command); 247 push @possibles, $abs if $abs = MM->maybe_command($abs); 248 } 249 } 250 return @possibles if wantarray and $INSTANCES; 251 return shift @possibles; 252} 253 254=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] ); 255 256C<run> takes 4 arguments: 257 258=over 4 259 260=item command 261 262This is the command to execute. It may be either a string or an array 263reference. 264This is a required argument. 265 266See L<"Caveats"> for remarks on how commands are parsed and their 267limitations. 268 269=item verbose 270 271This controls whether all output of a command should also be printed 272to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers 273require L<IPC::Run> to be installed, or your system able to work with 274L<IPC::Open3>). 275 276It will default to the global setting of C<$IPC::Cmd::VERBOSE>, 277which by default is 0. 278 279=item buffer 280 281This will hold all the output of a command. It needs to be a reference 282to a scalar. 283Note that this will hold both the STDOUT and STDERR messages, and you 284have no way of telling which is which. 285If you require this distinction, run the C<run> command in list context 286and inspect the individual buffers. 287 288Of course, this requires that the underlying call supports buffers. See 289the note on buffers above. 290 291=item timeout 292 293Sets the maximum time the command is allowed to run before aborting, 294using the built-in C<alarm()> call. If the timeout is triggered, the 295C<errorcode> in the return value will be set to an object of the 296C<IPC::Cmd::TimeOut> class. See the L<"error message"> section below for 297details. 298 299Defaults to C<0>, meaning no timeout is set. 300 301=back 302 303C<run> will return a simple C<true> or C<false> when called in scalar 304context. 305In list context, you will be returned a list of the following items: 306 307=over 4 308 309=item success 310 311A simple boolean indicating if the command executed without errors or 312not. 313 314=item error message 315 316If the first element of the return value (C<success>) was 0, then some 317error occurred. This second element is the error message the command 318you requested exited with, if available. This is generally a pretty 319printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on 320what they can contain. 321If the error was a timeout, the C<error message> will be prefixed with 322the string C<IPC::Cmd::TimeOut>, the timeout class. 323 324=item full_buffer 325 326This is an array reference containing all the output the command 327generated. 328Note that buffers are only available if you have L<IPC::Run> installed, 329or if your system is able to work with L<IPC::Open3> -- see below). 330Otherwise, this element will be C<undef>. 331 332=item out_buffer 333 334This is an array reference containing all the output sent to STDOUT the 335command generated. The notes from L<"full_buffer"> apply. 336 337=item error_buffer 338 339This is an arrayreference containing all the output sent to STDERR the 340command generated. The notes from L<"full_buffer"> apply. 341 342 343=back 344 345See the L<"HOW IT WORKS"> section below to see how C<IPC::Cmd> decides 346what modules or function calls to use when issuing a command. 347 348=cut 349 350{ my @acc = qw[ok error _fds]; 351 352 ### autogenerate accessors ### 353 for my $key ( @acc ) { 354 no strict 'refs'; 355 *{__PACKAGE__."::$key"} = sub { 356 $_[0]->{$key} = $_[1] if @_ > 1; 357 return $_[0]->{$key}; 358 } 359 } 360} 361 362sub can_use_run_forked { 363 return $CAN_USE_RUN_FORKED eq "1"; 364} 365 366sub get_monotonic_time { 367 if ($HAVE_MONOTONIC) { 368 return Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC); 369 } 370 else { 371 return time(); 372 } 373} 374 375sub adjust_monotonic_start_time { 376 my ($ref_vars, $now, $previous) = @_; 377 378 # workaround only for those systems which don't have 379 # Time::HiRes::CLOCK_MONOTONIC (Mac OSX in particular) 380 return if $HAVE_MONOTONIC; 381 382 # don't have previous monotonic value (only happens once 383 # in the beginning of the program execution) 384 return unless $previous; 385 386 my $time_diff = $now - $previous; 387 388 # adjust previously saved time with the skew value which is 389 # either negative when clock moved back or more than 5 seconds -- 390 # assuming that event loop does happen more often than once 391 # per five seconds, which might not be always true (!) but 392 # hopefully that's ok, because it's just a workaround 393 if ($time_diff > 5 || $time_diff < 0) { 394 foreach my $ref_var (@{$ref_vars}) { 395 if (defined($$ref_var)) { 396 $$ref_var = $$ref_var + $time_diff; 397 } 398 } 399 } 400} 401 402# incompatible with POSIX::SigAction 403# 404sub install_layered_signal { 405 my ($s, $handler_code) = @_; 406 407 my %available_signals = map {$_ => 1} keys %SIG; 408 409 Carp::confess("install_layered_signal got nonexistent signal name [$s]") 410 unless defined($available_signals{$s}); 411 Carp::confess("install_layered_signal expects coderef") 412 if !ref($handler_code) || ref($handler_code) ne 'CODE'; 413 414 my $previous_handler = $SIG{$s}; 415 416 my $sig_handler = sub { 417 my ($called_sig_name, @sig_param) = @_; 418 419 # $s is a closure referring to real signal name 420 # for which this handler is being installed. 421 # it is used to distinguish between 422 # real signal handlers and aliased signal handlers 423 my $signal_name = $s; 424 425 # $called_sig_name is a signal name which 426 # was passed to this signal handler; 427 # it doesn't equal $signal_name in case 428 # some signal handlers in %SIG point 429 # to other signal handler (CHLD and CLD, 430 # ABRT and IOT) 431 # 432 # initial signal handler for aliased signal 433 # calls some other signal handler which 434 # should not execute the same handler_code again 435 if ($called_sig_name eq $signal_name) { 436 $handler_code->($signal_name); 437 } 438 439 # run original signal handler if any (including aliased) 440 # 441 if (ref($previous_handler)) { 442 $previous_handler->($called_sig_name, @sig_param); 443 } 444 }; 445 446 $SIG{$s} = $sig_handler; 447} 448 449# give process a chance sending TERM, 450# waiting for a while (2 seconds) 451# and killing it with KILL 452sub kill_gently { 453 my ($pid, $opts) = @_; 454 455 require POSIX; 456 457 $opts = {} unless $opts; 458 $opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'}); 459 $opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'}; 460 $opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'}; 461 462 if ($opts->{'first_kill_type'} eq 'just_process') { 463 kill(15, $pid); 464 } 465 elsif ($opts->{'first_kill_type'} eq 'process_group') { 466 kill(-15, $pid); 467 } 468 469 my $do_wait = 1; 470 my $child_finished = 0; 471 472 my $wait_start_time = get_monotonic_time(); 473 my $now; 474 my $previous_monotonic_value; 475 476 while ($do_wait) { 477 $previous_monotonic_value = $now; 478 $now = get_monotonic_time(); 479 480 adjust_monotonic_start_time([\$wait_start_time], $now, $previous_monotonic_value); 481 482 if ($now > $wait_start_time + $opts->{'wait_time'}) { 483 $do_wait = 0; 484 next; 485 } 486 487 my $waitpid = waitpid($pid, POSIX::WNOHANG); 488 489 if ($waitpid eq -1) { 490 $child_finished = 1; 491 $do_wait = 0; 492 next; 493 } 494 495 Time::HiRes::usleep(250000); # quarter of a second 496 } 497 498 if (!$child_finished) { 499 if ($opts->{'final_kill_type'} eq 'just_process') { 500 kill(9, $pid); 501 } 502 elsif ($opts->{'final_kill_type'} eq 'process_group') { 503 kill(-9, $pid); 504 } 505 } 506} 507 508sub open3_run { 509 my ($cmd, $opts) = @_; 510 511 $opts = {} unless $opts; 512 513 my $child_in = FileHandle->new; 514 my $child_out = FileHandle->new; 515 my $child_err = FileHandle->new; 516 $child_out->autoflush(1); 517 $child_err->autoflush(1); 518 519 my $pid = open3($child_in, $child_out, $child_err, $cmd); 520 521 # push my child's pid to our parent 522 # so in case i am killed parent 523 # could stop my child (search for 524 # child_child_pid in parent code) 525 if ($opts->{'parent_info'}) { 526 my $ps = $opts->{'parent_info'}; 527 print $ps "spawned $pid\n"; 528 } 529 530 if ($child_in && $child_out->opened && $opts->{'child_stdin'}) { 531 # If the child process dies for any reason, 532 # the next write to CHLD_IN is likely to generate 533 # a SIGPIPE in the parent, which is fatal by default. 534 # So you may wish to handle this signal. 535 # 536 # from http://perldoc.perl.org/IPC/Open3.html, 537 # absolutely needed to catch piped commands errors. 538 # 539 local $SIG{'PIPE'} = sub { 1; }; 540 541 print $child_in $opts->{'child_stdin'}; 542 } 543 close($child_in); 544 545 my $child_output = { 546 'out' => $child_out->fileno, 547 'err' => $child_err->fileno, 548 $child_out->fileno => { 549 'parent_socket' => $opts->{'parent_stdout'}, 550 'scalar_buffer' => "", 551 'child_handle' => $child_out, 552 'block_size' => ($child_out->stat)[11] || 1024, 553 }, 554 $child_err->fileno => { 555 'parent_socket' => $opts->{'parent_stderr'}, 556 'scalar_buffer' => "", 557 'child_handle' => $child_err, 558 'block_size' => ($child_err->stat)[11] || 1024, 559 }, 560 }; 561 562 my $select = IO::Select->new(); 563 $select->add($child_out, $child_err); 564 565 # pass any signal to the child 566 # effectively creating process 567 # strongly attached to the child: 568 # it will terminate only after child 569 # has terminated (except for SIGKILL, 570 # which is specially handled) 571 foreach my $s (keys %SIG) { 572 my $sig_handler; 573 $sig_handler = sub { 574 kill("$s", $pid); 575 $SIG{$s} = $sig_handler; 576 }; 577 $SIG{$s} = $sig_handler; 578 } 579 580 my $child_finished = 0; 581 582 my $real_exit; 583 my $exit_value; 584 585 while(!$child_finished) { 586 587 # parent was killed otherwise we would have got 588 # the same signal as parent and process it same way 589 if (getppid() eq "1") { 590 591 # end my process group with all the children 592 # (i am the process group leader, so my pid 593 # equals to the process group id) 594 # 595 # same thing which is done 596 # with $opts->{'clean_up_children'} 597 # in run_forked 598 # 599 kill(-9, $$); 600 601 POSIX::_exit 1; 602 } 603 604 my $waitpid = waitpid($pid, POSIX::WNOHANG); 605 606 # child finished, catch it's exit status 607 if ($waitpid ne 0 && $waitpid ne -1) { 608 $real_exit = $?; 609 $exit_value = $? >> 8; 610 } 611 612 if ($waitpid eq -1) { 613 $child_finished = 1; 614 } 615 616 617 my $ready_fds = []; 618 push @{$ready_fds}, $select->can_read(1/100); 619 620 READY_FDS: while (scalar(@{$ready_fds})) { 621 my $fd = shift @{$ready_fds}; 622 $ready_fds = [grep {$_ ne $fd} @{$ready_fds}]; 623 624 my $str = $child_output->{$fd->fileno}; 625 Carp::confess("child stream not found: $fd") unless $str; 626 627 my $data; 628 my $count = $fd->sysread($data, $str->{'block_size'}); 629 630 if ($count) { 631 if ($str->{'parent_socket'}) { 632 my $ph = $str->{'parent_socket'}; 633 print $ph $data; 634 } 635 else { 636 $str->{'scalar_buffer'} .= $data; 637 } 638 } 639 elsif ($count eq 0) { 640 $select->remove($fd); 641 $fd->close(); 642 } 643 else { 644 Carp::confess("error during sysread: " . $!); 645 } 646 647 push @{$ready_fds}, $select->can_read(1/100) if $child_finished; 648 } 649 650 Time::HiRes::usleep(1); 651 } 652 653 # since we've successfully reaped the child, 654 # let our parent know about this. 655 # 656 if ($opts->{'parent_info'}) { 657 my $ps = $opts->{'parent_info'}; 658 659 # child was killed, inform parent 660 if ($real_exit & 127) { 661 print $ps "$pid killed with " . ($real_exit & 127) . "\n"; 662 } 663 664 print $ps "reaped $pid\n"; 665 } 666 667 if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) { 668 return $exit_value; 669 } 670 else { 671 return { 672 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'}, 673 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'}, 674 'exit_code' => $exit_value, 675 }; 676 } 677} 678 679=head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} ); 680 681C<run_forked> is used to execute some program or a coderef, 682optionally feed it with some input, get its return code 683and output (both stdout and stderr into separate buffers). 684In addition, it allows to terminate the program 685if it takes too long to finish. 686 687The important and distinguishing feature of run_forked 688is execution timeout which at first seems to be 689quite a simple task but if you think 690that the program which you're spawning 691might spawn some children itself (which 692in their turn could do the same and so on) 693it turns out to be not a simple issue. 694 695C<run_forked> is designed to survive and 696successfully terminate almost any long running task, 697even a fork bomb in case your system has the resources 698to survive during given timeout. 699 700This is achieved by creating separate watchdog process 701which spawns the specified program in a separate 702process session and supervises it: optionally 703feeds it with input, stores its exit code, 704stdout and stderr, terminates it in case 705it runs longer than specified. 706 707Invocation requires the command to be executed or a coderef and optionally a hashref of options: 708 709=over 710 711=item C<timeout> 712 713Specify in seconds how long to run the command before it is killed with SIG_KILL (9), 714which effectively terminates it and all of its children (direct or indirect). 715 716=item C<child_stdin> 717 718Specify some text that will be passed into the C<STDIN> of the executed program. 719 720=item C<stdout_handler> 721 722Coderef of a subroutine to call when a portion of data is received on 723STDOUT from the executing program. 724 725=item C<stderr_handler> 726 727Coderef of a subroutine to call when a portion of data is received on 728STDERR from the executing program. 729 730 731=item C<discard_output> 732 733Discards the buffering of the standard output and standard errors for return by run_forked(). 734With this option you have to use the std*_handlers to read what the command outputs. 735Useful for commands that send a lot of output. 736 737=item C<terminate_on_parent_sudden_death> 738 739Enable this option if you wish all spawned processes to be killed if the initially spawned 740process (the parent) is killed or dies without waiting for child processes. 741 742=back 743 744C<run_forked> will return a HASHREF with the following keys: 745 746=over 747 748=item C<exit_code> 749 750The exit code of the executed program. 751 752=item C<timeout> 753 754The number of seconds the program ran for before being terminated, or 0 if no timeout occurred. 755 756=item C<stdout> 757 758Holds the standard output of the executed command (or empty string if 759there was no STDOUT output or if C<discard_output> was used; it's always defined!) 760 761=item C<stderr> 762 763Holds the standard error of the executed command (or empty string if 764there was no STDERR output or if C<discard_output> was used; it's always defined!) 765 766=item C<merged> 767 768Holds the standard output and error of the executed command merged into one stream 769(or empty string if there was no output at all or if C<discard_output> was used; it's always defined!) 770 771=item C<err_msg> 772 773Holds some explanation in the case of an error. 774 775=back 776 777=cut 778 779sub run_forked { 780 ### container to store things in 781 my $self = bless {}, __PACKAGE__; 782 783 if (!can_use_run_forked()) { 784 Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED"); 785 return; 786 } 787 788 require POSIX; 789 790 my ($cmd, $opts) = @_; 791 if (ref($cmd) eq 'ARRAY') { 792 $cmd = join(" ", @{$cmd}); 793 } 794 795 if (!$cmd) { 796 Carp::carp("run_forked expects command to run"); 797 return; 798 } 799 800 $opts = {} unless $opts; 801 $opts->{'timeout'} = 0 unless $opts->{'timeout'}; 802 $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'}); 803 804 # turned on by default 805 $opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'}); 806 807 # sockets to pass child stdout to parent 808 my $child_stdout_socket; 809 my $parent_stdout_socket; 810 811 # sockets to pass child stderr to parent 812 my $child_stderr_socket; 813 my $parent_stderr_socket; 814 815 # sockets for child -> parent internal communication 816 my $child_info_socket; 817 my $parent_info_socket; 818 819 socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) || 820 Carp::confess ("socketpair: $!"); 821 socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) || 822 Carp::confess ("socketpair: $!"); 823 socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) || 824 Carp::confess ("socketpair: $!"); 825 826 $child_stdout_socket->autoflush(1); 827 $parent_stdout_socket->autoflush(1); 828 $child_stderr_socket->autoflush(1); 829 $parent_stderr_socket->autoflush(1); 830 $child_info_socket->autoflush(1); 831 $parent_info_socket->autoflush(1); 832 833 my $start_time = get_monotonic_time(); 834 835 my $pid; 836 if ($pid = fork) { 837 838 # we are a parent 839 close($parent_stdout_socket); 840 close($parent_stderr_socket); 841 close($parent_info_socket); 842 843 my $flags; 844 845 # prepare sockets to read from child 846 847 $flags = 0; 848 fcntl($child_stdout_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!"; 849 $flags |= POSIX::O_NONBLOCK; 850 fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!"; 851 852 $flags = 0; 853 fcntl($child_stderr_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!"; 854 $flags |= POSIX::O_NONBLOCK; 855 fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!"; 856 857 $flags = 0; 858 fcntl($child_info_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!"; 859 $flags |= POSIX::O_NONBLOCK; 860 fcntl($child_info_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!"; 861 862 # print "child $pid started\n"; 863 864 my $child_output = { 865 $child_stdout_socket->fileno => { 866 'scalar_buffer' => "", 867 'child_handle' => $child_stdout_socket, 868 'block_size' => ($child_stdout_socket->stat)[11] || 1024, 869 'protocol' => 'stdout', 870 }, 871 $child_stderr_socket->fileno => { 872 'scalar_buffer' => "", 873 'child_handle' => $child_stderr_socket, 874 'block_size' => ($child_stderr_socket->stat)[11] || 1024, 875 'protocol' => 'stderr', 876 }, 877 $child_info_socket->fileno => { 878 'scalar_buffer' => "", 879 'child_handle' => $child_info_socket, 880 'block_size' => ($child_info_socket->stat)[11] || 1024, 881 'protocol' => 'info', 882 }, 883 }; 884 885 my $select = IO::Select->new(); 886 $select->add($child_stdout_socket, $child_stderr_socket, $child_info_socket); 887 888 my $child_timedout = 0; 889 my $child_finished = 0; 890 my $child_stdout = ''; 891 my $child_stderr = ''; 892 my $child_merged = ''; 893 my $child_exit_code = 0; 894 my $child_killed_by_signal = 0; 895 my $parent_died = 0; 896 897 my $last_parent_check = 0; 898 my $got_sig_child = 0; 899 my $got_sig_quit = 0; 900 my $orig_sig_child = $SIG{'CHLD'}; 901 902 $SIG{'CHLD'} = sub { $got_sig_child = get_monotonic_time(); }; 903 904 if ($opts->{'terminate_on_signal'}) { 905 install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); }); 906 } 907 908 my $child_child_pid; 909 my $now; 910 my $previous_monotonic_value; 911 912 while (!$child_finished) { 913 $previous_monotonic_value = $now; 914 $now = get_monotonic_time(); 915 916 adjust_monotonic_start_time([\$start_time, \$last_parent_check, \$got_sig_child], $now, $previous_monotonic_value); 917 918 if ($opts->{'terminate_on_parent_sudden_death'}) { 919 # check for parent once each five seconds 920 if ($now > $last_parent_check + 5) { 921 if (getppid() eq "1") { 922 kill_gently ($pid, { 923 'first_kill_type' => 'process_group', 924 'final_kill_type' => 'process_group', 925 'wait_time' => $opts->{'terminate_wait_time'} 926 }); 927 $parent_died = 1; 928 } 929 930 $last_parent_check = $now; 931 } 932 } 933 934 # user specified timeout 935 if ($opts->{'timeout'}) { 936 if ($now > $start_time + $opts->{'timeout'}) { 937 kill_gently ($pid, { 938 'first_kill_type' => 'process_group', 939 'final_kill_type' => 'process_group', 940 'wait_time' => $opts->{'terminate_wait_time'} 941 }); 942 $child_timedout = 1; 943 } 944 } 945 946 # give OS 10 seconds for correct return of waitpid, 947 # kill process after that and finish wait loop; 948 # shouldn't ever happen -- remove this code? 949 if ($got_sig_child) { 950 if ($now > $got_sig_child + 10) { 951 print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n"; 952 kill (-9, $pid); 953 $child_finished = 1; 954 } 955 } 956 957 if ($got_sig_quit) { 958 kill_gently ($pid, { 959 'first_kill_type' => 'process_group', 960 'final_kill_type' => 'process_group', 961 'wait_time' => $opts->{'terminate_wait_time'} 962 }); 963 $child_finished = 1; 964 } 965 966 my $waitpid = waitpid($pid, POSIX::WNOHANG); 967 968 # child finished, catch it's exit status 969 if ($waitpid ne 0 && $waitpid ne -1) { 970 $child_exit_code = $? >> 8; 971 } 972 973 if ($waitpid eq -1) { 974 $child_finished = 1; 975 } 976 977 my $ready_fds = []; 978 push @{$ready_fds}, $select->can_read(1/100); 979 980 READY_FDS: while (scalar(@{$ready_fds})) { 981 my $fd = shift @{$ready_fds}; 982 $ready_fds = [grep {$_ ne $fd} @{$ready_fds}]; 983 984 my $str = $child_output->{$fd->fileno}; 985 Carp::confess("child stream not found: $fd") unless $str; 986 987 my $data = ""; 988 my $count = $fd->sysread($data, $str->{'block_size'}); 989 990 if ($count) { 991 # extract all the available lines and store the rest in temporary buffer 992 if ($data =~ /(.+\n)([^\n]*)/so) { 993 $data = $str->{'scalar_buffer'} . $1; 994 $str->{'scalar_buffer'} = $2 || ""; 995 } 996 else { 997 $str->{'scalar_buffer'} .= $data; 998 $data = ""; 999 } 1000 } 1001 elsif ($count eq 0) { 1002 $select->remove($fd); 1003 $fd->close(); 1004 if ($str->{'scalar_buffer'}) { 1005 $data = $str->{'scalar_buffer'} . "\n"; 1006 } 1007 } 1008 else { 1009 Carp::confess("error during sysread on [$fd]: " . $!); 1010 } 1011 1012 # $data contains only full lines (or last line if it was unfinished read 1013 # or now new-line in the output of the child); dat is processed 1014 # according to the "protocol" of socket 1015 if ($str->{'protocol'} eq 'info') { 1016 if ($data =~ /^spawned ([0-9]+?)\n(.*?)/so) { 1017 $child_child_pid = $1; 1018 $data = $2; 1019 } 1020 if ($data =~ /^reaped ([0-9]+?)\n(.*?)/so) { 1021 $child_child_pid = undef; 1022 $data = $2; 1023 } 1024 if ($data =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) { 1025 $child_killed_by_signal = $1; 1026 $data = $2; 1027 } 1028 1029 # we don't expect any other data in info socket, so it's 1030 # some strange violation of protocol, better know about this 1031 if ($data) { 1032 Carp::confess("info protocol violation: [$data]"); 1033 } 1034 } 1035 if ($str->{'protocol'} eq 'stdout') { 1036 if (!$opts->{'discard_output'}) { 1037 $child_stdout .= $data; 1038 $child_merged .= $data; 1039 } 1040 1041 if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') { 1042 $opts->{'stdout_handler'}->($data); 1043 } 1044 } 1045 if ($str->{'protocol'} eq 'stderr') { 1046 if (!$opts->{'discard_output'}) { 1047 $child_stderr .= $data; 1048 $child_merged .= $data; 1049 } 1050 1051 if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') { 1052 $opts->{'stderr_handler'}->($data); 1053 } 1054 } 1055 1056 # process may finish (waitpid returns -1) before 1057 # we've read all of its output because of buffering; 1058 # so try to read all the way it is possible to read 1059 # in such case - this shouldn't be too much (unless 1060 # the buffer size is HUGE -- should introduce 1061 # another counter in such case, maybe later) 1062 # 1063 push @{$ready_fds}, $select->can_read(1/100) if $child_finished; 1064 } 1065 1066 Time::HiRes::usleep(1); 1067 } 1068 1069 # $child_pid_pid is not defined in two cases: 1070 # * when our child was killed before 1071 # it had chance to tell us the pid 1072 # of the child it spawned. we can do 1073 # nothing in this case :( 1074 # * our child successfully reaped its child, 1075 # we have nothing left to do in this case 1076 # 1077 # defined $child_pid_pid means child's child 1078 # has not died but nobody is waiting for it, 1079 # killing it brutally. 1080 # 1081 if ($child_child_pid) { 1082 kill_gently($child_child_pid); 1083 } 1084 1085 # in case there are forks in child which 1086 # do not forward or process signals (TERM) correctly 1087 # kill whole child process group, effectively trying 1088 # not to return with some children or their parts still running 1089 # 1090 # to be more accurate -- we need to be sure 1091 # that this is process group created by our child 1092 # (and not some other process group with the same pgid, 1093 # created just after death of our child) -- fortunately 1094 # this might happen only when process group ids 1095 # are reused quickly (there are lots of processes 1096 # spawning new process groups for example) 1097 # 1098 if ($opts->{'clean_up_children'}) { 1099 kill(-9, $pid); 1100 } 1101 1102 # print "child $pid finished\n"; 1103 1104 close($child_stdout_socket); 1105 close($child_stderr_socket); 1106 close($child_info_socket); 1107 1108 my $o = { 1109 'stdout' => $child_stdout, 1110 'stderr' => $child_stderr, 1111 'merged' => $child_merged, 1112 'timeout' => $child_timedout ? $opts->{'timeout'} : 0, 1113 'exit_code' => $child_exit_code, 1114 'parent_died' => $parent_died, 1115 'killed_by_signal' => $child_killed_by_signal, 1116 'child_pgid' => $pid, 1117 'cmd' => $cmd, 1118 }; 1119 1120 my $err_msg = ''; 1121 if ($o->{'exit_code'}) { 1122 $err_msg .= "exited with code [$o->{'exit_code'}]\n"; 1123 } 1124 if ($o->{'timeout'}) { 1125 $err_msg .= "ran more than [$o->{'timeout'}] seconds\n"; 1126 } 1127 if ($o->{'parent_died'}) { 1128 $err_msg .= "parent died\n"; 1129 } 1130 if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) { 1131 $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n"; 1132 } 1133 if ($o->{'stderr'}) { 1134 $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n"; 1135 } 1136 if ($o->{'killed_by_signal'}) { 1137 $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n"; 1138 } 1139 $o->{'err_msg'} = $err_msg; 1140 1141 if ($orig_sig_child) { 1142 $SIG{'CHLD'} = $orig_sig_child; 1143 } 1144 else { 1145 delete($SIG{'CHLD'}); 1146 } 1147 1148 return $o; 1149 } 1150 else { 1151 Carp::confess("cannot fork: $!") unless defined($pid); 1152 1153 # create new process session for open3 call, 1154 # so we hopefully can kill all the subprocesses 1155 # which might be spawned in it (except for those 1156 # which do setsid theirselves -- can't do anything 1157 # with those) 1158 1159 POSIX::setsid() || Carp::confess("Error running setsid: " . $!); 1160 1161 if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') { 1162 $opts->{'child_BEGIN'}->(); 1163 } 1164 1165 close($child_stdout_socket); 1166 close($child_stderr_socket); 1167 close($child_info_socket); 1168 1169 my $child_exit_code; 1170 1171 # allow both external programs 1172 # and internal perl calls 1173 if (!ref($cmd)) { 1174 $child_exit_code = open3_run($cmd, { 1175 'parent_info' => $parent_info_socket, 1176 'parent_stdout' => $parent_stdout_socket, 1177 'parent_stderr' => $parent_stderr_socket, 1178 'child_stdin' => $opts->{'child_stdin'}, 1179 }); 1180 } 1181 elsif (ref($cmd) eq 'CODE') { 1182 # reopen STDOUT and STDERR for child code: 1183 # https://rt.cpan.org/Ticket/Display.html?id=85912 1184 open STDOUT, '>&', $parent_stdout_socket || Carp::confess("Unable to reopen STDOUT: $!\n"); 1185 open STDERR, '>&', $parent_stderr_socket || Carp::confess("Unable to reopen STDERR: $!\n"); 1186 1187 $child_exit_code = $cmd->({ 1188 'opts' => $opts, 1189 'parent_info' => $parent_info_socket, 1190 'parent_stdout' => $parent_stdout_socket, 1191 'parent_stderr' => $parent_stderr_socket, 1192 'child_stdin' => $opts->{'child_stdin'}, 1193 }); 1194 } 1195 else { 1196 print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n"; 1197 $child_exit_code = 1; 1198 } 1199 1200 close($parent_stdout_socket); 1201 close($parent_stderr_socket); 1202 close($parent_info_socket); 1203 1204 if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') { 1205 $opts->{'child_END'}->(); 1206 } 1207 1208 $| = 1; 1209 POSIX::_exit $child_exit_code; 1210 } 1211} 1212 1213sub run { 1214 ### container to store things in 1215 my $self = bless {}, __PACKAGE__; 1216 1217 my %hash = @_; 1218 1219 ### if the user didn't provide a buffer, we'll store it here. 1220 my $def_buf = ''; 1221 1222 my($verbose,$cmd,$buffer,$timeout); 1223 my $tmpl = { 1224 verbose => { default => $VERBOSE, store => \$verbose }, 1225 buffer => { default => \$def_buf, store => \$buffer }, 1226 command => { required => 1, store => \$cmd, 1227 allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' }, 1228 }, 1229 timeout => { default => 0, store => \$timeout }, 1230 }; 1231 1232 unless( check( $tmpl, \%hash, $VERBOSE ) ) { 1233 Carp::carp( loc( "Could not validate input: %1", 1234 Params::Check->last_error ) ); 1235 return; 1236 }; 1237 1238 $cmd = _quote_args_vms( $cmd ) if IS_VMS; 1239 1240 ### strip any empty elements from $cmd if present 1241 if ( $ALLOW_NULL_ARGS ) { 1242 $cmd = [ grep { defined } @$cmd ] if ref $cmd; 1243 } 1244 else { 1245 $cmd = [ grep { defined && length } @$cmd ] if ref $cmd; 1246 } 1247 1248 my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd); 1249 print loc("Running [%1]...\n", $pp_cmd ) if $verbose; 1250 1251 ### did the user pass us a buffer to fill or not? if so, set this 1252 ### flag so we know what is expected of us 1253 ### XXX this is now being ignored. in the future, we could add diagnostic 1254 ### messages based on this logic 1255 #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1; 1256 1257 ### buffers that are to be captured 1258 my( @buffer, @buff_err, @buff_out ); 1259 1260 ### capture STDOUT 1261 my $_out_handler = sub { 1262 my $buf = shift; 1263 return unless defined $buf; 1264 1265 print STDOUT $buf if $verbose; 1266 push @buffer, $buf; 1267 push @buff_out, $buf; 1268 }; 1269 1270 ### capture STDERR 1271 my $_err_handler = sub { 1272 my $buf = shift; 1273 return unless defined $buf; 1274 1275 print STDERR $buf if $verbose; 1276 push @buffer, $buf; 1277 push @buff_err, $buf; 1278 }; 1279 1280 1281 ### flag to indicate we have a buffer captured 1282 my $have_buffer = $self->can_capture_buffer ? 1 : 0; 1283 1284 ### flag indicating if the subcall went ok 1285 my $ok; 1286 1287 ### don't look at previous errors: 1288 local $?; 1289 local $@; 1290 local $!; 1291 1292 ### we might be having a timeout set 1293 eval { 1294 local $SIG{ALRM} = sub { die bless sub { 1295 ALARM_CLASS . 1296 qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds] 1297 }, ALARM_CLASS } if $timeout; 1298 alarm $timeout || 0; 1299 1300 ### IPC::Run is first choice if $USE_IPC_RUN is set. 1301 if( !IS_WIN32 and $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) { 1302 ### ipc::run handlers needs the command as a string or an array ref 1303 1304 $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" ) 1305 if $DEBUG; 1306 1307 $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler ); 1308 1309 ### since IPC::Open3 works on all platforms, and just fails on 1310 ### win32 for capturing buffers, do that ideally 1311 } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) { 1312 1313 $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer") 1314 if $DEBUG; 1315 1316 ### in case there are pipes in there; 1317 ### IPC::Open3 will call exec and exec will do the right thing 1318 1319 my $method = IS_WIN32 ? '_open3_run_win32' : '_open3_run'; 1320 1321 $ok = $self->$method( 1322 $cmd, $_out_handler, $_err_handler, $verbose 1323 ); 1324 1325 ### if we are allowed to run verbose, just dispatch the system command 1326 } else { 1327 $self->_debug( "# Using system(). Have buffer: $have_buffer" ) 1328 if $DEBUG; 1329 $ok = $self->_system_run( $cmd, $verbose ); 1330 } 1331 1332 alarm 0; 1333 }; 1334 1335 ### restore STDIN after duping, or STDIN will be closed for 1336 ### this current perl process! 1337 $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds; 1338 1339 my $err; 1340 unless( $ok ) { 1341 ### alarm happened 1342 if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) { 1343 $err = $@->(); # the error code is an expired alarm 1344 1345 ### another error happened, set by the dispatchub 1346 } else { 1347 $err = $self->error; 1348 } 1349 } 1350 1351 ### fill the buffer; 1352 $$buffer = join '', @buffer if @buffer; 1353 1354 ### return a list of flags and buffers (if available) in list 1355 ### context, or just a simple 'ok' in scalar 1356 return wantarray 1357 ? $have_buffer 1358 ? ($ok, $err, \@buffer, \@buff_out, \@buff_err) 1359 : ($ok, $err ) 1360 : $ok 1361 1362 1363} 1364 1365sub _open3_run_win32 { 1366 my $self = shift; 1367 my $cmd = shift; 1368 my $outhand = shift; 1369 my $errhand = shift; 1370 1371 require Socket; 1372 1373 my $pipe = sub { 1374 socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) 1375 or return undef; 1376 shutdown($_[0], 1); # No more writing for reader 1377 shutdown($_[1], 0); # No more reading for writer 1378 return 1; 1379 }; 1380 1381 my $open3 = sub { 1382 local (*TO_CHLD_R, *TO_CHLD_W); 1383 local (*FR_CHLD_R, *FR_CHLD_W); 1384 local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W); 1385 1386 $pipe->(*TO_CHLD_R, *TO_CHLD_W ) or die $^E; 1387 $pipe->(*FR_CHLD_R, *FR_CHLD_W ) or die $^E; 1388 $pipe->(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E; 1389 1390 my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_); 1391 1392 return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R ); 1393 }; 1394 1395 $cmd = [ grep { defined && length } @$cmd ] if ref $cmd; 1396 $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd ); 1397 1398 my ($pid, $to_chld, $fr_chld, $fr_chld_err) = 1399 $open3->( ( ref $cmd ? @$cmd : $cmd ) ); 1400 1401 my $in_sel = IO::Select->new(); 1402 my $out_sel = IO::Select->new(); 1403 1404 my %objs; 1405 1406 $objs{ fileno( $fr_chld ) } = $outhand; 1407 $objs{ fileno( $fr_chld_err ) } = $errhand; 1408 $in_sel->add( $fr_chld ); 1409 $in_sel->add( $fr_chld_err ); 1410 1411 close($to_chld); 1412 1413 while ($in_sel->count() + $out_sel->count()) { 1414 my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef); 1415 1416 for my $fh (@$ins) { 1417 my $obj = $objs{ fileno($fh) }; 1418 my $buf; 1419 my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf)); 1420 if (!$bytes_read) { 1421 $in_sel->remove($fh); 1422 } 1423 else { 1424 $obj->( "$buf" ); 1425 } 1426 } 1427 1428 for my $fh (@$outs) { 1429 } 1430 } 1431 1432 waitpid($pid, 0); 1433 1434 ### some error occurred 1435 if( $? ) { 1436 $self->error( $self->_pp_child_error( $cmd, $? ) ); 1437 $self->ok( 0 ); 1438 return; 1439 } else { 1440 return $self->ok( 1 ); 1441 } 1442} 1443 1444sub _open3_run { 1445 my $self = shift; 1446 my $cmd = shift; 1447 my $_out_handler = shift; 1448 my $_err_handler = shift; 1449 my $verbose = shift || 0; 1450 1451 ### Following code are adapted from Friar 'abstracts' in the 1452 ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886). 1453 ### XXX that code didn't work. 1454 ### we now use the following code, thanks to theorbtwo 1455 1456 ### define them beforehand, so we always have defined FH's 1457 ### to read from. 1458 use Symbol; 1459 my $kidout = Symbol::gensym(); 1460 my $kiderror = Symbol::gensym(); 1461 1462 ### Dup the filehandle so we can pass 'our' STDIN to the 1463 ### child process. This stops us from having to pump input 1464 ### from ourselves to the childprocess. However, we will need 1465 ### to revive the FH afterwards, as IPC::Open3 closes it. 1466 ### We'll do the same for STDOUT and STDERR. It works without 1467 ### duping them on non-unix derivatives, but not on win32. 1468 my @fds_to_dup = ( IS_WIN32 && !$verbose 1469 ? qw[STDIN STDOUT STDERR] 1470 : qw[STDIN] 1471 ); 1472 $self->_fds( \@fds_to_dup ); 1473 $self->__dup_fds( @fds_to_dup ); 1474 1475 ### pipes have to come in a quoted string, and that clashes with 1476 ### whitespace. This sub fixes up such commands so they run properly 1477 $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd ); 1478 1479 ### don't stringify @$cmd, so spaces in filenames/paths are 1480 ### treated properly 1481 my $pid = eval { 1482 IPC::Open3::open3( 1483 '<&STDIN', 1484 (IS_WIN32 ? '>&STDOUT' : $kidout), 1485 (IS_WIN32 ? '>&STDERR' : $kiderror), 1486 ( ref $cmd ? @$cmd : $cmd ), 1487 ); 1488 }; 1489 1490 ### open3 error occurred 1491 if( $@ and $@ =~ /^open3:/ ) { 1492 $self->ok( 0 ); 1493 $self->error( $@ ); 1494 return; 1495 }; 1496 1497 ### use OUR stdin, not $kidin. Somehow, 1498 ### we never get the input.. so jump through 1499 ### some hoops to do it :( 1500 my $selector = IO::Select->new( 1501 (IS_WIN32 ? \*STDERR : $kiderror), 1502 \*STDIN, 1503 (IS_WIN32 ? \*STDOUT : $kidout) 1504 ); 1505 1506 STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1); 1507 $kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush'); 1508 $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush'); 1509 1510 ### add an explicit break statement 1511 ### code courtesy of theorbtwo from #london.pm 1512 my $stdout_done = 0; 1513 my $stderr_done = 0; 1514 OUTER: while ( my @ready = $selector->can_read ) { 1515 1516 for my $h ( @ready ) { 1517 my $buf; 1518 1519 ### $len is the amount of bytes read 1520 my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes 1521 1522 ### see perldoc -f sysread: it returns undef on error, 1523 ### so bail out. 1524 if( not defined $len ) { 1525 warn(loc("Error reading from process: %1", $!)); 1526 last OUTER; 1527 } 1528 1529 ### check for $len. it may be 0, at which point we're 1530 ### done reading, so don't try to process it. 1531 ### if we would print anyway, we'd provide bogus information 1532 $_out_handler->( "$buf" ) if $len && $h == $kidout; 1533 $_err_handler->( "$buf" ) if $len && $h == $kiderror; 1534 1535 ### Wait till child process is done printing to both 1536 ### stdout and stderr. 1537 $stdout_done = 1 if $h == $kidout and $len == 0; 1538 $stderr_done = 1 if $h == $kiderror and $len == 0; 1539 last OUTER if ($stdout_done && $stderr_done); 1540 } 1541 } 1542 1543 waitpid $pid, 0; # wait for it to die 1544 1545 ### restore STDIN after duping, or STDIN will be closed for 1546 ### this current perl process! 1547 ### done in the parent call now 1548 # $self->__reopen_fds( @fds_to_dup ); 1549 1550 ### some error occurred 1551 if( $? ) { 1552 $self->error( $self->_pp_child_error( $cmd, $? ) ); 1553 $self->ok( 0 ); 1554 return; 1555 } else { 1556 return $self->ok( 1 ); 1557 } 1558} 1559 1560### Text::ParseWords::shellwords() uses unix semantics. that will break 1561### on win32 1562{ my $parse_sub = IS_WIN32 1563 ? __PACKAGE__->can('_split_like_shell_win32') 1564 : Text::ParseWords->can('shellwords'); 1565 1566 sub _ipc_run { 1567 my $self = shift; 1568 my $cmd = shift; 1569 my $_out_handler = shift; 1570 my $_err_handler = shift; 1571 1572 STDOUT->autoflush(1); STDERR->autoflush(1); 1573 1574 ### a command like: 1575 # [ 1576 # '/usr/bin/gzip', 1577 # '-cdf', 1578 # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz', 1579 # '|', 1580 # '/usr/bin/tar', 1581 # '-tf -' 1582 # ] 1583 ### needs to become: 1584 # [ 1585 # ['/usr/bin/gzip', '-cdf', 1586 # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz'] 1587 # '|', 1588 # ['/usr/bin/tar', '-tf -'] 1589 # ] 1590 1591 1592 my @command; 1593 my $special_chars; 1594 1595 my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ }; 1596 if( ref $cmd ) { 1597 my $aref = []; 1598 for my $item (@$cmd) { 1599 if( $item =~ $re ) { 1600 push @command, $aref, $item; 1601 $aref = []; 1602 $special_chars .= $1; 1603 } else { 1604 push @$aref, $item; 1605 } 1606 } 1607 push @command, $aref; 1608 } else { 1609 @command = map { if( $_ =~ $re ) { 1610 $special_chars .= $1; $_; 1611 } else { 1612# [ split /\s+/ ] 1613 [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ] 1614 } 1615 } split( /\s*$re\s*/, $cmd ); 1616 } 1617 1618 ### if there's a pipe in the command, *STDIN needs to 1619 ### be inserted *BEFORE* the pipe, to work on win32 1620 ### this also works on *nix, so we should do it when possible 1621 ### this should *also* work on multiple pipes in the command 1622 ### if there's no pipe in the command, append STDIN to the back 1623 ### of the command instead. 1624 ### XXX seems IPC::Run works it out for itself if you just 1625 ### don't pass STDIN at all. 1626 # if( $special_chars and $special_chars =~ /\|/ ) { 1627 # ### only add STDIN the first time.. 1628 # my $i; 1629 # @command = map { ($_ eq '|' && not $i++) 1630 # ? ( \*STDIN, $_ ) 1631 # : $_ 1632 # } @command; 1633 # } else { 1634 # push @command, \*STDIN; 1635 # } 1636 1637 # \*STDIN is already included in the @command, see a few lines up 1638 my $ok = eval { IPC::Run::run( @command, 1639 fileno(STDOUT).'>', 1640 $_out_handler, 1641 fileno(STDERR).'>', 1642 $_err_handler 1643 ) 1644 }; 1645 1646 ### all is well 1647 if( $ok ) { 1648 return $self->ok( $ok ); 1649 1650 ### some error occurred 1651 } else { 1652 $self->ok( 0 ); 1653 1654 ### if the eval fails due to an exception, deal with it 1655 ### unless it's an alarm 1656 if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) { 1657 $self->error( $@ ); 1658 1659 ### if it *is* an alarm, propagate 1660 } elsif( $@ ) { 1661 die $@; 1662 1663 ### some error in the sub command 1664 } else { 1665 $self->error( $self->_pp_child_error( $cmd, $? ) ); 1666 } 1667 1668 return; 1669 } 1670 } 1671} 1672 1673sub _system_run { 1674 my $self = shift; 1675 my $cmd = shift; 1676 my $verbose = shift || 0; 1677 1678 ### pipes have to come in a quoted string, and that clashes with 1679 ### whitespace. This sub fixes up such commands so they run properly 1680 $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd ); 1681 1682 my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR]; 1683 $self->_fds( \@fds_to_dup ); 1684 $self->__dup_fds( @fds_to_dup ); 1685 1686 ### system returns 'true' on failure -- the exit code of the cmd 1687 $self->ok( 1 ); 1688 system( ref $cmd ? @$cmd : $cmd ) == 0 or do { 1689 $self->error( $self->_pp_child_error( $cmd, $? ) ); 1690 $self->ok( 0 ); 1691 }; 1692 1693 ### done in the parent call now 1694 #$self->__reopen_fds( @fds_to_dup ); 1695 1696 return unless $self->ok; 1697 return $self->ok; 1698} 1699 1700{ my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS; 1701 1702 1703 sub __fix_cmd_whitespace_and_special_chars { 1704 my $self = shift; 1705 my $cmd = shift; 1706 1707 ### command has a special char in it 1708 if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) { 1709 1710 ### since we have special chars, we have to quote white space 1711 ### this *may* conflict with the parsing :( 1712 my $fixed; 1713 my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd; 1714 1715 $self->_debug( "# Quoted $fixed arguments containing whitespace" ) 1716 if $DEBUG && $fixed; 1717 1718 ### stringify it, so the special char isn't escaped as argument 1719 ### to the program 1720 $cmd = join ' ', @cmd; 1721 } 1722 1723 return $cmd; 1724 } 1725} 1726 1727### Command-line arguments (but not the command itself) must be quoted 1728### to ensure case preservation. Borrowed from Module::Build with adaptations. 1729### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument 1730### quoting for run() on VMS 1731sub _quote_args_vms { 1732 ### Returns a command string with proper quoting so that the subprocess 1733 ### sees this same list of args, or if we get a single arg that is an 1734 ### array reference, quote the elements of it (except for the first) 1735 ### and return the reference. 1736 my @args = @_; 1737 my $got_arrayref = (scalar(@args) == 1 1738 && UNIVERSAL::isa($args[0], 'ARRAY')) 1739 ? 1 1740 : 0; 1741 1742 @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1; 1743 1744 my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args; 1745 1746 ### Do not quote qualifiers that begin with '/' or previously quoted args. 1747 map { if (/^[^\/\"]/) { 1748 $_ =~ s/\"/""/g; # escape C<"> by doubling 1749 $_ = q(").$_.q("); 1750 } 1751 } 1752 ($got_arrayref ? @{$args[0]} 1753 : @args 1754 ); 1755 1756 $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd); 1757 1758 return $got_arrayref ? $args[0] 1759 : join(' ', @args); 1760} 1761 1762 1763### XXX this is cribbed STRAIGHT from M::B 0.30 here: 1764### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell 1765### XXX this *should* be integrated into text::parsewords 1766sub _split_like_shell_win32 { 1767 # As it turns out, Windows command-parsing is very different from 1768 # Unix command-parsing. Double-quotes mean different things, 1769 # backslashes don't necessarily mean escapes, and so on. So we 1770 # can't use Text::ParseWords::shellwords() to break a command string 1771 # into words. The algorithm below was bashed out by Randy and Ken 1772 # (mostly Randy), and there are a lot of regression tests, so we 1773 # should feel free to adjust if desired. 1774 1775 local $_ = shift; 1776 1777 my @argv; 1778 return @argv unless defined() && length(); 1779 1780 my $arg = ''; 1781 my( $i, $quote_mode ) = ( 0, 0 ); 1782 1783 while ( $i < length() ) { 1784 1785 my $ch = substr( $_, $i , 1 ); 1786 my $next_ch = substr( $_, $i+1, 1 ); 1787 1788 if ( $ch eq '\\' && $next_ch eq '"' ) { 1789 $arg .= '"'; 1790 $i++; 1791 } elsif ( $ch eq '\\' && $next_ch eq '\\' ) { 1792 $arg .= '\\'; 1793 $i++; 1794 } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) { 1795 $quote_mode = !$quote_mode; 1796 $arg .= '"'; 1797 $i++; 1798 } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode && 1799 ( $i + 2 == length() || 1800 substr( $_, $i + 2, 1 ) eq ' ' ) 1801 ) { # for cases like: a"" => [ 'a' ] 1802 push( @argv, $arg ); 1803 $arg = ''; 1804 $i += 2; 1805 } elsif ( $ch eq '"' ) { 1806 $quote_mode = !$quote_mode; 1807 } elsif ( $ch eq ' ' && !$quote_mode ) { 1808 push( @argv, $arg ) if defined( $arg ) && length( $arg ); 1809 $arg = ''; 1810 ++$i while substr( $_, $i + 1, 1 ) eq ' '; 1811 } else { 1812 $arg .= $ch; 1813 } 1814 1815 $i++; 1816 } 1817 1818 push( @argv, $arg ) if defined( $arg ) && length( $arg ); 1819 return @argv; 1820} 1821 1822 1823 1824{ use File::Spec; 1825 use Symbol; 1826 1827 my %Map = ( 1828 STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ], 1829 STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ], 1830 STDIN => [qw|<&|, \*STDIN, Symbol::gensym() ], 1831 ); 1832 1833 ### dups FDs and stores them in a cache 1834 sub __dup_fds { 1835 my $self = shift; 1836 my @fds = @_; 1837 1838 __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG; 1839 1840 for my $name ( @fds ) { 1841 my($redir, $fh, $glob) = @{$Map{$name}} or ( 1842 Carp::carp(loc("No such FD: '%1'", $name)), next ); 1843 1844 ### MUST use the 2-arg version of open for dup'ing for 1845 ### 5.6.x compatibility. 5.8.x can use 3-arg open 1846 ### see perldoc5.6.2 -f open for details 1847 open $glob, $redir . fileno($fh) or ( 1848 Carp::carp(loc("Could not dup '$name': %1", $!)), 1849 return 1850 ); 1851 1852 ### we should re-open this filehandle right now, not 1853 ### just dup it 1854 ### Use 2-arg version of open, as 5.5.x doesn't support 1855 ### 3-arg version =/ 1856 if( $redir eq '>&' ) { 1857 open( $fh, '>' . File::Spec->devnull ) or ( 1858 Carp::carp(loc("Could not reopen '$name': %1", $!)), 1859 return 1860 ); 1861 } 1862 } 1863 1864 return 1; 1865 } 1866 1867 ### reopens FDs from the cache 1868 sub __reopen_fds { 1869 my $self = shift; 1870 my @fds = @_; 1871 1872 __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG; 1873 1874 for my $name ( @fds ) { 1875 my($redir, $fh, $glob) = @{$Map{$name}} or ( 1876 Carp::carp(loc("No such FD: '%1'", $name)), next ); 1877 1878 ### MUST use the 2-arg version of open for dup'ing for 1879 ### 5.6.x compatibility. 5.8.x can use 3-arg open 1880 ### see perldoc5.6.2 -f open for details 1881 open( $fh, $redir . fileno($glob) ) or ( 1882 Carp::carp(loc("Could not restore '$name': %1", $!)), 1883 return 1884 ); 1885 1886 ### close this FD, we're not using it anymore 1887 close $glob; 1888 } 1889 return 1; 1890 1891 } 1892} 1893 1894sub _debug { 1895 my $self = shift; 1896 my $msg = shift or return; 1897 my $level = shift || 0; 1898 1899 local $Carp::CarpLevel += $level; 1900 Carp::carp($msg); 1901 1902 return 1; 1903} 1904 1905sub _pp_child_error { 1906 my $self = shift; 1907 my $cmd = shift or return; 1908 my $ce = shift or return; 1909 my $pp_cmd = ref $cmd ? "@$cmd" : $cmd; 1910 1911 1912 my $str; 1913 if( $ce == -1 ) { 1914 ### Include $! in the error message, so that the user can 1915 ### see 'No such file or directory' versus 'Permission denied' 1916 ### versus 'Cannot fork' or whatever the cause was. 1917 $str = "Failed to execute '$pp_cmd': $!"; 1918 1919 } elsif ( $ce & 127 ) { 1920 ### some signal 1921 $str = loc( "'%1' died with signal %2, %3 coredump", 1922 $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without'); 1923 1924 } else { 1925 ### Otherwise, the command run but gave error status. 1926 $str = "'$pp_cmd' exited with value " . ($ce >> 8); 1927 } 1928 1929 $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG; 1930 1931 return $str; 1932} 1933 19341; 1935 1936=head2 $q = QUOTE 1937 1938Returns the character used for quoting strings on this platform. This is 1939usually a C<'> (single quote) on most systems, but some systems use different 1940quotes. For example, C<Win32> uses C<"> (double quote). 1941 1942You can use it as follows: 1943 1944 use IPC::Cmd qw[run QUOTE]; 1945 my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE; 1946 1947This makes sure that C<foo bar> is treated as a string, rather than two 1948separate arguments to the C<echo> function. 1949 1950__END__ 1951 1952=head1 HOW IT WORKS 1953 1954C<run> will try to execute your command using the following logic: 1955 1956=over 4 1957 1958=item * 1959 1960If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN> 1961is set to true (See the L<"Global Variables"> section) use that to execute 1962the command. You will have the full output available in buffers, interactive commands 1963are sure to work and you are guaranteed to have your verbosity 1964settings honored cleanly. 1965 1966=item * 1967 1968Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true 1969(See the L<"Global Variables"> section), try to execute the command using 1970L<IPC::Open3>. Buffers will be available on all platforms, 1971interactive commands will still execute cleanly, and also your verbosity 1972settings will be adhered to nicely; 1973 1974=item * 1975 1976Otherwise, if you have the C<verbose> argument set to true, we fall back 1977to a simple C<system()> call. We cannot capture any buffers, but 1978interactive commands will still work. 1979 1980=item * 1981 1982Otherwise we will try and temporarily redirect STDERR and STDOUT, do a 1983C<system()> call with your command and then re-open STDERR and STDOUT. 1984This is the method of last resort and will still allow you to execute 1985your commands cleanly. However, no buffers will be available. 1986 1987=back 1988 1989=head1 Global Variables 1990 1991The behaviour of IPC::Cmd can be altered by changing the following 1992global variables: 1993 1994=head2 $IPC::Cmd::VERBOSE 1995 1996This controls whether IPC::Cmd will print any output from the 1997commands to the screen or not. The default is 0. 1998 1999=head2 $IPC::Cmd::USE_IPC_RUN 2000 2001This variable controls whether IPC::Cmd will try to use L<IPC::Run> 2002when available and suitable. 2003 2004=head2 $IPC::Cmd::USE_IPC_OPEN3 2005 2006This variable controls whether IPC::Cmd will try to use L<IPC::Open3> 2007when available and suitable. Defaults to true. 2008 2009=head2 $IPC::Cmd::WARN 2010 2011This variable controls whether run-time warnings should be issued, like 2012the failure to load an C<IPC::*> module you explicitly requested. 2013 2014Defaults to true. Turn this off at your own risk. 2015 2016=head2 $IPC::Cmd::INSTANCES 2017 2018This variable controls whether C<can_run> will return all instances of 2019the binary it finds in the C<PATH> when called in a list context. 2020 2021Defaults to false, set to true to enable the described behaviour. 2022 2023=head2 $IPC::Cmd::ALLOW_NULL_ARGS 2024 2025This variable controls whether C<run> will remove any empty/null arguments 2026it finds in command arguments. 2027 2028Defaults to false, so it will remove null arguments. Set to true to allow 2029them. 2030 2031=head1 Caveats 2032 2033=over 4 2034 2035=item Whitespace and IPC::Open3 / system() 2036 2037When using C<IPC::Open3> or C<system>, if you provide a string as the 2038C<command> argument, it is assumed to be appropriately escaped. You can 2039use the C<QUOTE> constant to use as a portable quote character (see above). 2040However, if you provide an array reference, special rules apply: 2041 2042If your command contains B<special characters> (< > | &), it will 2043be internally stringified before executing the command, to avoid that these 2044special characters are escaped and passed as arguments instead of retaining 2045their special meaning. 2046 2047However, if the command contained arguments that contained whitespace, 2048stringifying the command would lose the significance of the whitespace. 2049Therefore, C<IPC::Cmd> will quote any arguments containing whitespace in your 2050command if the command is passed as an arrayref and contains special characters. 2051 2052=item Whitespace and IPC::Run 2053 2054When using C<IPC::Run>, if you provide a string as the C<command> argument, 2055the string will be split on whitespace to determine the individual elements 2056of your command. Although this will usually just Do What You Mean, it may 2057break if you have files or commands with whitespace in them. 2058 2059If you do not wish this to happen, you should provide an array 2060reference, where all parts of your command are already separated out. 2061Note however, if there are extra or spurious whitespaces in these parts, 2062the parser or underlying code may not interpret it correctly, and 2063cause an error. 2064 2065Example: 2066The following code 2067 2068 gzip -cdf foo.tar.gz | tar -xf - 2069 2070should either be passed as 2071 2072 "gzip -cdf foo.tar.gz | tar -xf -" 2073 2074or as 2075 2076 ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-'] 2077 2078But take care not to pass it as, for example 2079 2080 ['gzip -cdf foo.tar.gz', '|', 'tar -xf -'] 2081 2082Since this will lead to issues as described above. 2083 2084 2085=item IO Redirect 2086 2087Currently it is too complicated to parse your command for IO 2088redirections. For capturing STDOUT or STDERR there is a work around 2089however, since you can just inspect your buffers for the contents. 2090 2091=item Interleaving STDOUT/STDERR 2092 2093Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short 2094bursts of output from a program, e.g. this sample, 2095 2096 for ( 1..4 ) { 2097 $_ % 2 ? print STDOUT $_ : print STDERR $_; 2098 } 2099 2100IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning 2101the output looks like '13' on STDOUT and '24' on STDERR, instead of 2102 2103 1 2104 2 2105 3 2106 4 2107 2108This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave 2109STDOUT and STDERR. 2110 2111=back 2112 2113=head1 See Also 2114 2115L<IPC::Run>, L<IPC::Open3> 2116 2117=head1 ACKNOWLEDGEMENTS 2118 2119Thanks to James Mastros and Martijn van der Streek for their 2120help in getting L<IPC::Open3> to behave nicely. 2121 2122Thanks to Petya Kohts for the C<run_forked> code. 2123 2124=head1 BUG REPORTS 2125 2126Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>. 2127 2128=head1 AUTHOR 2129 2130Original author: Jos Boumans E<lt>kane@cpan.orgE<gt>. 2131Current maintainer: Chris Williams E<lt>bingos@cpan.orgE<gt>. 2132 2133=head1 COPYRIGHT 2134 2135This library is free software; you may redistribute and/or modify it 2136under the same terms as Perl itself. 2137 2138=cut 2139