File Coverage

lib/IPC/Capture.pm
Criterion Covered Total %
statement 170 301 56.4
branch 17 66 25.7
condition 8 38 21.0
subroutine 24 36 66.6
pod 21 21 100.0
total 240 462 51.9


line stmt bran cond sub pod time code
1             package IPC::Capture;
2 1     1   1155 use base qw( Class::Base );
  1         2  
  1         1034  
3              
4             =head1 NAME
5              
6             IPC::Capture - portably run external apps and capture the output
7              
8             =head1 SYNOPSIS
9              
10             use IPC::Capture;
11             my $ich = IPC::Capture->new();
12             $ich->set_filter('stdout_only');
13              
14             my $output = $ich->run( $this_cmd );
15             if ( $output ) ) {
16             # work with $output...
17             }
18              
19             unless( $ich->can_run( $another_cmd ) {
20             die "Will not be able to run the external command: $another_cmd\n";
21             }
22              
23             $ich->set_filter('stderr_only');
24             my $errors = $ich->run( $another_cmd );
25              
26             # stdout and stderr together:
27             $ich->set_filter('all_output');
28             my $all = $ich->run( $another_cmd );
29              
30              
31              
32             =head1 DESCRIPTION
33              
34             IPC::Capture is a module for running external applications
35             in a portable fashion when you're primarily interested in capturing
36             the returned output.
37              
38             Essentially this is an attempt at creating a portable way of doing
39             "backticks" with io-redirection. In fact, if it looks like it will work,
40             this module will internally just try to run the command via a sub-shell
41             invoked by qx; otherwise, it will try some other approaches which may work
42             (going through other modules such as L, L, and/or
43             L).
44              
45             The different ways of running external commands are called "ways" here
46             (because words like "methods" already have too many other associations).
47             At present, there are only two "ways" defined in this module: "qx" and
48             "ipc_cmd". We probe the system trying each of the known ways (in the
49             order defined in the "ways" attribute), and use the first one that looks
50             like it will work.
51              
52             =head2 METHODS
53              
54             =over
55              
56             =cut
57              
58 1     1   1485 use 5.008;
  1         4  
  1         39  
59 1     1   16 use strict;
  1         2  
  1         30  
60 1     1   5 use warnings;
  1         2  
  1         39  
61 1     1   6 use Carp;
  1         2  
  1         79  
62 1     1   7 use Data::Dumper;
  1         2  
  1         60  
63 1     1   963 use Hash::Util qw( lock_keys unlock_keys );
  1         5202  
  1         8  
64 1     1   161 use File::Spec qw( devnull );
  1         5  
  1         32  
65 1     1   1399 use File::Temp qw( tempfile tempdir );
  1         27838  
  1         86  
66             # Note: IPC::Cmd is used below dynamically (if qx fails)
67 1     1   1225 use List::MoreUtils qw( zip );
  1         2479  
  1         1699  
68              
69             our $VERSION = '0.06';
70             my $DEBUG = 0; # TODO change to 0 before shipping
71              
72             # needed for accessor generation
73             our $AUTOLOAD;
74             my %ATTRIBUTES = ();
75              
76             =item new
77              
78             Creates a new IPC::Capture object.
79              
80             Takes a hashref as an argument, with named fields identical
81             to the names of the object attributes (which also may be set
82             later via the accessor methods). These attributes are:
83              
84             =over
85              
86             =item filter
87              
88             The "filter" is a code that specifies what command output
89             streams we're interested in capturing. Allowed values:
90              
91             =over
92              
93             =item stdout_only
94              
95             Discards stderr and returns only stdout. Like the Bourne shell
96             redirect: '2>/dev/null'
97              
98             =item stderr_only
99              
100             Discards stdout and returns only stderr. Like the Bourne shell
101             redirect: '2>&1 1>/dev/null'
102              
103             =item all_output
104              
105             Intermixes lines of stdout and stderr in chronological order.
106             Like the Bourne shell redirect: '2>&1'
107              
108             =item all_separated
109              
110             The return will be an array reference with two elements: stdout and stderr.
111             (But under some circumstances, it may not be possible to seperate
112             the two, and all output will be returned intermixed, as the first
113             item, and the second will be undef.)
114              
115             =back
116              
117             =item autochomp
118              
119             Set to a true value, causes all returned values to be
120             automatically chomped. Defaults to false.
121              
122             =item known_ways
123              
124             List of known ways of invoking external commands, in the default
125             order in which they'll be tried (as of this writing: ['ex', 'ipc_cmd'].
126              
127             =item ways
128              
129             List of ways of invoking external commands, in the order the user
130             would like to try them. Defaults to L.
131              
132             =item way
133              
134             The chosen "way" that will be used for invoking external commands.
135              
136             =item stdout_probe_messages
137              
138             List of messages which are sent to STDOUT by the probe sub-script.
139             An array reference.
140              
141             =item stderr_probe_messages
142              
143             List of messages which are sent to STDERR by the probe sub-script.
144             An array reference.
145              
146             =back
147              
148             Takes an optional hashref as an argument, with named fields
149             identical to the names of the object attributes.
150              
151             =cut
152              
153             # Note: "new" is inherited from Class::Base and
154             # calls the following "init" routine automatically.
155              
156             =item init
157              
158             Method that initializes object attributes and then locks them
159             down to prevent accidental creation of new ones.
160              
161             Any class that inherits from this one should have an B of
162             it's own that calls this B. Otherwise, it's an internally
163             used routine that is not of much interest to client coders.
164              
165             =cut
166              
167             sub init {
168 3     3 1 5889 my $self = shift;
169 3         8 my $args = shift;
170 3         12 unlock_keys( %{ $self } );
  3         32  
171              
172 3         68 my @attributes = qw(
173             filter
174              
175             autochomp
176              
177             known_ways
178             ways
179             way
180              
181             known_filters
182              
183             stdout_probe_messages
184             stderr_probe_messages
185              
186             success
187             );
188              
189 3         9 foreach my $field (@attributes) {
190 27         56 $ATTRIBUTES{ $field } = 1;
191 27         61 $self->{ $field } = $args->{ $field };
192             }
193              
194 3         8 $self->{ success } = 1; ### TODO stub.
195              
196 3         12 $self->{ known_ways } = ['qx', 'ipc_cmd'];
197 3   33     27 $self->{ ways } ||= $self->{ known_ways };
198              
199             $self->{ known_filters } =
200             [
201 3         12 'stdout_only',
202             'stderr_only',
203             'all_output',
204             'all_separated',
205             ];
206              
207             $self->{ stdout_probe_messages } ||=
208 3   50     31 [ 'abc', 'ijk', 'xyz' ];
209              
210             $self->{ stderr_probe_messages } ||=
211 3   50     26 [ '123', '567', '890' ];
212              
213 3         11 my $way = $self->probe_system;
214 3 50       10 unless( $way ) {
215 0         0 $self->debug("IPC::Capture probe_system method has not found a way.");
216             }
217 3   50     23 $self->{ way } = $way || 'qx'; # TODO should there be a fallback default here?
218              
219 3 50       12 $self->debugging( 1 ) if $DEBUG;
220 3 50       105 $DEBUG = 1 if $self->debugging();
221              
222 3         56 lock_keys( %{ $self } );
  3         41  
223 3         142 return $self;
224             }
225             # Note: logically, known_ways and known_filters
226             # could be class data: but I don't think I care.
227              
228             =item probe_system
229              
230             Internally used during the init phase of object creation.
231             Chooses a good "way" of running commands external to perl.
232              
233             =cut
234              
235             sub probe_system {
236 3     3 1 6 my $self = shift;
237 3         17 my $ways = $self->ways;
238              
239             ## Here we use File::Temp to write out a small perl script that sends
240             ## some known output to stdout and (optionally) to stderr
241 3         237 my $code = $self->define_yammer_script();
242              
243             # creating a temporary perl script file
244             # Note: we explicitly use tmpdir, or else it uses curdir which may not be writable(!)
245 3         201 my $tmpdir = File::Spec->tmpdir();
246 3 50       15 $File::Temp::KEEP_ALL = 1 if $DEBUG; # overrides "UNLINK" & leaves tempfile
247 3         37 my ($fh1, $scriptname) = tempfile('yap_XXXX',
248             SUFFIX => '.pl',
249             DIR => $tmpdir,
250             UNLINK => 1 );
251              
252 3         2161 $self->debug( "scriptname: $scriptname\n" );
253 3         29 print {$fh1} $code;
  3         50  
254 3         231 close( $fh1 );
255              
256             # trying running the script a few different ways
257 3         17 my $chosen_way;
258 3         4 foreach my $way (@{ $ways } ) {
  3         12  
259 3         9 my $method = "probe_system_$way";
260 3         15 my $retval = $self->$method( $scriptname );
261 3 50       14 if ( defined( $retval ) ) {
262 3         19 $chosen_way = $way;
263 3         21 last;
264             }
265             }
266              
267             # cleanup
268 3         477 unlink( $scriptname );
269              
270 3         32 return $chosen_way;
271             }
272              
273              
274             =item define_yammer_script
275              
276             This is an internally used routine, broken out as a method for
277             ease of testing.
278              
279             This generates some code for the 'yammer_script' which is used
280             used by L to check which ways work for running
281             external commands. The 'yammer_script' sends three lines of
282             output to stdout, and if provided with command-line arguments, it
283             will echo up to three of them to stderr. The stderr output is
284             interleaved with the output sent to stdout, starting with stdout
285             (so the pattern is: OeOeOe).
286              
287             This method uses the object data L to get
288             an aref of messages to send to stdout; but this can be overridden
289             by passing it an aref of alternate messages.
290              
291             So, just to make it clear: the STDOUT strings are defined when
292             this method is called, but the STDERR strings are defined only
293             when the yammer script it generates is run.
294              
295             =cut
296              
297             sub define_yammer_script {
298 3     3 1 7 my $self = shift;
299 3   33     51 my $messages = shift || $self->stdout_probe_messages;
300 3         4 my ($x, $y, $z) = @{ $messages };
  3         9  
301 3         20 my $code =
302             '$|=1;' . "\n" .
303             'print "' . $x . '\n"; ' . "\n" .
304             'print STDERR "$ARGV[0]\n" if defined($ARGV[0]); ' . "\n" .
305             'print "' . $y . '\n"; ' . "\n" .
306             'print STDERR "$ARGV[1]\n" if defined($ARGV[1]); ' . "\n" .
307             'print "' . $z . '\n"; ' . "\n" .
308             'print STDERR "$ARGV[2]\n" if defined($ARGV[2]); ' . "\n" ;
309 3         8 return $code;
310             }
311              
312              
313             =item probe_system_qx
314              
315             Method used internally by the internal method "probe_system".
316             Takes one argument: the script name, which it will try to run
317             via qx.
318              
319             =cut
320              
321             sub probe_system_qx {
322 3     3 1 5 my $self = shift;
323 3         6 my $scriptname = shift;
324 3   33     29 my $stderr_probe_messages = shift || $self->stderr_probe_messages;
325              
326 3         6 my $perl = $^X; # have perl tell us where it is (might not be in path)
327 3         5 my $stderr_args = join ' ', @{ $stderr_probe_messages };
  3         10  
328 3         8 my $cmd = "$perl $scriptname $stderr_args";
329              
330 3         9 my $stdout_probe_messages = $self->stdout_probe_messages;
331              
332 3         3 my ($capture_stdout, $capture_stderr, $capture_all);
333 3         11 $capture_stdout = $self->run_qx_stdout_only( $cmd );
334 3         208 chomp($capture_stdout);
335 3         37 $capture_stderr = $self->run_qx_stderr_only( $cmd );
336 3         17 chomp($capture_stderr);
337 3         20 $capture_all = $self->run_qx_all_output( $cmd );
338 3         13 chomp($capture_all);
339              
340 3         8 my $expected_stdout = join "\n", @{ $stdout_probe_messages };
  3         26  
341 3         12 my $expected_stderr = join "\n", @{ $stderr_probe_messages };
  3         15  
342 3         10 my $expected_all = join "\n", zip @{ $stdout_probe_messages }, @{ $stderr_probe_messages };
  3         8  
  3         61  
343              
344 3 50 33     124 if ( ( $capture_stdout eq $expected_stdout ) &&
      33        
345             ( $capture_stderr eq $expected_stderr ) &&
346             ( $capture_all eq $expected_all ) ) {
347 3         41 return 1;
348             } else {
349 0         0 return;
350             }
351             }
352              
353              
354             =item probe_system_ipc_cmd
355              
356             Method used internally by the internal method "probe_system".
357             Takes one argument: the script name, which it will try to run
358             via IPC::Cmd.
359              
360             =cut
361              
362             sub probe_system_ipc_cmd {
363 0     0 1 0 my $self = shift;
364 0         0 my $scriptname = shift;
365 0   0     0 my $stderr_probe_messages = shift || [ '123', '567', '890' ];
366              
367 0         0 my $perl = $^X; # have perl tell us where it is (might not be in path)
368 0         0 my $stderr_args = join ' ', @{ $stderr_probe_messages };
  0         0  
369 0         0 my $cmd = "$perl $scriptname $stderr_args";
370              
371 0         0 my $stdout_probe_messages = $self->stdout_probe_messages;
372              
373 0         0 my ($capture_stdout, $capture_stderr, $capture_all);
374 0         0 $capture_stdout = $self->run_ipc_cmd_stdout_only( $cmd );
375 0         0 chomp($capture_stdout);
376 0         0 $capture_stderr = $self->run_ipc_cmd_stderr_only( $cmd );
377 0         0 chomp($capture_stderr);
378 0         0 $capture_all = $self->run_ipc_cmd_all_output( $cmd );
379 0         0 chomp($capture_all);
380              
381 0         0 my $expected_stdout = join "\n", @{ $stdout_probe_messages };
  0         0  
382 0         0 my $expected_stderr = join "\n", @{ $stderr_probe_messages };
  0         0  
383 0         0 my $expected_all = join "\n", zip @{ $stdout_probe_messages }, @{ $stderr_probe_messages };
  0         0  
  0         0  
384              
385 0 0 0     0 if ( ( $capture_stdout eq $expected_stdout ) &&
      0        
386             ( $capture_stderr eq $expected_stderr ) &&
387             ( $capture_all eq $expected_all ) ) {
388 0         0 return 1;
389             } else {
390 0         0 return;
391             }
392             }
393              
394             =item can_run
395              
396             Given the name of an external command, will check to see if we
397             can run it.
398              
399             Note: just because the program has the name you're looking for,
400             there's no guarantee that it's the right program.
401              
402             =cut
403              
404             sub can_run {
405 0     0 1 0 my $self = shift;
406 0         0 my $cmd = shift;
407 0         0 my $way = $self->way;
408 0         0 my $method = "can_run_$way";
409 0         0 my $status = $self->$method( $cmd );
410 0         0 return $status;
411             }
412              
413             =item can_run_qx
414              
415             This is a method used internally by L, it tries to
416             determine if the given program can be run via the shell
417             (i.e. the "qx" way), and returns the full path to the program
418             if it's found, otherwise, undef.
419              
420             =cut
421              
422             # Trying a few different ways, only one of which need work...
423             sub can_run_qx {
424 0     0 1 0 my $self = shift;
425 0         0 my $program = shift;
426 0         0 my $found;
427              
428 0 0       0 if( $found = $self->can_run_qx_which( $program ) ) {
    0          
429 0         0 return $found;
430             } elsif( $found = $self->can_run_qx_path_glob( $program ) ) {
431 0         0 return $found;
432             }
433              
434 0         0 return; # undef, nothing found
435             }
436              
437              
438             =item can_run_qx_which
439              
440             This is a method used internally by L.
441             It uses the old old unix utility "which" to look for
442             the given program.
443              
444             =cut
445              
446             sub can_run_qx_which {
447 0     0 1 0 my $self = shift;
448 0         0 my $program = shift;
449 0         0 my $subname = ( caller(0) )[3];
450              
451 0         0 my $which = 'which';
452 0         0 my $found;
453 0         0 eval {
454 1     1   8 no warnings;
  1         3  
  1         2454  
455 0         0 $found = qx{ $which $program };
456 0         0 chomp( $found );
457             };
458 0 0 0     0 if ($@) {
    0          
459 0         0 $self->debug("$subname: Running '$which' errored out: $@\n");
460 0         0 return;
461             } elsif ( defined( $found ) && ($found =~ m{ \b $program $ }xms) ) {
462 0         0 return $found;
463             } else {
464 0         0 return;
465             }
466             }
467              
468              
469             =item can_run_qx_path_glob
470              
471             This is a method used internally by L.
472             It looks for the given program by checking looking for
473             an executible file of that name somewhere in the path.
474              
475             =cut
476              
477             sub can_run_qx_path_glob {
478 0     0 1 0 my $self = shift;
479 0         0 my $program = shift;
480 0         0 my $found;
481             # Just look in each directory in the PATH for an
482             # executable file with the right name,
483 0         0 my @PATH = File::Spec->path();
484 0         0 foreach my $loc (@PATH) {
485 0         0 chdir( $loc );
486             # This is better for debugging (for obscure reasons):
487             # my @names = glob '*';
488             # foreach my $name (@names) {
489             # But this is more memory efficient...
490 0         0 while ( my $name = glob '*' ) {
491 0 0 0     0 if (( $name eq $program ) && ( -f "$loc/$name" ) && ( -x "$loc/$name" )) {
      0        
492 0         0 $found = File::Spec->catfile($loc, $name);
493 0         0 return $found;
494             }
495             }
496             }
497 0         0 return;
498             }
499              
500             =item can_run_ipc_cmd
501              
502             Given the name of a program, checks to see if it can run it.
503             Returns the full path to the binary if it is found.
504              
505             Note: this is a simple wrapper around IPC::Cmd::can_run.
506              
507             =cut
508              
509             sub can_run_ipc_cmd {
510 0     0 1 0 my $self = shift;
511 0         0 my $program = shift;
512 0         0 require IPC::Cmd;
513 0         0 my $path = IPC::Cmd::can_run( $program );
514 0         0 return $path;
515             }
516              
517             =item run
518              
519             Takes one argument: an external command string.
520              
521             Returns the output from the external command (as controlled by
522             the L setting in the object). The output
523             will almost always be in the form of a multi-line string,
524             except in one case:
525              
526             If filter is set to "all_separated", then this will return a
527             reference to an array of two elements, the first containing
528             stdout, the second stderr.
529              
530             =cut
531              
532             sub run {
533 8     8 1 70 my $self = shift;
534 8         21 my $cmd = shift;
535 8         21 my $output;
536 8         58 my $way = $self->way;
537 8         37 my $od = $self->filter;
538 8         30 my $method = 'run_' . $way. '_' . $od ; # run__
539 8         58 $output = $self->$method( $cmd );
540 8         386 return $output;
541             }
542              
543             =back
544              
545             =head2 "run__"
546              
547             These methods are for internal use by the "run" method.
548              
549             =head2 "run_qx_*" methods
550              
551             These are methods that take the given command and simply try to
552             run them via whatever shell is available to the qx{} operator.
553              
554             The L setting is converted to equivalent
555             Bourne shell redirect.
556              
557             =over
558              
559             =item run_qx_all_output
560              
561             =cut
562              
563             sub run_qx_all_output {
564 5     5 1 9 my $self = shift;
565 5         16 my $cmd = shift;
566 5         16 my $output;
567 5         30 my $sod = '2>&1';
568 5         158836 $output = qx{$cmd $sod};
569 5 50       239 chomp( $output ) if $self->autochomp;
570 5         80 return $output;
571             }
572              
573             =item run_qx_stdout_only
574              
575             =cut
576              
577             sub run_qx_stdout_only {
578 5     5 1 9 my $self = shift;
579 5         7 my $cmd = shift;
580 5         5 my $output;
581 5         72 my $devnull = File::Spec->devnull;
582 5         13 my $sod = "2>$devnull";
583 5         184674 $output = qx{$cmd $sod};
584 5 50       282 chomp( $output ) if $self->autochomp;
585 5         214 return $output;
586             }
587              
588             =item run_qx_stderr_only
589              
590             =cut
591              
592             sub run_qx_stderr_only {
593 5     5 1 209 my $self = shift;
594 5         14 my $cmd = shift;
595 5         9 my $output;
596 5         97 my $devnull = File::Spec->devnull;
597 5         23 my $sod = "2>&1 1>$devnull";
598 5         185716 $output = qx{$cmd $sod};
599 5 50       206 chomp( $output ) if $self->autochomp;
600 5         78 return $output;
601             }
602              
603             =item run_qx_all_separated_old
604              
605             (An earlier attempt that seemed "more correct"
606             to me, but doesn't work on MSwin32.)
607              
608             =cut
609              
610             # uses redirection to a temp file to get stderr isolated from stdout
611             sub run_qx_all_separated_old {
612 0     0 1 0 my $self = shift;
613 0         0 my $cmd = shift;
614 0         0 my ($output, $stdout, $stderr);
615 0         0 my $tmpdir = File::Spec->tmpdir();
616              
617 0 0       0 $File::Temp::KEEP_ALL = 1 if $DEBUG;
618              
619 0         0 my ($fh, $filename) = tempfile('buf_XXXX',
620             SUFFIX => '.dat',
621             DIR => $tmpdir,
622             UNLINK => 1);
623              
624              
625 0         0 my $sod = "2>$filename";
626 0         0 $stdout = qx{$cmd $sod};
627              
628 0         0 while( my $line = <$fh> ) {
629 0         0 $stderr .= $line;
630             }
631              
632 0         0 $output = [ $stdout, $stderr ];
633 0 0       0 $self->chomp_aref( $output ) if $self->autochomp;
634 0         0 return $output;
635             }
636              
637              
638             =item run_qx_all_separated
639              
640              
641             =cut
642              
643             # And alternate form of L to work
644             # around an mswin32 issue.
645              
646             sub run_qx_all_separated {
647 2     2 1 14 my $self = shift;
648 2         10 my $cmd = shift;
649 2         8 my ($output, $stdout, $stderr);
650 2         87 my $tmpdir = File::Spec->tmpdir();
651              
652             # $File::Temp::KEEP_ALL = 1 if $DEBUG;
653              
654 2         41 my ($fh, $filename) = tempfile('buf_XXXX',
655             SUFFIX => '.dat',
656             DIR => $tmpdir,
657             UNLINK => 0);
658              
659 2         1351 close($fh);
660              
661 2         9 my $sod = "2>$filename";
662 2         174651 $stdout = qx{$cmd $sod};
663              
664 2 50       180 open $fh, '<', $filename or croak "Could not re-open $filename for read: $!";
665              
666 2         62 while( my $line = <$fh> ) {
667 12         47 $stderr .= $line;
668             }
669 2         23 close($fh);
670              
671 2 50       293 unlink( $filename ) unless $DEBUG;
672              
673 2         21 $output = [ $stdout, $stderr ];
674 2 50       37 $self->chomp_aref( $output ) if $self->autochomp;
675 2         51 return $output;
676             }
677              
678              
679              
680             =back
681              
682             =head2 "run_ipc_cmd_*" methods
683              
684             These are methods that take the given command and try to
685             run them via the L module, (which in turn will try
686             to use L or L).
687              
688             The L setting determines what kind of
689             IPC::Cmd call to use, and which of it's output channels will
690             be returned.
691              
692             =over
693              
694             =item run_ipc_cmd_stdout_only
695              
696             Used internally by L when the L is set
697             to 'stdout_only' (and the L is 'ipc_cmd').
698              
699             =cut
700              
701             sub run_ipc_cmd_stdout_only {
702 0     0 1 0 my $self = shift;
703 0         0 my $cmd = shift;
704 0         0 my $output;
705             my $all_buf;
706 0         0 require IPC::Cmd;
707 0         0 my( $success, $error_code, $all_sep_buf, $stdout_buf, $stderr_buf ) =
708             IPC::Cmd::run( command => $cmd, verbose => 0, buffer=> \$all_buf );
709 0         0 $output = $stdout_buf->[0];
710              
711 0 0       0 if( not( $success ) ) {
712 0         0 warn "IPC::Cmd run of $cmd failed.";
713             }
714 0 0       0 chomp( $output ) if $self->autochomp;
715 0         0 return $output;
716             }
717              
718              
719             =item run_ipc_cmd_stderr_only
720              
721             Used internally by L when the L is set
722             to 'stderr_only' (and the L is 'ipc_cmd'):
723              
724             =cut
725              
726             sub run_ipc_cmd_stderr_only {
727 0     0 1 0 my $self = shift;
728 0         0 my $cmd = shift;
729 0         0 my $output;
730             my $all_buf;
731 0         0 require IPC::Cmd;
732 0         0 my( $success, $error_code, $all_sep_buf, $stdout_buf, $stderr_buf ) =
733             IPC::Cmd::run( command => $cmd, verbose => 0, buffer=> \$all_buf );
734 0         0 $output = $stderr_buf->[0];
735              
736 0 0       0 if( not( $success ) ) {
737 0         0 warn "IPC::Cmd run of $cmd has failed";
738             }
739 0 0       0 chomp( $output ) if $self->autochomp;
740 0         0 return $output;
741             }
742              
743              
744             =item run_ipc_cmd_all_output
745              
746             Used internally by L when the L is set
747             to 'all_output' (and the L is 'ipc_cmd'):
748              
749             =cut
750              
751             sub run_ipc_cmd_all_output {
752 0     0 1 0 my $self = shift;
753 0         0 my $cmd = shift;
754 0         0 my $output;
755             my $all_buf;
756 0         0 require IPC::Cmd;
757 0 0       0 if( IPC::Cmd::run( command => $cmd, verbose => 0, buffer=> \$all_buf ) ) {
758 0         0 $output = $all_buf;
759             } else {
760 0         0 warn "IPC::Cmd run of $cmd failed.";
761             }
762 0 0       0 chomp( $output ) if $self->autochomp;
763 0         0 return $output;
764             }
765              
766             =item run_ipc_cmd_all_separated
767              
768             Used internally by L when the L is set
769             to 'all_separated' (and the L is 'ipc_cmd'):
770              
771             =cut
772              
773             sub run_ipc_cmd_all_separated {
774 0     0 1 0 my $self = shift;
775 0         0 my $cmd = shift;
776 0         0 my ($output, $stdout, $stderr);
777 0         0 my $all_buf;
778 0         0 require IPC::Cmd;
779 0         0 my( $success, $error_code, $all_sep_buf, $stdout_buf, $stderr_buf ) =
780             IPC::Cmd::run( command => $cmd, verbose => 0, buffer=> \$all_buf );
781 0         0 $output = $all_sep_buf;
782              
783 0 0       0 if( not( $success ) ) {
784 0         0 warn "IPC::Cmd run of $cmd failed.";
785             }
786              
787 0 0       0 $self->chomp_aref( $output ) if $self->autochomp;
788 0         0 return $output;
789             }
790              
791             =back
792              
793             =head1 utility methods
794              
795             =over
796              
797             =item chomp_aref
798              
799             Like "chomp", but presumes it's been given an array reference
800             of strings to work on.
801              
802             =cut
803              
804             sub chomp_aref {
805 0     0 1 0 my $self = shift;
806 0         0 my $aref = shift;
807              
808 0 0       0 unless ( ref( $aref ) eq 'ARRAY' ) {
809 0         0 croak "chomp_aref only works on an array reference";
810             }
811 0         0 foreach ( @{ $aref } ){
  0         0  
812 0         0 chomp( $_ );
813             }
814 0         0 return $aref;
815             }
816              
817              
818              
819              
820             =back
821              
822             =head2 basic setters and getters
823              
824             The naming convention in use here is that setters begin with
825             "set_", but getters have *no* prefix: the most commonly used case
826             deserves the simplest syntax (and mutators are deprecated).
827              
828             These accessors exist for all of the object attributes (documented
829             above) irrespective of whether they're expected to be externally useful.
830              
831             =head2 automatic generation of accessors
832              
833             =over
834              
835             =item AUTOLOAD
836              
837             =cut
838              
839             sub AUTOLOAD {
840 7 50   7   227 return if $AUTOLOAD =~ /DESTROY$/; # skip calls to DESTROY ()
841              
842 7         195 my ($name) = $AUTOLOAD =~ /([^:]+)$/; # extract method name
843 7         26 (my $field = $name) =~ s/^set_//;
844              
845             # check that this is a valid accessor call
846 7 50       25 croak("Unknown method '$AUTOLOAD' called")
847             unless defined( $ATTRIBUTES{ $field } );
848              
849 1     1   9 { no strict 'refs';
  1         1  
  1         256  
  7         12  
850              
851             # create the setter and getter and install them in the symbol table
852              
853 7 100       34 if ( $name =~ /^set_/ ) {
    50          
854              
855             *$name = sub {
856 8     8   9779 my $self = shift;
857 8         42 $self->{ $field } = shift;
858 8         29 return $self->{ $field };
859 1         24 };
860              
861 1         9 goto &$name; # jump to the new method.
862             } elsif ( $name =~ /^get_/ ) {
863 0         0 carp("Apparent attempt at using a getter with unneeded 'get_' prefix.");
864             }
865              
866             *$name = sub {
867 45     45   162 my $self = shift;
868 45         307 return $self->{ $field };
869 6         51 };
870              
871 6         25 goto &$name; # jump to the new method.
872             }
873             }
874              
875              
876             1;
877              
878             =back
879              
880             =head1 How It Works
881              
882             Where possible, IPC::Capture will simply work by running the
883             given command in a sub-shell, invoked with a qx.
884              
885             During the init phase, it tries to determine if a qx works as
886             expected (using Bourne-shell style redirects) by the expedient of
887             writing a temporary perl script that generates a known output,
888             and then just trying to run the script. (This step will be
889             skipped if the object is told which style of i/o it should use
890             when instantiated.)
891              
892             It appears that qx with i/o re-direction is a relatively portable
893             idiom these days: it's supported by most forms of perl on
894             Windows, and I would be surprised if OSX does not support it
895             also.
896              
897             If a qx fails, then this system will try another way of doing
898             the job using the L module.
899              
900             If no way of running a simple command and capturing it's output
901             can be found, an error will be signalled during instantiation.
902              
903             L in turn uses L or L (depending
904             on which is installed), which means that this module should have
905             a fair degree of cross-platform portability.
906              
907             =head2 further notes
908              
909             Depending on the type of output requested with the "filter",
910             this module will choose to do either a scalar or an array context call
911             to IPC::Cmd::run (insulating the user from one of IPC::Cmd's
912             oddities).
913              
914             =head1 MOTIVATION
915              
916             The original goal was to find something more portable than
917             shelling out via qx with Bourne shell redirection.
918              
919             I'd just written the L module that shells out to
920             emacs, and I was looking for improvements. (Note: emacs is
921             a widely available program, with portability roughly on the
922             same scale as perl.)
923              
924             The L module looked like a promising simplification
925             over directly using L or L, but it's
926             output capture features seemed clumsy.
927              
928             So: my first thought was to write a wrapper around the wrapper,
929             and as an added bonus, it would fall back on doing a simple qx
930             if L wasn't going to work.
931              
932             My initial tests of that code immediately revealed a problem
933             with L: it usually worked as expected, but sometimes
934             would behave strangely (e.g. returning only one line of output
935             instead of the expected six; or instead of interleaving stderr
936             with stdout, it might return all stderr lines first).
937             My suspicion was that this was due to running on a perl with
938             threads enabled, but in any case, it didn't inspire confidence
939             with the idea that L was going to be more reliable than qx.
940              
941             At which point, it occured to me that I could rewrite the
942             module to work the other way around: just use qx, but fall
943             back on L. And indeed, it wasn't that difficult to
944             write probe routines to find out if qx works reliably.
945              
946             All of this work seemed a little besides the point when I realized
947             that nearly every Windows installation of perl can deal with Bourne
948             shell redirects -- but still this module may very well improve
949             portability to some of the more unusual platforms such as VMS or
950             the older Macs.
951              
952             And at the very least, if I use this module religiously, I can
953             stop worrying about mistyping '2>&1'.
954              
955              
956             =head1 TODO
957              
958             o More filters -- "output_to_file", etc.
959             Add a general purpose, user-defineable one?
960              
961             o IPC::Cmd seems to have reliability problems (possibly, with
962             multi-threaded perls?), the precise output it returns can vary
963             from run to run. Possibly: implement a voting algorithm, return
964             the output most commonly recieved.
965              
966             o Better test coverage: autochomp; probe_system*;
967              
968             o 02-can_run.t tests multiple internal routines, only one flavor of
969             which need work for the overall behavior to work. Possibly should
970             ship only with tests that verify the interface methods...
971              
972             o IPC::Capture lacks "success", as of 0.05. This means the SYNOPSIS
973             is complete nonsense for versions 0.04 and earlier. For now,
974             not mentioning "success", but think about implementing it.
975              
976             =head1 SEE ALSO
977              
978             L
979             L
980             L
981              
982             Shell redirection apparently works on Windows:
983             http://www.perlmonks.org/?node_id=679842
984              
985              
986             =head1 AUTHOR
987              
988             Joseph Brenner, Edoom@kzsu.stanford.eduE,
989             07 Apr 2008
990              
991             =head1 COPYRIGHT AND LICENSE
992              
993             Copyright (C) 2008 by Joseph Brenner
994              
995             This library is free software; you can redistribute it and/or modify
996             it under the same terms as Perl itself, either Perl version 5.8.2 or,
997             at your option, any later version of Perl 5 you may have available.
998              
999             =head1 BUGS AND LIMITATIONS
1000              
1001             There are possible security gotchas with using this module,
1002             because it hands strings off to the shell to execute. Any
1003             commands built-up from user input should be scrubbed carefully
1004             before being run with this module. Using taint is strongly
1005             recommended: see L.
1006              
1007             =cut