lib/IPC/Cmd.pm

   1 package IPC::Cmd;
   2
   3 use strict;
   4
   5 BEGIN {
   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 $WARN
  17                     ];
  18
  19     $VERSION        = '0.46';
  20     $VERBOSE        = 0;
  21     $DEBUG          = 0;
  22     $WARN           = 1;
  23     $USE_IPC_RUN    = IS_WIN32 && !IS_WIN98;
  24     $USE_IPC_OPEN3  = not IS_VMS;
  25
  26     @ISA            = qw[Exporter];
  27     @EXPORT_OK      = qw[can_run run QUOTE];
  28 }
  29
  30 require Carp;
  31 use File::Spec;
  32 use Params::Check               qw[check];
  33 use Text::ParseWords            ();             # import ONLY if needed!
  34 use Module::Load::Conditional   qw[can_load];
  35 use Locale::Maketext::Simple    Style => 'gettext';
  36
  37 =pod
  38
  39 =head1 NAME
  40
  41 IPC::Cmd - finding and running system commands made easy
  42
  43 =head1 SYNOPSIS
  44
  45     use IPC::Cmd qw[can_run run];
  46
  47     my $full_path = can_run('wget') or warn 'wget is not installed!';
  48
  49     ### commands can be arrayrefs or strings ###
  50     my $cmd = "$full_path -b theregister.co.uk";
  51     my $cmd = [$full_path, '-b', 'theregister.co.uk'];
  52
  53     ### in scalar context ###
  54     my $buffer;
  55     if( scalar run( command => $cmd,
  56                     verbose => 0,
  57                     buffer  => \$buffer,
  58                     timeout => 20 )
  59     ) {
  60         print "fetched webpage successfully: $buffer\n";
  61     }
  62
  63
  64     ### in list context ###
  65     my( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
  66             run( command => $cmd, verbose => 0 );
  67
  68     if( $success ) {
  69         print "this is what the command printed:\n";
  70         print join "", @$full_buf;
  71     }
  72
  73     ### check for features
  74     print "IPC::Open3 available: "  . IPC::Cmd->can_use_ipc_open3;
  75     print "IPC::Run available: "    . IPC::Cmd->can_use_ipc_run;
  76     print "Can capture buffer: "    . IPC::Cmd->can_capture_buffer;
  77
  78     ### don't have IPC::Cmd be verbose, ie don't print to stdout or
  79     ### stderr when running commands -- default is '0'
  80     $IPC::Cmd::VERBOSE = 0;
  81
  82
  83 =head1 DESCRIPTION
  84
  85 IPC::Cmd allows you to run commands, interactively if desired,
  86 platform independent but have them still work.
  87
  88 The C<can_run> function can tell you if a certain binary is installed
  89 and if so where, whereas the C<run> function can actually execute any
  90 of the commands you give it and give you a clear return value, as well
  91 as adhere to your verbosity settings.
  92
  93 =head1 CLASS METHODS
  94
  95 =head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
  96
  97 Utility function that tells you if C<IPC::Run> is available.
  98 If the verbose flag is passed, it will print diagnostic messages
  99 if C<IPC::Run> can not be found or loaded.
 100
 101 =cut
 102
 103
 104 sub can_use_ipc_run     {
 105     my $self    = shift;
 106     my $verbose = shift || 0;
 107
 108     ### ipc::run doesn't run on win98
 109     return if IS_WIN98;
 110
 111     ### if we dont have ipc::run, we obviously can't use it.
 112     return unless can_load(
 113                         modules => { 'IPC::Run' => '0.55' },
 114                         verbose => ($WARN && $verbose),
 115                     );
 116
 117     ### otherwise, we're good to go
 118     return $IPC::Run::VERSION;
 119 }
 120
 121 =head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
 122
 123 Utility function that tells you if C<IPC::Open3> is available.
 124 If the verbose flag is passed, it will print diagnostic messages
 125 if C<IPC::Open3> can not be found or loaded.
 126
 127 =cut
 128
 129
 130 sub can_use_ipc_open3   {
 131     my $self    = shift;
 132     my $verbose = shift || 0;
 133
 134     ### ipc::open3 is not working on VMS becasue of a lack of fork.
 135     ### XXX todo, win32 also does not have fork, so need to do more research.
 136     return if IS_VMS;
 137
 138     ### ipc::open3 works on every non-VMS platform platform, but it can't
 139     ### capture buffers on win32 :(
 140     return unless can_load(
 141         modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
 142         verbose => ($WARN && $verbose),
 143     );
 144
 145     return $IPC::Open3::VERSION;
 146 }
 147
 148 =head2 $bool = IPC::Cmd->can_capture_buffer
 149
 150 Utility function that tells you if C<IPC::Cmd> is capable of
 151 capturing buffers in it's current configuration.
 152
 153 =cut
 154
 155 sub can_capture_buffer {
 156     my $self    = shift;
 157
 158     return 1 if $USE_IPC_RUN    && $self->can_use_ipc_run;
 159     return 1 if $USE_IPC_OPEN3  && $self->can_use_ipc_open3 && !IS_WIN32;
 160     return;
 161 }
 162
 163
 164 =head1 FUNCTIONS
 165
 166 =head2 $path = can_run( PROGRAM );
 167
 168 C<can_run> takes but a single argument: the name of a binary you wish
 169 to locate. C<can_run> works much like the unix binary C<which> or the bash
 170 command C<type>, which scans through your path, looking for the requested
 171 binary .
 172
 173 Unlike C<which> and C<type>, this function is platform independent and
 174 will also work on, for example, Win32.
 175
 176 It will return the full path to the binary you asked for if it was
 177 found, or C<undef> if it was not.
 178
 179 =cut
 180
 181 sub can_run {
 182     my $command = shift;
 183
 184     # a lot of VMS executables have a symbol defined
 185     # check those first
 186     if ( $^O eq 'VMS' ) {
 187         require VMS::DCLsym;
 188         my $syms = VMS::DCLsym->new;
 189         return $command if scalar $syms->getsym( uc $command );
 190     }
 191
 192     require Config;
 193     require File::Spec;
 194     require ExtUtils::MakeMaker;
 195
 196     if( File::Spec->file_name_is_absolute($command) ) {
 197         return MM->maybe_command($command);
 198
 199     } else {
 200         for my $dir (
 201             (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
 202             File::Spec->curdir
 203         ) {
 204             my $abs = File::Spec->catfile($dir, $command);
 205             return $abs if $abs = MM->maybe_command($abs);
 206         }
 207     }
 208 }
 209
 210 =head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
 211
 212 C<run> takes 4 arguments:
 213
 214 =over 4
 215
 216 =item command
 217
 218 This is the command to execute. It may be either a string or an array
 219 reference.
 220 This is a required argument.
 221
 222 See L<CAVEATS> for remarks on how commands are parsed and their
 223 limitations.
 224
 225 =item verbose
 226
 227 This controls whether all output of a command should also be printed
 228 to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
 229 require C<IPC::Run> to be installed or your system able to work with
 230 C<IPC::Open3>).
 231
 232 It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
 233 which by default is 0.
 234
 235 =item buffer
 236
 237 This will hold all the output of a command. It needs to be a reference
 238 to a scalar.
 239 Note that this will hold both the STDOUT and STDERR messages, and you
 240 have no way of telling which is which.
 241 If you require this distinction, run the C<run> command in list context
 242 and inspect the individual buffers.
 243
 244 Of course, this requires that the underlying call supports buffers. See
 245 the note on buffers right above.
 246
 247 =item timeout
 248
 249 Sets the maximum time the command is allowed to run before aborting,
 250 using the built-in C<alarm()> call. If the timeout is triggered, the
 251 C<errorcode> in the return value will be set to an object of the
 252 C<IPC::Cmd::TimeOut> class. See the C<errorcode> section below for
 253 details.
 254
 255 Defaults to C<0>, meaning no timeout is set.
 256
 257 =back
 258
 259 C<run> will return a simple C<true> or C<false> when called in scalar
 260 context.
 261 In list context, you will be returned a list of the following items:
 262
 263 =over 4
 264
 265 =item success
 266
 267 A simple boolean indicating if the command executed without errors or
 268 not.
 269
 270 =item error message
 271
 272 If the first element of the return value (success) was 0, then some
 273 error occurred. This second element is the error message the command
 274 you requested exited with, if available. This is generally a pretty
 275 printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
 276 what they can contain.
 277 If the error was a timeout, the C<error message> will be prefixed with
 278 the string C<IPC::Cmd::TimeOut>, the timeout class.
 279
 280 =item full_buffer
 281
 282 This is an arrayreference containing all the output the command
 283 generated.
 284 Note that buffers are only available if you have C<IPC::Run> installed,
 285 or if your system is able to work with C<IPC::Open3> -- See below).
 286 This element will be C<undef> if this is not the case.
 287
 288 =item out_buffer
 289
 290 This is an arrayreference containing all the output sent to STDOUT the
 291 command generated.
 292 Note that buffers are only available if you have C<IPC::Run> installed,
 293 or if your system is able to work with C<IPC::Open3> -- See below).
 294 This element will be C<undef> if this is not the case.
 295
 296 =item error_buffer
 297
 298 This is an arrayreference containing all the output sent to STDERR the
 299 command generated.
 300 Note that buffers are only available if you have C<IPC::Run> installed,
 301 or if your system is able to work with C<IPC::Open3> -- See below).
 302 This element will be C<undef> if this is not the case.
 303
 304 =back
 305
 306 See the C<HOW IT WORKS> Section below to see how C<IPC::Cmd> decides
 307 what modules or function calls to use when issuing a command.
 308
 309 =cut
 310
 311 {   my @acc = qw[ok error _fds];
 312
 313     ### autogenerate accessors ###
 314     for my $key ( @acc ) {
 315         no strict 'refs';
 316         *{__PACKAGE__."::$key"} = sub {
 317             $_[0]->{$key} = $_[1] if @_ > 1;
 318             return $_[0]->{$key};
 319         }
 320     }
 321 }
 322
 323 sub run {
 324     ### container to store things in
 325     my $self = bless {}, __PACKAGE__;
 326
 327     my %hash = @_;
 328
 329     ### if the user didn't provide a buffer, we'll store it here.
 330     my $def_buf = '';
 331
 332     my($verbose,$cmd,$buffer,$timeout);
 333     my $tmpl = {
 334         verbose => { default  => $VERBOSE,  store => \$verbose },
 335         buffer  => { default  => \$def_buf, store => \$buffer },
 336         command => { required => 1,         store => \$cmd,
 337                      allow    => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
 338         },
 339         timeout => { default  => 0,         store => \$timeout },
 340     };
 341
 342     unless( check( $tmpl, \%hash, $VERBOSE ) ) {
 343         Carp::carp( loc( "Could not validate input: %1",
 344                          Params::Check->last_error ) );
 345         return;
 346     };
 347
 348     $cmd = _quote_args_vms( $cmd ) if IS_VMS;
 349
 350     ### strip any empty elements from $cmd if present
 351     $cmd = [ grep { length && defined } @$cmd ] if ref $cmd;
 352
 353     my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
 354     print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
 355
 356     ### did the user pass us a buffer to fill or not? if so, set this
 357     ### flag so we know what is expected of us
 358     ### XXX this is now being ignored. in the future, we could add diagnostic
 359     ### messages based on this logic
 360     #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
 361
 362     ### buffers that are to be captured
 363     my( @buffer, @buff_err, @buff_out );
 364
 365     ### capture STDOUT
 366     my $_out_handler = sub {
 367         my $buf = shift;
 368         return unless defined $buf;
 369
 370         print STDOUT $buf if $verbose;
 371         push @buffer,   $buf;
 372         push @buff_out, $buf;
 373     };
 374
 375     ### capture STDERR
 376     my $_err_handler = sub {
 377         my $buf = shift;
 378         return unless defined $buf;
 379
 380         print STDERR $buf if $verbose;
 381         push @buffer,   $buf;
 382         push @buff_err, $buf;
 383     };
 384
 385
 386     ### flag to indicate we have a buffer captured
 387     my $have_buffer = $self->can_capture_buffer ? 1 : 0;
 388
 389     ### flag indicating if the subcall went ok
 390     my $ok;
 391
 392     ### dont look at previous errors:
 393     local $?;
 394     local $@;
 395     local $!;
 396
 397     ### we might be having a timeout set
 398     eval {
 399         local $SIG{ALRM} = sub { die bless sub {
 400             ALARM_CLASS .
 401             qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
 402         }, ALARM_CLASS } if $timeout;
 403         alarm $timeout || 0;
 404
 405         ### IPC::Run is first choice if $USE_IPC_RUN is set.
 406         if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
 407             ### ipc::run handlers needs the command as a string or an array ref
 408
 409             $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
 410                 if $DEBUG;
 411
 412             $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
 413
 414         ### since IPC::Open3 works on all platforms, and just fails on
 415         ### win32 for capturing buffers, do that ideally
 416         } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
 417
 418             $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
 419                 if $DEBUG;
 420
 421             ### in case there are pipes in there;
 422             ### IPC::Open3 will call exec and exec will do the right thing
 423             $ok = $self->_open3_run(
 424                                     $cmd, $_out_handler, $_err_handler, $verbose
 425                                 );
 426
 427         ### if we are allowed to run verbose, just dispatch the system command
 428         } else {
 429             $self->_debug( "# Using system(). Have buffer: $have_buffer" )
 430                 if $DEBUG;
 431             $ok = $self->_system_run( $cmd, $verbose );
 432         }
 433
 434         alarm 0;
 435     };
 436
 437     ### restore STDIN after duping, or STDIN will be closed for
 438     ### this current perl process!
 439     $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
 440
 441     my $err;
 442     unless( $ok ) {
 443         ### alarm happened
 444         if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
 445             $err = $@->();  # the error code is an expired alarm
 446
 447         ### another error happened, set by the dispatchub
 448         } else {
 449             $err = $self->error;
 450         }
 451     }
 452
 453     ### fill the buffer;
 454     $$buffer = join '', @buffer if @buffer;
 455
 456     ### return a list of flags and buffers (if available) in list
 457     ### context, or just a simple 'ok' in scalar
 458     return wantarray
 459                 ? $have_buffer
 460                     ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
 461                     : ($ok, $err )
 462                 : $ok
 463
 464
 465 }
 466
 467 sub _open3_run {
 468     my $self            = shift;
 469     my $cmd             = shift;
 470     my $_out_handler    = shift;
 471     my $_err_handler    = shift;
 472     my $verbose         = shift || 0;
 473
 474     ### Following code are adapted from Friar 'abstracts' in the
 475     ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
 476     ### XXX that code didn't work.
 477     ### we now use the following code, thanks to theorbtwo
 478
 479     ### define them beforehand, so we always have defined FH's
 480     ### to read from.
 481     use Symbol;
 482     my $kidout      = Symbol::gensym();
 483     my $kiderror    = Symbol::gensym();
 484
 485     ### Dup the filehandle so we can pass 'our' STDIN to the
 486     ### child process. This stops us from having to pump input
 487     ### from ourselves to the childprocess. However, we will need
 488     ### to revive the FH afterwards, as IPC::Open3 closes it.
 489     ### We'll do the same for STDOUT and STDERR. It works without
 490     ### duping them on non-unix derivatives, but not on win32.
 491     my @fds_to_dup = ( IS_WIN32 && !$verbose
 492                             ? qw[STDIN STDOUT STDERR]
 493                             : qw[STDIN]
 494                         );
 495     $self->_fds( \@fds_to_dup );
 496     $self->__dup_fds( @fds_to_dup );
 497
 498     ### pipes have to come in a quoted string, and that clashes with
 499     ### whitespace. This sub fixes up such commands so they run properly
 500     $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
 501
 502     ### dont stringify @$cmd, so spaces in filenames/paths are
 503     ### treated properly
 504     my $pid = eval {
 505         IPC::Open3::open3(
 506                     '<&STDIN',
 507                     (IS_WIN32 ? '>&STDOUT' : $kidout),
 508                     (IS_WIN32 ? '>&STDERR' : $kiderror),
 509                     ( ref $cmd ? @$cmd : $cmd ),
 510                 );
 511     };
 512
 513     ### open3 error occurred
 514     if( $@ and $@ =~ /^open3:/ ) {
 515         $self->ok( 0 );
 516         $self->error( $@ );
 517         return;
 518     };
 519
 520     ### use OUR stdin, not $kidin. Somehow,
 521     ### we never get the input.. so jump through
 522     ### some hoops to do it :(
 523     my $selector = IO::Select->new(
 524                         (IS_WIN32 ? \*STDERR : $kiderror),
 525                         \*STDIN,
 526                         (IS_WIN32 ? \*STDOUT : $kidout)
 527                     );
 528
 529     STDOUT->autoflush(1);   STDERR->autoflush(1);   STDIN->autoflush(1);
 530     $kidout->autoflush(1)   if UNIVERSAL::can($kidout,   'autoflush');
 531     $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
 532
 533     ### add an epxlicit break statement
 534     ### code courtesy of theorbtwo from #london.pm
 535     my $stdout_done = 0;
 536     my $stderr_done = 0;
 537     OUTER: while ( my @ready = $selector->can_read ) {
 538
 539         for my $h ( @ready ) {
 540             my $buf;
 541
 542             ### $len is the amount of bytes read
 543             my $len = sysread( $h, $buf, 4096 );    # try to read 4096 bytes
 544
 545             ### see perldoc -f sysread: it returns undef on error,
 546             ### so bail out.
 547             if( not defined $len ) {
 548                 warn(loc("Error reading from process: %1", $!));
 549                 last OUTER;
 550             }
 551
 552             ### check for $len. it may be 0, at which point we're
 553             ### done reading, so don't try to process it.
 554             ### if we would print anyway, we'd provide bogus information
 555             $_out_handler->( "$buf" ) if $len && $h == $kidout;
 556             $_err_handler->( "$buf" ) if $len && $h == $kiderror;
 557
 558             ### Wait till child process is done printing to both
 559             ### stdout and stderr.
 560             $stdout_done = 1 if $h == $kidout   and $len == 0;
 561             $stderr_done = 1 if $h == $kiderror and $len == 0;
 562             last OUTER if ($stdout_done && $stderr_done);
 563         }
 564     }
 565
 566     waitpid $pid, 0; # wait for it to die
 567
 568     ### restore STDIN after duping, or STDIN will be closed for
 569     ### this current perl process!
 570     ### done in the parent call now
 571     # $self->__reopen_fds( @fds_to_dup );
 572
 573     ### some error occurred
 574     if( $? ) {
 575         $self->error( $self->_pp_child_error( $cmd, $? ) );
 576         $self->ok( 0 );
 577         return;
 578     } else {
 579         return $self->ok( 1 );
 580     }
 581 }
 582
 583 ### text::parsewords::shellwordss() uses unix semantics. that will break
 584 ### on win32
 585 {   my $parse_sub = IS_WIN32
 586                         ? __PACKAGE__->can('_split_like_shell_win32')
 587                         : Text::ParseWords->can('shellwords');
 588
 589     sub _ipc_run {
 590         my $self            = shift;
 591         my $cmd             = shift;
 592         my $_out_handler    = shift;
 593         my $_err_handler    = shift;
 594
 595         STDOUT->autoflush(1); STDERR->autoflush(1);
 596
 597         ### a command like:
 598         # [
 599         #     '/usr/bin/gzip',
 600         #     '-cdf',
 601         #     '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
 602         #     '|',
 603         #     '/usr/bin/tar',
 604         #     '-tf -'
 605         # ]
 606         ### needs to become:
 607         # [
 608         #     ['/usr/bin/gzip', '-cdf',
 609         #       '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
 610         #     '|',
 611         #     ['/usr/bin/tar', '-tf -']
 612         # ]
 613
 614
 615         my @command;
 616         my $special_chars;
 617
 618         my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
 619         if( ref $cmd ) {
 620             my $aref = [];
 621             for my $item (@$cmd) {
 622                 if( $item =~ $re ) {
 623                     push @command, $aref, $item;
 624                     $aref = [];
 625                     $special_chars .= $1;
 626                 } else {
 627                     push @$aref, $item;
 628                 }
 629             }
 630             push @command, $aref;
 631         } else {
 632             @command = map { if( $_ =~ $re ) {
 633                                 $special_chars .= $1; $_;
 634                              } else {
 635 #                                [ split /\s+/ ]
 636                                  [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
 637                              }
 638                         } split( /\s*$re\s*/, $cmd );
 639         }
 640
 641         ### if there's a pipe in the command, *STDIN needs to
 642         ### be inserted *BEFORE* the pipe, to work on win32
 643         ### this also works on *nix, so we should do it when possible
 644         ### this should *also* work on multiple pipes in the command
 645         ### if there's no pipe in the command, append STDIN to the back
 646         ### of the command instead.
 647         ### XXX seems IPC::Run works it out for itself if you just
 648         ### dont pass STDIN at all.
 649         #     if( $special_chars and $special_chars =~ /\|/ ) {
 650         #         ### only add STDIN the first time..
 651         #         my $i;
 652         #         @command = map { ($_ eq '|' && not $i++)
 653         #                             ? ( \*STDIN, $_ )
 654         #                             : $_
 655         #                         } @command;
 656         #     } else {
 657         #         push @command, \*STDIN;
 658         #     }
 659
 660         # \*STDIN is already included in the @command, see a few lines up
 661         my $ok = eval { IPC::Run::run(   @command,
 662                                 fileno(STDOUT).'>',
 663                                 $_out_handler,
 664                                 fileno(STDERR).'>',
 665                                 $_err_handler
 666                             )
 667                         };
 668
 669         ### all is well
 670         if( $ok ) {
 671             return $self->ok( $ok );
 672
 673         ### some error occurred
 674         } else {
 675             $self->ok( 0 );
 676
 677             ### if the eval fails due to an exception, deal with it
 678             ### unless it's an alarm
 679             if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
 680                 $self->error( $@ );
 681
 682             ### if it *is* an alarm, propagate
 683             } elsif( $@ ) {
 684                 die $@;
 685
 686             ### some error in the sub command
 687             } else {
 688                 $self->error( $self->_pp_child_error( $cmd, $? ) );
 689             }
 690
 691             return;
 692         }
 693     }
 694 }
 695
 696 sub _system_run {
 697     my $self    = shift;
 698     my $cmd     = shift;
 699     my $verbose = shift || 0;
 700
 701     ### pipes have to come in a quoted string, and that clashes with
 702     ### whitespace. This sub fixes up such commands so they run properly
 703     $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
 704
 705     my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
 706     $self->_fds( \@fds_to_dup );
 707     $self->__dup_fds( @fds_to_dup );
 708
 709     ### system returns 'true' on failure -- the exit code of the cmd
 710     $self->ok( 1 );
 711     system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
 712         $self->error( $self->_pp_child_error( $cmd, $? ) );
 713         $self->ok( 0 );
 714     };
 715
 716     ### done in the parent call now
 717     #$self->__reopen_fds( @fds_to_dup );
 718
 719     return unless $self->ok;
 720     return $self->ok;
 721 }
 722
 723 {   my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
 724
 725
 726     sub __fix_cmd_whitespace_and_special_chars {
 727         my $self = shift;
 728         my $cmd  = shift;
 729
 730         ### command has a special char in it
 731         if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
 732
 733             ### since we have special chars, we have to quote white space
 734             ### this *may* conflict with the parsing :(
 735             my $fixed;
 736             my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
 737
 738             $self->_debug( "# Quoted $fixed arguments containing whitespace" )
 739                     if $DEBUG && $fixed;
 740
 741             ### stringify it, so the special char isn't escaped as argument
 742             ### to the program
 743             $cmd = join ' ', @cmd;
 744         }
 745
 746         return $cmd;
 747     }
 748 }
 749
 750 ### Command-line arguments (but not the command itself) must be quoted
 751 ### to ensure case preservation. Borrowed from Module::Build with adaptations.
 752 ### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
 753 ### quoting for run() on VMS
 754 sub _quote_args_vms {
 755   ### Returns a command string with proper quoting so that the subprocess
 756   ### sees this same list of args, or if we get a single arg that is an
 757   ### array reference, quote the elements of it (except for the first)
 758   ### and return the reference.
 759   my @args = @_;
 760   my $got_arrayref = (scalar(@args) == 1
 761                       && UNIVERSAL::isa($args[0], 'ARRAY'))
 762                    ? 1
 763                    : 0;
 764
 765   @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;
 766
 767   my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
 768
 769   ### Do not quote qualifiers that begin with '/' or previously quoted args.
 770   map { if (/^[^\/\"]/) {
 771           $_ =~ s/\"/""/g;     # escape C<"> by doubling
 772           $_ = q(").$_.q(");
 773         }
 774   }
 775     ($got_arrayref ? @{$args[0]}
 776                    : @args
 777     );
 778
 779   $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
 780
 781   return $got_arrayref ? $args[0]
 782                        : join(' ', @args);
 783 }
 784
 785
 786 ### XXX this is cribbed STRAIGHT from M::B 0.30 here:
 787 ### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
 788 ### XXX this *should* be integrated into text::parsewords
 789 sub _split_like_shell_win32 {
 790   # As it turns out, Windows command-parsing is very different from
 791   # Unix command-parsing.  Double-quotes mean different things,
 792   # backslashes don't necessarily mean escapes, and so on.  So we
 793   # can't use Text::ParseWords::shellwords() to break a command string
 794   # into words.  The algorithm below was bashed out by Randy and Ken
 795   # (mostly Randy), and there are a lot of regression tests, so we
 796   # should feel free to adjust if desired.
 797
 798   local $_ = shift;
 799
 800   my @argv;
 801   return @argv unless defined() && length();
 802
 803   my $arg = '';
 804   my( $i, $quote_mode ) = ( 0, 0 );
 805
 806   while ( $i < length() ) {
 807
 808     my $ch      = substr( $_, $i  , 1 );
 809     my $next_ch = substr( $_, $i+1, 1 );
 810
 811     if ( $ch eq '\\' && $next_ch eq '"' ) {
 812       $arg .= '"';
 813       $i++;
 814     } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
 815       $arg .= '\\';
 816       $i++;
 817     } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
 818       $quote_mode = !$quote_mode;
 819       $arg .= '"';
 820       $i++;
 821     } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
 822           ( $i + 2 == length()  ||
 823         substr( $_, $i + 2, 1 ) eq ' ' )
 824         ) { # for cases like: a"" => [ 'a' ]
 825       push( @argv, $arg );
 826       $arg = '';
 827       $i += 2;
 828     } elsif ( $ch eq '"' ) {
 829       $quote_mode = !$quote_mode;
 830     } elsif ( $ch eq ' ' && !$quote_mode ) {
 831       push( @argv, $arg ) if $arg;
 832       $arg = '';
 833       ++$i while substr( $_, $i + 1, 1 ) eq ' ';
 834     } else {
 835       $arg .= $ch;
 836     }
 837
 838     $i++;
 839   }
 840
 841   push( @argv, $arg ) if defined( $arg ) && length( $arg );
 842   return @argv;
 843 }
 844
 845
 846
 847 {   use File::Spec;
 848     use Symbol;
 849
 850     my %Map = (
 851         STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
 852         STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
 853         STDIN  => [qw|<&|, \*STDIN,  Symbol::gensym() ],
 854     );
 855
 856     ### dups FDs and stores them in a cache
 857     sub __dup_fds {
 858         my $self    = shift;
 859         my @fds     = @_;
 860
 861         __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
 862
 863         for my $name ( @fds ) {
 864             my($redir, $fh, $glob) = @{$Map{$name}} or (
 865                 Carp::carp(loc("No such FD: '%1'", $name)), next );
 866
 867             ### MUST use the 2-arg version of open for dup'ing for
 868             ### 5.6.x compatibilty. 5.8.x can use 3-arg open
 869             ### see perldoc5.6.2 -f open for details
 870             open $glob, $redir . fileno($fh) or (
 871                         Carp::carp(loc("Could not dup '$name': %1", $!)),
 872                         return
 873                     );
 874
 875             ### we should re-open this filehandle right now, not
 876             ### just dup it
 877             ### Use 2-arg version of open, as 5.5.x doesn't support
 878             ### 3-arg version =/
 879             if( $redir eq '>&' ) {
 880                 open( $fh, '>' . File::Spec->devnull ) or (
 881                     Carp::carp(loc("Could not reopen '$name': %1", $!)),
 882                     return
 883                 );
 884             }
 885         }
 886
 887         return 1;
 888     }
 889
 890     ### reopens FDs from the cache
 891     sub __reopen_fds {
 892         my $self    = shift;
 893         my @fds     = @_;
 894
 895         __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
 896
 897         for my $name ( @fds ) {
 898             my($redir, $fh, $glob) = @{$Map{$name}} or (
 899                 Carp::carp(loc("No such FD: '%1'", $name)), next );
 900
 901             ### MUST use the 2-arg version of open for dup'ing for
 902             ### 5.6.x compatibilty. 5.8.x can use 3-arg open
 903             ### see perldoc5.6.2 -f open for details
 904             open( $fh, $redir . fileno($glob) ) or (
 905                     Carp::carp(loc("Could not restore '$name': %1", $!)),
 906                     return
 907                 );
 908
 909             ### close this FD, we're not using it anymore
 910             close $glob;
 911         }
 912         return 1;
 913
 914     }
 915 }
 916
 917 sub _debug {
 918     my $self    = shift;
 919     my $msg     = shift or return;
 920     my $level   = shift || 0;
 921
 922     local $Carp::CarpLevel += $level;
 923     Carp::carp($msg);
 924
 925     return 1;
 926 }
 927
 928 sub _pp_child_error {
 929     my $self    = shift;
 930     my $cmd     = shift or return;
 931     my $ce      = shift or return;
 932     my $pp_cmd  = ref $cmd ? "@$cmd" : $cmd;
 933
 934
 935     my $str;
 936     if( $ce == -1 ) {
 937         ### Include $! in the error message, so that the user can
 938         ### see 'No such file or directory' versus 'Permission denied'
 939         ### versus 'Cannot fork' or whatever the cause was.
 940         $str = "Failed to execute '$pp_cmd': $!";
 941
 942     } elsif ( $ce & 127 ) {
 943         ### some signal
 944         $str = loc( "'%1' died with signal %d, %s coredump\n",
 945                $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
 946
 947     } else {
 948         ### Otherwise, the command run but gave error status.
 949         $str = "'$pp_cmd' exited with value " . ($ce >> 8);
 950     }
 951
 952     $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
 953
 954     return $str;
 955 }
 956
 957 1;
 958
 959 =head2 $q = QUOTE
 960
 961 Returns the character used for quoting strings on this platform. This is
 962 usually a C<'> (single quote) on most systems, but some systems use different
 963 quotes. For example, C<Win32> uses C<"> (double quote).
 964
 965 You can use it as follows:
 966
 967   use IPC::Cmd qw[run QUOTE];
 968   my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
 969
 970 This makes sure that C<foo bar> is treated as a string, rather than two
 971 seperate arguments to the C<echo> function.
 972
 973 __END__
 974
 975 =head1 HOW IT WORKS
 976
 977 C<run> will try to execute your command using the following logic:
 978
 979 =over 4
 980
 981 =item *
 982
 983 If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
 984 is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute
 985 the command. You will have the full output available in buffers, interactive commands are sure to work  and you are guaranteed to have your verbosity
 986 settings honored cleanly.
 987
 988 =item *
 989
 990 Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
 991 (See the C<GLOBAL VARIABLES> Section), try to execute the command using
 992 C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
 993 interactive commands will still execute cleanly, and also your verbosity
 994 settings will be adhered to nicely;
 995
 996 =item *
 997
 998 Otherwise, if you have the verbose argument set to true, we fall back
 999 to a simple system() call. We cannot capture any buffers, but
1000 interactive commands will still work.
1001
1002 =item *
1003
1004 Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
1005 system() call with your command and then re-open STDERR and STDOUT.
1006 This is the method of last resort and will still allow you to execute
1007 your commands cleanly. However, no buffers will be available.
1008
1009 =back
1010
1011 =head1 Global Variables
1012
1013 The behaviour of IPC::Cmd can be altered by changing the following
1014 global variables:
1015
1016 =head2 $IPC::Cmd::VERBOSE
1017
1018 This controls whether IPC::Cmd will print any output from the
1019 commands to the screen or not. The default is 0;
1020
1021 =head2 $IPC::Cmd::USE_IPC_RUN
1022
1023 This variable controls whether IPC::Cmd will try to use L<IPC::Run>
1024 when available and suitable. Defaults to true if you are on C<Win32>.
1025
1026 =head2 $IPC::Cmd::USE_IPC_OPEN3
1027
1028 This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
1029 when available and suitable. Defaults to true.
1030
1031 =head2 $IPC::Cmd::WARN
1032
1033 This variable controls whether run time warnings should be issued, like
1034 the failure to load an C<IPC::*> module you explicitly requested.
1035
1036 Defaults to true. Turn this off at your own risk.
1037
1038 =head1 Caveats
1039
1040 =over 4
1041
1042 =item Whitespace and IPC::Open3 / system()
1043
1044 When using C<IPC::Open3> or C<system>, if you provide a string as the
1045 C<command> argument, it is assumed to be appropriately escaped. You can
1046 use the C<QUOTE> constant to use as a portable quote character (see above).
1047 However, if you provide and C<Array Reference>, special rules apply:
1048
1049 If your command contains C<Special Characters> (< > | &), it will
1050 be internally stringified before executing the command, to avoid that these
1051 special characters are escaped and passed as arguments instead of retaining
1052 their special meaning.
1053
1054 However, if the command contained arguments that contained whitespace,
1055 stringifying the command would loose the significance of the whitespace.
1056 Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
1057 command if the command is passed as an arrayref and contains special characters.
1058
1059 =item Whitespace and IPC::Run
1060
1061 When using C<IPC::Run>, if you provide a string as the C<command> argument,
1062 the string will be split on whitespace to determine the individual elements
1063 of your command. Although this will usually just Do What You Mean, it may
1064 break if you have files or commands with whitespace in them.
1065
1066 If you do not wish this to happen, you should provide an array
1067 reference, where all parts of your command are already separated out.
1068 Note however, if there's extra or spurious whitespace in these parts,
1069 the parser or underlying code may not interpret it correctly, and
1070 cause an error.
1071
1072 Example:
1073 The following code
1074
1075     gzip -cdf foo.tar.gz | tar -xf -
1076
1077 should either be passed as
1078
1079     "gzip -cdf foo.tar.gz | tar -xf -"
1080
1081 or as
1082
1083     ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
1084
1085 But take care not to pass it as, for example
1086
1087     ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
1088
1089 Since this will lead to issues as described above.
1090
1091
1092 =item IO Redirect
1093
1094 Currently it is too complicated to parse your command for IO
1095 Redirections. For capturing STDOUT or STDERR there is a work around
1096 however, since you can just inspect your buffers for the contents.
1097
1098 =item Interleaving STDOUT/STDERR
1099
1100 Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
1101 bursts of output from a program, ie this sample:
1102
1103     for ( 1..4 ) {
1104         $_ % 2 ? print STDOUT $_ : print STDERR $_;
1105     }
1106
1107 IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
1108 the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
1109
1110 It should have been 1, 2, 3, 4.
1111
1112 This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
1113 STDOUT and STDERR
1114
1115 =back
1116
1117 =head1 See Also
1118
1119 C<IPC::Run>, C<IPC::Open3>
1120
1121 =head1 ACKNOWLEDGEMENTS
1122
1123 Thanks to James Mastros and Martijn van der Streek for their
1124 help in getting IPC::Open3 to behave nicely.
1125
1126 =head1 BUG REPORTS
1127
1128 Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
1129
1130 =head1 AUTHOR
1131
1132 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1133
1134 =head1 COPYRIGHT
1135
1136 This library is free software; you may redistribute and/or modify it
1137 under the same terms as Perl itself.
1138
1139 =cut