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