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.42_01';
  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     ### strip any empty elements from $cmd if present
 349     $cmd = [ grep { length && defined } @$cmd ] if ref $cmd;
 350
 351     my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
 352     print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
 353
 354     ### did the user pass us a buffer to fill or not? if so, set this
 355     ### flag so we know what is expected of us
 356     ### XXX this is now being ignored. in the future, we could add diagnostic
 357     ### messages based on this logic
 358     #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
 359
 360     ### buffers that are to be captured
 361     my( @buffer, @buff_err, @buff_out );
 362
 363     ### capture STDOUT
 364     my $_out_handler = sub {
 365         my $buf = shift;
 366         return unless defined $buf;
 367
 368         print STDOUT $buf if $verbose;
 369         push @buffer,   $buf;
 370         push @buff_out, $buf;
 371     };
 372
 373     ### capture STDERR
 374     my $_err_handler = sub {
 375         my $buf = shift;
 376         return unless defined $buf;
 377
 378         print STDERR $buf if $verbose;
 379         push @buffer,   $buf;
 380         push @buff_err, $buf;
 381     };
 382
 383
 384     ### flag to indicate we have a buffer captured
 385     my $have_buffer = $self->can_capture_buffer ? 1 : 0;
 386
 387     ### flag indicating if the subcall went ok
 388     my $ok;
 389
 390     ### dont look at previous errors:
 391     local $?;
 392     local $@;
 393     local $!;
 394
 395     ### we might be having a timeout set
 396     eval {
 397         local $SIG{ALRM} = sub { die bless sub {
 398             ALARM_CLASS .
 399             qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
 400         }, ALARM_CLASS } if $timeout;
 401         alarm $timeout || 0;
 402
 403         ### IPC::Run is first choice if $USE_IPC_RUN is set.
 404         if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
 405             ### ipc::run handlers needs the command as a string or an array ref
 406
 407             $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
 408                 if $DEBUG;
 409
 410             $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
 411
 412         ### since IPC::Open3 works on all platforms, and just fails on
 413         ### win32 for capturing buffers, do that ideally
 414         } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
 415
 416             $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
 417                 if $DEBUG;
 418
 419             ### in case there are pipes in there;
 420             ### IPC::Open3 will call exec and exec will do the right thing
 421             $ok = $self->_open3_run(
 422                                     $cmd, $_out_handler, $_err_handler, $verbose
 423                                 );
 424
 425         ### if we are allowed to run verbose, just dispatch the system command
 426         } else {
 427             $self->_debug( "# Using system(). Have buffer: $have_buffer" )
 428                 if $DEBUG;
 429             $ok = $self->_system_run( $cmd, $verbose );
 430         }
 431
 432         alarm 0;
 433     };
 434
 435     ### restore STDIN after duping, or STDIN will be closed for
 436     ### this current perl process!
 437     $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
 438
 439     my $err;
 440     unless( $ok ) {
 441         ### alarm happened
 442         if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
 443             $err = $@->();  # the error code is an expired alarm
 444
 445         ### another error happened, set by the dispatchub
 446         } else {
 447             $err = $self->error;
 448         }
 449     }
 450
 451     ### fill the buffer;
 452     $$buffer = join '', @buffer if @buffer;
 453
 454     ### return a list of flags and buffers (if available) in list
 455     ### context, or just a simple 'ok' in scalar
 456     return wantarray
 457                 ? $have_buffer
 458                     ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
 459                     : ($ok, $err )
 460                 : $ok
 461
 462
 463 }
 464
 465 sub _open3_run {
 466     my $self            = shift;
 467     my $cmd             = shift;
 468     my $_out_handler    = shift;
 469     my $_err_handler    = shift;
 470     my $verbose         = shift || 0;
 471
 472     ### Following code are adapted from Friar 'abstracts' in the
 473     ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
 474     ### XXX that code didn't work.
 475     ### we now use the following code, thanks to theorbtwo
 476
 477     ### define them beforehand, so we always have defined FH's
 478     ### to read from.
 479     use Symbol;
 480     my $kidout      = Symbol::gensym();
 481     my $kiderror    = Symbol::gensym();
 482
 483     ### Dup the filehandle so we can pass 'our' STDIN to the
 484     ### child process. This stops us from having to pump input
 485     ### from ourselves to the childprocess. However, we will need
 486     ### to revive the FH afterwards, as IPC::Open3 closes it.
 487     ### We'll do the same for STDOUT and STDERR. It works without
 488     ### duping them on non-unix derivatives, but not on win32.
 489     my @fds_to_dup = ( IS_WIN32 && !$verbose
 490                             ? qw[STDIN STDOUT STDERR]
 491                             : qw[STDIN]
 492                         );
 493     $self->_fds( \@fds_to_dup );
 494     $self->__dup_fds( @fds_to_dup );
 495
 496     ### pipes have to come in a quoted string, and that clashes with
 497     ### whitespace. This sub fixes up such commands so they run properly
 498     $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
 499
 500     ### dont stringify @$cmd, so spaces in filenames/paths are
 501     ### treated properly
 502     my $pid = eval {
 503         IPC::Open3::open3(
 504                     '<&STDIN',
 505                     (IS_WIN32 ? '>&STDOUT' : $kidout),
 506                     (IS_WIN32 ? '>&STDERR' : $kiderror),
 507                     ( ref $cmd ? @$cmd : $cmd ),
 508                 );
 509     };
 510
 511     ### open3 error occurred
 512     if( $@ and $@ =~ /^open3:/ ) {
 513         $self->ok( 0 );
 514         $self->error( $@ );
 515         return;
 516     };
 517
 518     ### use OUR stdin, not $kidin. Somehow,
 519     ### we never get the input.. so jump through
 520     ### some hoops to do it :(
 521     my $selector = IO::Select->new(
 522                         (IS_WIN32 ? \*STDERR : $kiderror),
 523                         \*STDIN,
 524                         (IS_WIN32 ? \*STDOUT : $kidout)
 525                     );
 526
 527     STDOUT->autoflush(1);   STDERR->autoflush(1);   STDIN->autoflush(1);
 528     $kidout->autoflush(1)   if UNIVERSAL::can($kidout,   'autoflush');
 529     $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
 530
 531     ### add an epxlicit break statement
 532     ### code courtesy of theorbtwo from #london.pm
 533     my $stdout_done = 0;
 534     my $stderr_done = 0;
 535     OUTER: while ( my @ready = $selector->can_read ) {
 536
 537         for my $h ( @ready ) {
 538             my $buf;
 539
 540             ### $len is the amount of bytes read
 541             my $len = sysread( $h, $buf, 4096 );    # try to read 4096 bytes
 542
 543             ### see perldoc -f sysread: it returns undef on error,
 544             ### so bail out.
 545             if( not defined $len ) {
 546                 warn(loc("Error reading from process: %1", $!));
 547                 last OUTER;
 548             }
 549
 550             ### check for $len. it may be 0, at which point we're
 551             ### done reading, so don't try to process it.
 552             ### if we would print anyway, we'd provide bogus information
 553             $_out_handler->( "$buf" ) if $len && $h == $kidout;
 554             $_err_handler->( "$buf" ) if $len && $h == $kiderror;
 555
 556             ### Wait till child process is done printing to both
 557             ### stdout and stderr.
 558             $stdout_done = 1 if $h == $kidout   and $len == 0;
 559             $stderr_done = 1 if $h == $kiderror and $len == 0;
 560             last OUTER if ($stdout_done && $stderr_done);
 561         }
 562     }
 563
 564     waitpid $pid, 0; # wait for it to die
 565
 566     ### restore STDIN after duping, or STDIN will be closed for
 567     ### this current perl process!
 568     ### done in the parent call now
 569     # $self->__reopen_fds( @fds_to_dup );
 570
 571     ### some error occurred
 572     if( $? ) {
 573         $self->error( $self->_pp_child_error( $cmd, $? ) );
 574         $self->ok( 0 );
 575         return;
 576     } else {
 577         return $self->ok( 1 );
 578     }
 579 }
 580
 581 ### text::parsewords::shellwordss() uses unix semantics. that will break
 582 ### on win32
 583 {   my $parse_sub = IS_WIN32
 584                         ? __PACKAGE__->can('_split_like_shell_win32')
 585                         : Text::ParseWords->can('shellwords');
 586
 587     sub _ipc_run {
 588         my $self            = shift;
 589         my $cmd             = shift;
 590         my $_out_handler    = shift;
 591         my $_err_handler    = shift;
 592
 593         STDOUT->autoflush(1); STDERR->autoflush(1);
 594
 595         ### a command like:
 596         # [
 597         #     '/usr/bin/gzip',
 598         #     '-cdf',
 599         #     '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
 600         #     '|',
 601         #     '/usr/bin/tar',
 602         #     '-tf -'
 603         # ]
 604         ### needs to become:
 605         # [
 606         #     ['/usr/bin/gzip', '-cdf',
 607         #       '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
 608         #     '|',
 609         #     ['/usr/bin/tar', '-tf -']
 610         # ]
 611
 612
 613         my @command;
 614         my $special_chars;
 615
 616         my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
 617         if( ref $cmd ) {
 618             my $aref = [];
 619             for my $item (@$cmd) {
 620                 if( $item =~ $re ) {
 621                     push @command, $aref, $item;
 622                     $aref = [];
 623                     $special_chars .= $1;
 624                 } else {
 625                     push @$aref, $item;
 626                 }
 627             }
 628             push @command, $aref;
 629         } else {
 630             @command = map { if( $_ =~ $re ) {
 631                                 $special_chars .= $1; $_;
 632                              } else {
 633 #                                [ split /\s+/ ]
 634                                  [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
 635                              }
 636                         } split( /\s*$re\s*/, $cmd );
 637         }
 638
 639         ### if there's a pipe in the command, *STDIN needs to
 640         ### be inserted *BEFORE* the pipe, to work on win32
 641         ### this also works on *nix, so we should do it when possible
 642         ### this should *also* work on multiple pipes in the command
 643         ### if there's no pipe in the command, append STDIN to the back
 644         ### of the command instead.
 645         ### XXX seems IPC::Run works it out for itself if you just
 646         ### dont pass STDIN at all.
 647         #     if( $special_chars and $special_chars =~ /\|/ ) {
 648         #         ### only add STDIN the first time..
 649         #         my $i;
 650         #         @command = map { ($_ eq '|' && not $i++)
 651         #                             ? ( \*STDIN, $_ )
 652         #                             : $_
 653         #                         } @command;
 654         #     } else {
 655         #         push @command, \*STDIN;
 656         #     }
 657
 658         # \*STDIN is already included in the @command, see a few lines up
 659         my $ok = eval { IPC::Run::run(   @command,
 660                                 fileno(STDOUT).'>',
 661                                 $_out_handler,
 662                                 fileno(STDERR).'>',
 663                                 $_err_handler
 664                             )
 665                         };
 666
 667         ### all is well
 668         if( $ok ) {
 669             return $self->ok( $ok );
 670
 671         ### some error occurred
 672         } else {
 673             $self->ok( 0 );
 674
 675             ### if the eval fails due to an exception, deal with it
 676             ### unless it's an alarm
 677             if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
 678                 $self->error( $@ );
 679
 680             ### if it *is* an alarm, propagate
 681             } elsif( $@ ) {
 682                 die $@;
 683
 684             ### some error in the sub command
 685             } else {
 686                 $self->error( $self->_pp_child_error( $cmd, $? ) );
 687             }
 688
 689             return;
 690         }
 691     }
 692 }
 693
 694 sub _system_run {
 695     my $self    = shift;
 696     my $cmd     = shift;
 697     my $verbose = shift || 0;
 698
 699     ### pipes have to come in a quoted string, and that clashes with
 700     ### whitespace. This sub fixes up such commands so they run properly
 701     $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
 702
 703     my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
 704     $self->_fds( \@fds_to_dup );
 705     $self->__dup_fds( @fds_to_dup );
 706
 707     ### system returns 'true' on failure -- the exit code of the cmd
 708     $self->ok( 1 );
 709     system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
 710         $self->error( $self->_pp_child_error( $cmd, $? ) );
 711         $self->ok( 0 );
 712     };
 713
 714     ### done in the parent call now
 715     #$self->__reopen_fds( @fds_to_dup );
 716
 717     return unless $self->ok;
 718     return $self->ok;
 719 }
 720
 721 {   my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
 722
 723
 724     sub __fix_cmd_whitespace_and_special_chars {
 725         my $self = shift;
 726         my $cmd  = shift;
 727
 728         ### command has a special char in it
 729         if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
 730
 731             ### since we have special chars, we have to quote white space
 732             ### this *may* conflict with the parsing :(
 733             my $fixed;
 734             my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
 735
 736             $self->_debug( "# Quoted $fixed arguments containing whitespace" )
 737                     if $DEBUG && $fixed;
 738
 739             ### stringify it, so the special char isn't escaped as argument
 740             ### to the program
 741             $cmd = join ' ', @cmd;
 742         }
 743
 744         return $cmd;
 745     }
 746 }
 747
 748
 749 ### XXX this is cribbed STRAIGHT from M::B 0.30 here:
 750 ### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
 751 ### XXX this *should* be integrated into text::parsewords
 752 sub _split_like_shell_win32 {
 753   # As it turns out, Windows command-parsing is very different from
 754   # Unix command-parsing.  Double-quotes mean different things,
 755   # backslashes don't necessarily mean escapes, and so on.  So we
 756   # can't use Text::ParseWords::shellwords() to break a command string
 757   # into words.  The algorithm below was bashed out by Randy and Ken
 758   # (mostly Randy), and there are a lot of regression tests, so we
 759   # should feel free to adjust if desired.
 760
 761   local $_ = shift;
 762
 763   my @argv;
 764   return @argv unless defined() && length();
 765
 766   my $arg = '';
 767   my( $i, $quote_mode ) = ( 0, 0 );
 768
 769   while ( $i < length() ) {
 770
 771     my $ch      = substr( $_, $i  , 1 );
 772     my $next_ch = substr( $_, $i+1, 1 );
 773
 774     if ( $ch eq '\\' && $next_ch eq '"' ) {
 775       $arg .= '"';
 776       $i++;
 777     } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
 778       $arg .= '\\';
 779       $i++;
 780     } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
 781       $quote_mode = !$quote_mode;
 782       $arg .= '"';
 783       $i++;
 784     } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
 785           ( $i + 2 == length()  ||
 786         substr( $_, $i + 2, 1 ) eq ' ' )
 787         ) { # for cases like: a"" => [ 'a' ]
 788       push( @argv, $arg );
 789       $arg = '';
 790       $i += 2;
 791     } elsif ( $ch eq '"' ) {
 792       $quote_mode = !$quote_mode;
 793     } elsif ( $ch eq ' ' && !$quote_mode ) {
 794       push( @argv, $arg ) if $arg;
 795       $arg = '';
 796       ++$i while substr( $_, $i + 1, 1 ) eq ' ';
 797     } else {
 798       $arg .= $ch;
 799     }
 800
 801     $i++;
 802   }
 803
 804   push( @argv, $arg ) if defined( $arg ) && length( $arg );
 805   return @argv;
 806 }
 807
 808
 809
 810 {   use File::Spec;
 811     use Symbol;
 812
 813     my %Map = (
 814         STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
 815         STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
 816         STDIN  => [qw|<&|, \*STDIN,  Symbol::gensym() ],
 817     );
 818
 819     ### dups FDs and stores them in a cache
 820     sub __dup_fds {
 821         my $self    = shift;
 822         my @fds     = @_;
 823
 824         __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
 825
 826         for my $name ( @fds ) {
 827             my($redir, $fh, $glob) = @{$Map{$name}} or (
 828                 Carp::carp(loc("No such FD: '%1'", $name)), next );
 829
 830             ### MUST use the 2-arg version of open for dup'ing for
 831             ### 5.6.x compatibilty. 5.8.x can use 3-arg open
 832             ### see perldoc5.6.2 -f open for details
 833             open $glob, $redir . fileno($fh) or (
 834                         Carp::carp(loc("Could not dup '$name': %1", $!)),
 835                         return
 836                     );
 837
 838             ### we should re-open this filehandle right now, not
 839             ### just dup it
 840             ### Use 2-arg version of open, as 5.5.x doesn't support
 841             ### 3-arg version =/
 842             if( $redir eq '>&' ) {
 843                 open( $fh, '>' . File::Spec->devnull ) or (
 844                     Carp::carp(loc("Could not reopen '$name': %1", $!)),
 845                     return
 846                 );
 847             }
 848         }
 849
 850         return 1;
 851     }
 852
 853     ### reopens FDs from the cache
 854     sub __reopen_fds {
 855         my $self    = shift;
 856         my @fds     = @_;
 857
 858         __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
 859
 860         for my $name ( @fds ) {
 861             my($redir, $fh, $glob) = @{$Map{$name}} or (
 862                 Carp::carp(loc("No such FD: '%1'", $name)), next );
 863
 864             ### MUST use the 2-arg version of open for dup'ing for
 865             ### 5.6.x compatibilty. 5.8.x can use 3-arg open
 866             ### see perldoc5.6.2 -f open for details
 867             open( $fh, $redir . fileno($glob) ) or (
 868                     Carp::carp(loc("Could not restore '$name': %1", $!)),
 869                     return
 870                 );
 871
 872             ### close this FD, we're not using it anymore
 873             close $glob;
 874         }
 875         return 1;
 876
 877     }
 878 }
 879
 880 sub _debug {
 881     my $self    = shift;
 882     my $msg     = shift or return;
 883     my $level   = shift || 0;
 884
 885     local $Carp::CarpLevel += $level;
 886     Carp::carp($msg);
 887
 888     return 1;
 889 }
 890
 891 sub _pp_child_error {
 892     my $self    = shift;
 893     my $cmd     = shift or return;
 894     my $ce      = shift or return;
 895     my $pp_cmd  = ref $cmd ? "@$cmd" : $cmd;
 896
 897
 898     my $str;
 899     if( $ce == -1 ) {
 900         ### Include $! in the error message, so that the user can
 901         ### see 'No such file or directory' versus 'Permission denied'
 902         ### versus 'Cannot fork' or whatever the cause was.
 903         $str = "Failed to execute '$pp_cmd': $!";
 904
 905     } elsif ( $ce & 127 ) {
 906         ### some signal
 907         $str = loc( "'%1' died with signal %d, %s coredump\n",
 908                $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
 909
 910     } else {
 911         ### Otherwise, the command run but gave error status.
 912         $str = "'$pp_cmd' exited with value " . ($ce >> 8);
 913     }
 914
 915     $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
 916
 917     return $str;
 918 }
 919
 920 1;
 921
 922 =head2 $q = QUOTE
 923
 924 Returns the character used for quoting strings on this platform. This is
 925 usually a C<'> (single quote) on most systems, but some systems use different
 926 quotes. For example, C<Win32> uses C<"> (double quote).
 927
 928 You can use it as follows:
 929
 930   use IPC::Cmd qw[run QUOTE];
 931   my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
 932
 933 This makes sure that C<foo bar> is treated as a string, rather than two
 934 seperate arguments to the C<echo> function.
 935
 936 __END__
 937
 938 =head1 HOW IT WORKS
 939
 940 C<run> will try to execute your command using the following logic:
 941
 942 =over 4
 943
 944 =item *
 945
 946 If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
 947 is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute
 948 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
 949 settings honored cleanly.
 950
 951 =item *
 952
 953 Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
 954 (See the C<GLOBAL VARIABLES> Section), try to execute the command using
 955 C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
 956 interactive commands will still execute cleanly, and also your verbosity
 957 settings will be adhered to nicely;
 958
 959 =item *
 960
 961 Otherwise, if you have the verbose argument set to true, we fall back
 962 to a simple system() call. We cannot capture any buffers, but
 963 interactive commands will still work.
 964
 965 =item *
 966
 967 Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
 968 system() call with your command and then re-open STDERR and STDOUT.
 969 This is the method of last resort and will still allow you to execute
 970 your commands cleanly. However, no buffers will be available.
 971
 972 =back
 973
 974 =head1 Global Variables
 975
 976 The behaviour of IPC::Cmd can be altered by changing the following
 977 global variables:
 978
 979 =head2 $IPC::Cmd::VERBOSE
 980
 981 This controls whether IPC::Cmd will print any output from the
 982 commands to the screen or not. The default is 0;
 983
 984 =head2 $IPC::Cmd::USE_IPC_RUN
 985
 986 This variable controls whether IPC::Cmd will try to use L<IPC::Run>
 987 when available and suitable. Defaults to true if you are on C<Win32>.
 988
 989 =head2 $IPC::Cmd::USE_IPC_OPEN3
 990
 991 This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
 992 when available and suitable. Defaults to true.
 993
 994 =head2 $IPC::Cmd::WARN
 995
 996 This variable controls whether run time warnings should be issued, like
 997 the failure to load an C<IPC::*> module you explicitly requested.
 998
 999 Defaults to true. Turn this off at your own risk.
1000
1001 =head1 Caveats
1002
1003 =over 4
1004
1005 =item Whitespace and IPC::Open3 / system()
1006
1007 When using C<IPC::Open3> or C<system>, if you provide a string as the
1008 C<command> argument, it is assumed to be appropriately escaped. You can
1009 use the C<QUOTE> constant to use as a portable quote character (see above).
1010 However, if you provide and C<Array Reference>, special rules apply:
1011
1012 If your command contains C<Special Characters> (< > | &), it will
1013 be internally stringified before executing the command, to avoid that these
1014 special characters are escaped and passed as arguments instead of retaining
1015 their special meaning.
1016
1017 However, if the command contained arguments that contained whitespace,
1018 stringifying the command would loose the significance of the whitespace.
1019 Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
1020 command if the command is passed as an arrayref and contains special characters.
1021
1022 =item Whitespace and IPC::Run
1023
1024 When using C<IPC::Run>, if you provide a string as the C<command> argument,
1025 the string will be split on whitespace to determine the individual elements
1026 of your command. Although this will usually just Do What You Mean, it may
1027 break if you have files or commands with whitespace in them.
1028
1029 If you do not wish this to happen, you should provide an array
1030 reference, where all parts of your command are already separated out.
1031 Note however, if there's extra or spurious whitespace in these parts,
1032 the parser or underlying code may not interpret it correctly, and
1033 cause an error.
1034
1035 Example:
1036 The following code
1037
1038     gzip -cdf foo.tar.gz | tar -xf -
1039
1040 should either be passed as
1041
1042     "gzip -cdf foo.tar.gz | tar -xf -"
1043
1044 or as
1045
1046     ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
1047
1048 But take care not to pass it as, for example
1049
1050     ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
1051
1052 Since this will lead to issues as described above.
1053
1054
1055 =item IO Redirect
1056
1057 Currently it is too complicated to parse your command for IO
1058 Redirections. For capturing STDOUT or STDERR there is a work around
1059 however, since you can just inspect your buffers for the contents.
1060
1061 =item Interleaving STDOUT/STDERR
1062
1063 Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
1064 bursts of output from a program, ie this sample:
1065
1066     for ( 1..4 ) {
1067         $_ % 2 ? print STDOUT $_ : print STDERR $_;
1068     }
1069
1070 IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
1071 the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
1072
1073 It should have been 1, 2, 3, 4.
1074
1075 This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
1076 STDOUT and STDERR
1077
1078 =back
1079
1080 =head1 See Also
1081
1082 C<IPC::Run>, C<IPC::Open3>
1083
1084 =head1 ACKNOWLEDGEMENTS
1085
1086 Thanks to James Mastros and Martijn van der Streek for their
1087 help in getting IPC::Open3 to behave nicely.
1088
1089 =head1 BUG REPORTS
1090
1091 Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
1092
1093 =head1 AUTHOR
1094
1095 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1096
1097 =head1 COPYRIGHT
1098
1099 This library is free software; you may redistribute and/or modify it
1100 under the same terms as Perl itself.
1101
1102 =cut