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