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