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