IPC-Cmd-0.42
diff -urN perl-5.10.0.orig/lib/IPC/Cmd/t/01_IPC-Cmd.t perl-5.10.0/lib/IPC/Cmd/t/01_IPC-Cmd.t
--- perl-5.10.0.orig/lib/IPC/Cmd/t/01_IPC-Cmd.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd/t/01_IPC-Cmd.t 2009-03-10 15:43:11.000000000 +0100
@@ -4,30 +4,43 @@
use strict;
use lib qw[../lib];
-use File::Spec ();
+use File::Spec;
use Test::More 'no_plan';
-my $Class = 'IPC::Cmd';
-my @Funcs = qw[run can_run];
-my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer];
-my $IsWin32 = $^O eq 'MSWin32';
-my $Verbose = @ARGV ? 1 : 0;
+my $Class = 'IPC::Cmd';
+my $AClass = $Class . '::TimeOut';
+my @Funcs = qw[run can_run QUOTE];
+my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer];
+my $IsWin32 = $^O eq 'MSWin32';
+my $Verbose = @ARGV ? 1 : 0;
use_ok( $Class, $_ ) for @Funcs;
can_ok( $Class, $_ ) for @Funcs, @Meths;
can_ok( __PACKAGE__, $_ ) for @Funcs;
-my $Have_IPC_Run = $Class->can_use_ipc_run;
-my $Have_IPC_Open3 = $Class->can_use_ipc_open3;
+my $Have_IPC_Run = $Class->can_use_ipc_run || 0;
+my $Have_IPC_Open3 = $Class->can_use_ipc_open3 || 0;
+
+diag("IPC::Run: $Have_IPC_Run IPC::Open3: $Have_IPC_Open3");
+
+local $IPC::Cmd::VERBOSE = $Verbose;
+local $IPC::Cmd::VERBOSE = $Verbose;
+local $IPC::Cmd::DEBUG = $Verbose;
+local $IPC::Cmd::DEBUG = $Verbose;
-$IPC::Cmd::VERBOSE = $IPC::Cmd::VERBOSE = $Verbose;
### run tests in various configurations, based on what modules we have
-my @Prefs = (
- [ $Have_IPC_Run, $Have_IPC_Open3 ],
- [ 0, $Have_IPC_Open3 ],
- [ 0, 0 ]
-);
+my @Prefs = ( );
+push @Prefs, [ $Have_IPC_Run, $Have_IPC_Open3 ] if $Have_IPC_Run;
+
+### run this config twice to ensure FD restores work properly
+push @Prefs, [ 0, $Have_IPC_Open3 ],
+ [ 0, $Have_IPC_Open3 ] if $Have_IPC_Open3;
+
+### run this config twice to ensure FD restores work properly
+### these are the system() tests;
+push @Prefs, [ 0, 0 ], [ 0, 0 ];
+
### can_run tests
{
@@ -35,59 +48,92 @@
ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existant binary] );
}
-### run tests that print only to stdout
-{ ### list of commands and regexes matching output ###
+{ ### list of commands and regexes matching output
+ ### XXX use " everywhere when using literal strings as commands for
+ ### portability, especially on win32
my $map = [
- # command # output regex
- [ "$^X -v", qr/larry\s+wall/i, ],
- [ [$^X, '-v'], qr/larry\s+wall/i, ],
- [ "$^X -eprint+42 | $^X -neprint", qr/42/, ],
- [ [$^X,qw[-eprint+42 |], $^X, qw|-neprint|], qr/42/, ],
+ # command # output regex # buffer
+
+ ### run tests that print only to stdout
+ [ "$^X -v", qr/larry\s+wall/i, 3, ],
+ [ [$^X, '-v'], qr/larry\s+wall/i, 3, ],
+
+ ### pipes
+ [ "$^X -eprint+424 | $^X -neprint+split+2", qr/44/, 3, ],
+ [ [$^X,qw[-eprint+424 |], $^X, qw|-neprint+split+2|],
+ qr/44/, 3, ],
+ ### whitespace
+ [ [$^X, '-eprint+shift', q|a b a|], qr/a b a/, 3, ],
+ [ qq[$^X -eprint+shift "a b a"], qr/a b a/, 3, ],
+
+ ### whitespace + pipe
+ [ [$^X, '-eprint+shift', q|a b a|, q[|], $^X, qw[-neprint+split+b] ],
+ qr/a a/, 3, ],
+ [ qq[$^X -eprint+shift "a b a" | $^X -neprint+split+b],
+ qr/a a/, 3, ],
+
+ ### run tests that print only to stderr
+ [ "$^X -ewarn+42", qr/^42 /, 4, ],
+ [ [$^X, '-ewarn+42'], qr/^42 /, 4, ],
];
- diag( "Running tests that print only to stdout" ) if $Verbose;
+ ### extended test in developer mode
+ ### test if gzip | tar works
+ if( $Verbose ) {
+ my $gzip = can_run('gzip');
+ my $tar = can_run('tar');
+
+ if( $gzip and $tar ) {
+ push @$map,
+ [ [$gzip, qw[-cdf src/x.tgz |], $tar, qw[-tf -]],
+ qr/a/, 3, ];
+ }
+ }
+
### for each configuarion
for my $pref ( @Prefs ) {
- diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
- if $Verbose;
- $IPC::Cmd::USE_IPC_RUN = $IPC::Cmd::USE_IPC_RUN = $pref->[0];
- $IPC::Cmd::USE_IPC_OPEN3 = $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
+ local $IPC::Cmd::USE_IPC_RUN = !!$pref->[0];
+ local $IPC::Cmd::USE_IPC_RUN = !!$pref->[0];
+ local $IPC::Cmd::USE_IPC_OPEN3 = !!$pref->[1];
+ local $IPC::Cmd::USE_IPC_OPEN3 = !!$pref->[1];
### for each command
for my $aref ( @$map ) {
- my $cmd = $aref->[0];
- my $regex = $aref->[1];
+ my $cmd = $aref->[0];
+ my $regex = $aref->[1];
+ my $index = $aref->[2];
+
+ my $pp_cmd = ref $cmd ? "Array: @$cmd" : "Scalar: $cmd";
+ $pp_cmd .= " (IPC::Run: $pref->[0] IPC::Open3: $pref->[1])";
- my $pp_cmd = ref $cmd ? "@$cmd" : "$cmd";
- diag( "Running '$pp_cmd' as " . (ref $cmd ? "ARRAY" : "SCALAR") )
- if $Verbose;
+ diag( "Running '$pp_cmd'") if $Verbose;
### in scalar mode
- { diag( "Running scalar mode" ) if $Verbose;
- my $buffer;
+ { my $buffer;
my $ok = run( command => $cmd, buffer => \$buffer );
- ok( $ok, "Ran command succesfully" );
+ ok( $ok, "Ran '$pp_cmd' command succesfully" );
SKIP: {
skip "No buffers available", 1
unless $Class->can_capture_buffer;
like( $buffer, $regex,
- " Buffer filled properly" );
+ " Buffer matches $regex -- ($pp_cmd)" );
}
}
### in list mode
{ diag( "Running list mode" ) if $Verbose;
my @list = run( command => $cmd );
- ok( $list[0], "Command ran successfully" );
- ok( !$list[1], " No error code set" );
+
+ ok( $list[0], "Ran '$pp_cmd' successfully" );
+ ok( !$list[1], " No error code set -- ($pp_cmd)" );
my $list_length = $Class->can_capture_buffer ? 5 : 2;
is( scalar(@list), $list_length,
- " Output list has $list_length entries" );
+ " Output list has $list_length entries -- ($pp_cmd)" );
SKIP: {
skip "No buffers available", 6
@@ -97,188 +143,81 @@
isa_ok( $list[$_], 'ARRAY' ) for 2..4;
like( "@{$list[2]}", $regex,
- " Combined buffer holds output" );
+ " Combined buffer matches $regex -- ($pp_cmd)" );
- like( "@{$list[3]}", qr/$regex/,
- " Stdout buffer filled" );
- is( scalar( @{$list[4]} ), 0,
- " Stderr buffer empty" );
+ like( "@{$list[$index]}", qr/$regex/,
+ " Proper buffer($index) matches $regex -- ($pp_cmd)" );
+ is( scalar( @{$list[ $index==3 ? 4 : 3 ]} ), 0,
+ " Other buffer empty -- ($pp_cmd)" );
}
}
}
}
}
+__END__
+### special call to check that output is interleaved properly
+{ my $cmd = [$^X, File::Spec->catfile( qw[src output.pl] ) ];
-### run tests that print only to stderr
-### XXX lots of duplication from stdout tests, only difference
-### is buffer inspection
-{ ### list of commands and regexes matching output ###
- my $map = [
- # command # output regex
- [ "$^X -ewarn+42", qr/^42 /, ],
- [ [$^X, '-ewarn+42'], qr/^42 /, ],
- ];
-
- diag( "Running tests that print only to stderr" ) if $Verbose;
### for each configuarion
for my $pref ( @Prefs ) {
diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
if $Verbose;
- $IPC::Cmd::USE_IPC_RUN = $IPC::Cmd::USE_IPC_RUN = $pref->[0];
- $IPC::Cmd::USE_IPC_OPEN3 = $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
-
- ### for each command
- for my $aref ( @$map ) {
- my $cmd = $aref->[0];
- my $regex = $aref->[1];
-
- my $pp_cmd = ref $cmd ? "@$cmd" : "$cmd";
- diag( "Running '$pp_cmd' as " . (ref $cmd ? "ARRAY" : "SCALAR") )
- if $Verbose;
-
- ### in scalar mode
- { diag( "Running stderr command in scalar mode" ) if $Verbose;
- my $buffer;
- my $ok = run( command => $cmd, buffer => \$buffer );
-
- ok( $ok, "Ran stderr command succesfully in scalar mode." );
-
- SKIP: {
- # No buffers are expected if neither IPC::Run nor IPC::Open3 is used.
- skip "No buffers available", 1
- unless $Class->can_capture_buffer;
+ local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
+ local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
- like( $buffer, $regex,
- " Buffer filled properly from stderr" );
- }
- }
-
- ### in list mode
- { diag( "Running stderr command in list mode" ) if $Verbose;
- my @list = run( command => $cmd );
- ok( $list[0], "Ran stderr command successfully in list mode." );
- ok( !$list[1], " No error code set" );
-
- my $list_length = $Class->can_capture_buffer ? 5 : 2;
- is( scalar(@list), $list_length,
- " Output list has $list_length entries" );
-
- SKIP: {
- # No buffers are expected if neither IPC::Run nor IPC::Open3 is used.
- skip "No buffers available", 6
- unless $Class->can_capture_buffer;
-
- ### the last 3 entries from the RV, are they array refs?
- isa_ok( $list[$_], 'ARRAY' ) for 2..4;
-
- like( "@{$list[2]}", $regex,
- " Combined buffer holds output" );
-
- is( scalar( @{$list[3]} ), 0,
- " Stdout buffer empty" );
- like( "@{$list[4]}", qr/$regex/,
- " Stderr buffer filled" );
- }
+ my @list = run( command => $cmd, buffer => \my $buffer );
+ ok( $list[0], "Ran @{$cmd} successfully" );
+ ok( !$list[1], " No errorcode set" );
+ SKIP: {
+ skip "No buffers available", 3 unless $Class->can_capture_buffer;
+
+ TODO: {
+ local $TODO = qq[Can't interleave input/output buffers yet];
+
+ is( "@{$list[2]}",'1 2 3 4'," Combined output as expected" );
+ is( "@{$list[3]}", '1 3', " STDOUT as expected" );
+ is( "@{$list[4]}", '2 4', " STDERR as expected" );
+
}
}
- }
+ }
}
+
+
### test failures
{ ### for each configuarion
for my $pref ( @Prefs ) {
diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
if $Verbose;
- $IPC::Cmd::USE_IPC_RUN = $IPC::Cmd::USE_IPC_RUN = $pref->[0];
- $IPC::Cmd::USE_IPC_OPEN3 = $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
+ local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
+ local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
- my $ok = run( command => "$^X -ledie" );
- ok( !$ok, "Failure caught" );
+ my ($ok,$err) = run( command => "$^X -edie" );
+ ok( !$ok, "Non-zero exit caught" );
+ ok( $err, " Error '$err'" );
}
-}
-
-__END__
-
-
-### check if IPC::Run is already loaded, if so, IPC::Run tests
-### from IPC::Run are known to fail on win32
-my $Skip_IPC_Run = ($^O eq 'MSWin32' && exists $INC{'IPC/Run.pm'}) ? 1 : 0;
-
-use_ok( 'IPC::Cmd' ) or diag "Cmd.pm not found. Dying", die;
-
-IPC::Cmd->import( qw[can_run run] );
-
-### silence it ###
-$IPC::Cmd::VERBOSE = $IPC::Cmd::VERBOSE = $ARGV[0] ? 1 : 0;
-
-{
- ok( can_run('perl'), q[Found 'perl' in your path] );
- ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existant binary] );
-}
-
+}
-{ ### list of commands and regexes matching output ###
- my $map = [
- ["$^X -v", qr/larry\s+wall/i, ],
- [[$^X, '-v'], qr/larry\s+wall/i, ],
- ["$^X -eprint1 | $^X -neprint", qr/1/, ],
- [[$^X,qw[-eprint1 |], $^X, qw|-neprint|], qr/1/, ],
- ];
-
- my @prefs = ( [1,1], [0,1], [0,0] );
-
- ### if IPC::Run is already loaded,remove tests involving IPC::Run
- ### when on win32
- shift @prefs if $Skip_IPC_Run;
-
- for my $pref ( @prefs ) {
- $IPC::Cmd::USE_IPC_RUN = $IPC::Cmd::USE_IPC_RUN = $pref->[0];
- $IPC::Cmd::USE_IPC_OPEN3 = $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
-
- for my $aref ( @$map ) {
- my $cmd = $aref->[0];
- my $regex = $aref->[1];
-
- my $Can_Buffer;
- my $captured;
- my $ok = run( command => $cmd,
- buffer => \$captured,
- );
-
- ok($ok, q[Successful run of command] );
-
- SKIP: {
- skip "No buffers returned", 1 unless $captured;
- like( $captured, $regex, q[ Buffer filled] );
-
- ### if we get here, we have buffers ###
- $Can_Buffer++;
- }
-
- my @list = run( command => $cmd );
- ok( $list[0], "Command ran successfully" );
- ok( !$list[1], " No error code set" );
-
- SKIP: {
- skip "No buffers, cannot do buffer tests", 3
- unless $Can_Buffer;
+### timeout tests
+{ my $timeout = 1;
+ for my $pref ( @Prefs ) {
+ diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
+ if $Verbose;
- ok( (grep /$regex/, @{$list[2]}),
- " Out buffer filled" );
- SKIP: {
- skip "IPC::Run bug prevents separated " .
- "stdout/stderr buffers", 2 if $pref->[0];
+ local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
+ local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
- ok( (grep /$regex/, @{$list[3]}),
- " Stdout buffer filled" );
- ok( @{$list[4]} == 0,
- " Stderr buffer empty" );
- }
- }
- }
+ ### -X to quiet the 'sleep without parens is ambiguous' warning
+ my ($ok,$err) = run( command => "$^X -Xesleep+4", timeout => $timeout );
+ ok( !$ok, "Timeout caught" );
+ ok( $err, " Error stored" );
+ ok( not(ref($err)), " Error string is not a reference" );
+ like( $err,qr/^$AClass/," Error '$err' mentions $AClass" );
}
-}
+}
+
diff -urN perl-5.10.0.orig/lib/IPC/Cmd/t/src/output.pl perl-5.10.0/lib/IPC/Cmd/t/src/output.pl
--- perl-5.10.0.orig/lib/IPC/Cmd/t/src/output.pl 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd/t/src/output.pl 2009-03-10 15:43:11.000000000 +0100
@@ -0,0 +1,13 @@
+use strict;
+use warnings;
+use IO::Handle;
+
+STDOUT->autoflush(1);
+STDERR->autoflush(1);
+
+my $max = shift || 4;
+for ( 1..$max ) {
+ $_ % 2
+ ? print STDOUT $_
+ : print STDERR $_;
+}
diff -urN perl-5.10.0.orig/lib/IPC/Cmd/t/src/x.tgz.packed perl-5.10.0/lib/IPC/Cmd/t/src/x.tgz.packed
--- perl-5.10.0.orig/lib/IPC/Cmd/t/src/x.tgz.packed 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd/t/src/x.tgz.packed 2009-03-10 15:43:43.000000000 +0100
@@ -0,0 +1,18 @@
+#########################################################################
+This is a binary file that was packed with the 'uupacktool.pl' which
+is included in the Perl distribution.
+
+To unpack this file use the following command:
+
+ uupacktool.pl -u lib/IPC/Cmd/t/src/x.tgz.packed lib/IPC/Cmd/t/src/x.tgz
+
+To recreate it use the following command:
+
+ uupacktool.pl -p lib/IPC/Cmd/t/src/x.tgz lib/IPC/Cmd/t/src/x.tgz.packed
+
+Created at Tue Mar 10 15:43:43 2009
+#########################################################################
+__UU__
+M'XL(`````````^W.NPW"0!!%T2EE2YC%:[N>#7""1,"G?QM##!&.SDE&(]W@
+M]?B_K)E3:Y&;>1KWFZ?W_Q&O)(<Z9!OW/FN4/&!;/.^/?BLE+OUZ_M9MV;(<
+6,0@```````````!^6P'GVS1B`"@`````
diff -urN perl-5.10.0.orig/lib/IPC/Cmd.pm perl-5.10.0/lib/IPC/Cmd.pm
--- perl-5.10.0.orig/lib/IPC/Cmd.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd.pm 2009-03-10 15:42:10.000000000 +0100
@@ -4,16 +4,19 @@
BEGIN {
- use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
- use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
- use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0;
+ use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
+ use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
+ use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0;
+ use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut';
+ use constant SPECIAL_CHARS => qw[< > | &];
+ use constant QUOTE => do { IS_WIN32 ? q["] : q['] };
use Exporter ();
use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
$USE_IPC_RUN $USE_IPC_OPEN3 $WARN
];
- $VERSION = '0.40_1';
+ $VERSION = '0.42';
$VERBOSE = 0;
$DEBUG = 0;
$WARN = 1;
@@ -21,12 +24,13 @@
$USE_IPC_OPEN3 = not IS_VMS;
@ISA = qw[Exporter];
- @EXPORT_OK = qw[can_run run];
+ @EXPORT_OK = qw[can_run run QUOTE];
}
require Carp;
use File::Spec;
use Params::Check qw[check];
+use Text::ParseWords (); # import ONLY if needed!
use Module::Load::Conditional qw[can_load];
use Locale::Maketext::Simple Style => 'gettext';
@@ -50,7 +54,8 @@
my $buffer;
if( scalar run( command => $cmd,
verbose => 0,
- buffer => \$buffer )
+ buffer => \$buffer,
+ timeout => 20 )
) {
print "fetched webpage successfully: $buffer\n";
}
@@ -73,6 +78,7 @@
### don't have IPC::Cmd be verbose, ie don't print to stdout or
### stderr when running commands -- default is '0'
$IPC::Cmd::VERBOSE = 0;
+
=head1 DESCRIPTION
@@ -86,7 +92,7 @@
=head1 CLASS METHODS
-=head2 $bool = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
+=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
Utility function that tells you if C<IPC::Run> is available.
If the verbose flag is passed, it will print diagnostic messages
@@ -109,10 +115,10 @@
);
### otherwise, we're good to go
- return 1;
+ return $IPC::Run::VERSION;
}
-=head2 $bool = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
+=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
Utility function that tells you if C<IPC::Open3> is available.
If the verbose flag is passed, it will print diagnostic messages
@@ -126,17 +132,17 @@
my $verbose = shift || 0;
### ipc::open3 is not working on VMS becasue of a lack of fork.
- ### todo, win32 also does not have fork, so need to do more research.
- return 0 if IS_VMS;
+ ### XXX todo, win32 also does not have fork, so need to do more research.
+ return if IS_VMS;
- ### ipc::open3 works on every platform, but it can't capture buffers
- ### on win32 :(
+ ### ipc::open3 works on every non-VMS platform platform, but it can't
+ ### capture buffers on win32 :(
return unless can_load(
modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
verbose => ($WARN && $verbose),
);
- return 1;
+ return $IPC::Open3::VERSION;
}
=head2 $bool = IPC::Cmd->can_capture_buffer
@@ -201,9 +207,9 @@
}
}
-=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR] );
+=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
-C<run> takes 3 arguments:
+C<run> takes 4 arguments:
=over 4
@@ -238,6 +244,16 @@
Of course, this requires that the underlying call supports buffers. See
the note on buffers right above.
+=item timeout
+
+Sets the maximum time the command is allowed to run before aborting,
+using the built-in C<alarm()> call. If the timeout is triggered, the
+C<errorcode> in the return value will be set to an object of the
+C<IPC::Cmd::TimeOut> class. See the C<errorcode> section below for
+details.
+
+Defaults to C<0>, meaning no timeout is set.
+
=back
C<run> will return a simple C<true> or C<false> when called in scalar
@@ -251,11 +267,15 @@
A simple boolean indicating if the command executed without errors or
not.
-=item errorcode
+=item error message
If the first element of the return value (success) was 0, then some
-error occurred. This second element is the error code the command
-you requested exited with, if available.
+error occurred. This second element is the error message the command
+you requested exited with, if available. This is generally a pretty
+printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
+what they can contain.
+If the error was a timeout, the C<error message> will be prefixed with
+the string C<IPC::Cmd::TimeOut>, the timeout class.
=item full_buffer
@@ -288,27 +308,48 @@
=cut
+{ my @acc = qw[ok error _fds];
+
+ ### autogenerate accessors ###
+ for my $key ( @acc ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ $_[0]->{$key} = $_[1] if @_ > 1;
+ return $_[0]->{$key};
+ }
+ }
+}
+
sub run {
+ ### container to store things in
+ my $self = bless {}, __PACKAGE__;
+
my %hash = @_;
### if the user didn't provide a buffer, we'll store it here.
my $def_buf = '';
- my($verbose,$cmd,$buffer);
+ my($verbose,$cmd,$buffer,$timeout);
my $tmpl = {
verbose => { default => $VERBOSE, store => \$verbose },
buffer => { default => \$def_buf, store => \$buffer },
command => { required => 1, store => \$cmd,
- allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' }
+ allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
},
+ timeout => { default => 0, store => \$timeout },
};
-
+
unless( check( $tmpl, \%hash, $VERBOSE ) ) {
- Carp::carp(loc("Could not validate input: %1", Params::Check->last_error));
+ Carp::carp( loc( "Could not validate input: %1",
+ Params::Check->last_error ) );
return;
};
- print loc("Running [%1]...\n", (ref $cmd ? "@$cmd" : $cmd)) if $verbose;
+ ### strip any empty elements from $cmd if present
+ $cmd = [ grep { length && defined } @$cmd ] if ref $cmd;
+
+ my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
+ print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
### did the user pass us a buffer to fill or not? if so, set this
### flag so we know what is expected of us
@@ -323,7 +364,7 @@
my $_out_handler = sub {
my $buf = shift;
return unless defined $buf;
-
+
print STDOUT $buf if $verbose;
push @buffer, $buf;
push @buff_out, $buf;
@@ -341,39 +382,70 @@
### flag to indicate we have a buffer captured
- my $have_buffer = __PACKAGE__->can_capture_buffer ? 1 : 0;
+ my $have_buffer = $self->can_capture_buffer ? 1 : 0;
### flag indicating if the subcall went ok
my $ok;
- ### IPC::Run is first choice if $USE_IPC_RUN is set.
- if( $USE_IPC_RUN and __PACKAGE__->can_use_ipc_run( 1 ) ) {
- ### ipc::run handlers needs the command as a string or an array ref
-
- __PACKAGE__->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
- if $DEBUG;
+ ### dont look at previous errors:
+ local $?;
+ local $@;
+ local $!;
+
+ ### we might be having a timeout set
+ eval {
+ local $SIG{ALRM} = sub { die bless sub {
+ ALARM_CLASS .
+ qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
+ }, ALARM_CLASS } if $timeout;
+ alarm $timeout || 0;
+
+ ### IPC::Run is first choice if $USE_IPC_RUN is set.
+ if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
+ ### ipc::run handlers needs the command as a string or an array ref
+
+ $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
+ if $DEBUG;
+
+ $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
+
+ ### since IPC::Open3 works on all platforms, and just fails on
+ ### win32 for capturing buffers, do that ideally
+ } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
+
+ $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
+ if $DEBUG;
+
+ ### in case there are pipes in there;
+ ### IPC::Open3 will call exec and exec will do the right thing
+ $ok = $self->_open3_run(
+ $cmd, $_out_handler, $_err_handler, $verbose
+ );
- $ok = __PACKAGE__->_ipc_run( $cmd, $_out_handler, $_err_handler );
-
- ### since IPC::Open3 works on all platforms, and just fails on
- ### win32 for capturing buffers, do that ideally
- } elsif ( $USE_IPC_OPEN3 and __PACKAGE__->can_use_ipc_open3( 1 ) ) {
-
- __PACKAGE__->_debug( "# Using IPC::Open3. Have buffer: $have_buffer" )
- if $DEBUG;
-
- ### in case there are pipes in there;
- ### IPC::Open3 will call exec and exec will do the right thing
- $ok = __PACKAGE__->_open3_run(
- ( ref $cmd ? "@$cmd" : $cmd ),
- $_out_handler, $_err_handler, $verbose
- );
+ ### if we are allowed to run verbose, just dispatch the system command
+ } else {
+ $self->_debug( "# Using system(). Have buffer: $have_buffer" )
+ if $DEBUG;
+ $ok = $self->_system_run( $cmd, $verbose );
+ }
- ### if we are allowed to run verbose, just dispatch the system command
- } else {
- __PACKAGE__->_debug( "# Using system(). Have buffer: $have_buffer" )
- if $DEBUG;
- $ok = __PACKAGE__->_system_run( (ref $cmd ? "@$cmd" : $cmd), $verbose );
+ alarm 0;
+ };
+
+ ### restore STDIN after duping, or STDIN will be closed for
+ ### this current perl process!
+ $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
+
+ my $err;
+ unless( $ok ) {
+ ### alarm happened
+ if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
+ $err = $@->(); # the error code is an expired alarm
+
+ ### another error happened, set by the dispatchub
+ } else {
+ $err = $self->error;
+ }
}
### fill the buffer;
@@ -383,8 +455,8 @@
### context, or just a simple 'ok' in scalar
return wantarray
? $have_buffer
- ? ($ok, $?, \@buffer, \@buff_out, \@buff_err)
- : ($ok, $? )
+ ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
+ : ($ok, $err )
: $ok
@@ -418,15 +490,30 @@
? qw[STDIN STDOUT STDERR]
: qw[STDIN]
);
- __PACKAGE__->__dup_fds( @fds_to_dup );
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
-
- my $pid = IPC::Open3::open3(
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ ### dont stringify @$cmd, so spaces in filenames/paths are
+ ### treated properly
+ my $pid = eval {
+ IPC::Open3::open3(
'<&STDIN',
(IS_WIN32 ? '>&STDOUT' : $kidout),
(IS_WIN32 ? '>&STDERR' : $kiderror),
- $cmd
+ ( ref $cmd ? @$cmd : $cmd ),
);
+ };
+
+ ### open3 error occurred
+ if( $@ and $@ =~ /^open3:/ ) {
+ $self->ok( 0 );
+ $self->error( $@ );
+ return;
+ };
### use OUR stdin, not $kidin. Somehow,
### we never get the input.. so jump through
@@ -459,7 +546,7 @@
warn(loc("Error reading from process: %1", $!));
last OUTER;
}
-
+
### check for $len. it may be 0, at which point we're
### done reading, so don't try to process it.
### if we would print anyway, we'd provide bogus information
@@ -478,88 +565,130 @@
### restore STDIN after duping, or STDIN will be closed for
### this current perl process!
- __PACKAGE__->__reopen_fds( @fds_to_dup );
+ ### done in the parent call now
+ # $self->__reopen_fds( @fds_to_dup );
- return if $?; # some error occurred
- return 1;
+ ### some error occurred
+ if( $? ) {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ return;
+ } else {
+ return $self->ok( 1 );
+ }
}
+### text::parsewords::shellwordss() uses unix semantics. that will break
+### on win32
+{ my $parse_sub = IS_WIN32
+ ? __PACKAGE__->can('_split_like_shell_win32')
+ : Text::ParseWords->can('shellwords');
+
+ sub _ipc_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $_out_handler = shift;
+ my $_err_handler = shift;
+
+ STDOUT->autoflush(1); STDERR->autoflush(1);
-sub _ipc_run {
- my $self = shift;
- my $cmd = shift;
- my $_out_handler = shift;
- my $_err_handler = shift;
-
- STDOUT->autoflush(1); STDERR->autoflush(1);
+ ### a command like:
+ # [
+ # '/usr/bin/gzip',
+ # '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
+ # '|',
+ # '/usr/bin/tar',
+ # '-tf -'
+ # ]
+ ### needs to become:
+ # [
+ # ['/usr/bin/gzip', '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
+ # '|',
+ # ['/usr/bin/tar', '-tf -']
+ # ]
+
+
+ my @command;
+ my $special_chars;
+
+ my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
+ if( ref $cmd ) {
+ my $aref = [];
+ for my $item (@$cmd) {
+ if( $item =~ $re ) {
+ push @command, $aref, $item;
+ $aref = [];
+ $special_chars .= $1;
+ } else {
+ push @$aref, $item;
+ }
+ }
+ push @command, $aref;
+ } else {
+ @command = map { if( $_ =~ $re ) {
+ $special_chars .= $1; $_;
+ } else {
+# [ split /\s+/ ]
+ [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
+ }
+ } split( /\s*$re\s*/, $cmd );
+ }
- ### a command like:
- # [
- # '/usr/bin/gzip',
- # '-cdf',
- # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
- # '|',
- # '/usr/bin/tar',
- # '-tf -'
- # ]
- ### needs to become:
- # [
- # ['/usr/bin/gzip', '-cdf',
- # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
- # '|',
- # ['/usr/bin/tar', '-tf -']
- # ]
-
-
- my @command; my $special_chars;
- if( ref $cmd ) {
- my $aref = [];
- for my $item (@$cmd) {
- if( $item =~ /([<>|&])/ ) {
- push @command, $aref, $item;
- $aref = [];
- $special_chars .= $1;
+ ### if there's a pipe in the command, *STDIN needs to
+ ### be inserted *BEFORE* the pipe, to work on win32
+ ### this also works on *nix, so we should do it when possible
+ ### this should *also* work on multiple pipes in the command
+ ### if there's no pipe in the command, append STDIN to the back
+ ### of the command instead.
+ ### XXX seems IPC::Run works it out for itself if you just
+ ### dont pass STDIN at all.
+ # if( $special_chars and $special_chars =~ /\|/ ) {
+ # ### only add STDIN the first time..
+ # my $i;
+ # @command = map { ($_ eq '|' && not $i++)
+ # ? ( \*STDIN, $_ )
+ # : $_
+ # } @command;
+ # } else {
+ # push @command, \*STDIN;
+ # }
+
+ # \*STDIN is already included in the @command, see a few lines up
+ my $ok = eval { IPC::Run::run( @command,
+ fileno(STDOUT).'>',
+ $_out_handler,
+ fileno(STDERR).'>',
+ $_err_handler
+ )
+ };
+
+ ### all is well
+ if( $ok ) {
+ return $self->ok( $ok );
+
+ ### some error occurred
+ } else {
+ $self->ok( 0 );
+
+ ### if the eval fails due to an exception, deal with it
+ ### unless it's an alarm
+ if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
+ $self->error( $@ );
+
+ ### if it *is* an alarm, propagate
+ } elsif( $@ ) {
+ die $@;
+
+ ### some error in the sub command
} else {
- push @$aref, $item;
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
}
+
+ return;
}
- push @command, $aref;
- } else {
- @command = map { if( /([<>|&])/ ) {
- $special_chars .= $1; $_;
- } else {
- [ split / +/ ]
- }
- } split( /\s*([<>|&])\s*/, $cmd );
- }
-
- ### if there's a pipe in the command, *STDIN needs to
- ### be inserted *BEFORE* the pipe, to work on win32
- ### this also works on *nix, so we should do it when possible
- ### this should *also* work on multiple pipes in the command
- ### if there's no pipe in the command, append STDIN to the back
- ### of the command instead.
- ### XXX seems IPC::Run works it out for itself if you just
- ### dont pass STDIN at all.
- # if( $special_chars and $special_chars =~ /\|/ ) {
- # ### only add STDIN the first time..
- # my $i;
- # @command = map { ($_ eq '|' && not $i++)
- # ? ( \*STDIN, $_ )
- # : $_
- # } @command;
- # } else {
- # push @command, \*STDIN;
- # }
-
-
- # \*STDIN is already included in the @command, see a few lines up
- return IPC::Run::run( @command,
- fileno(STDOUT).'>',
- $_out_handler,
- fileno(STDERR).'>',
- $_err_handler
- );
+ }
}
sub _system_run {
@@ -567,18 +696,117 @@
my $cmd = shift;
my $verbose = shift || 0;
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
- __PACKAGE__->__dup_fds( @fds_to_dup );
-
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
+
### system returns 'true' on failure -- the exit code of the cmd
- system( $cmd );
+ $self->ok( 1 );
+ system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ };
+
+ ### done in the parent call now
+ #$self->__reopen_fds( @fds_to_dup );
+
+ return unless $self->ok;
+ return $self->ok;
+}
+
+{ my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
+
+
+ sub __fix_cmd_whitespace_and_special_chars {
+ my $self = shift;
+ my $cmd = shift;
+
+ ### command has a special char in it
+ if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
+
+ ### since we have special chars, we have to quote white space
+ ### this *may* conflict with the parsing :(
+ my $fixed;
+ my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
+
+ $self->_debug( "# Quoted $fixed arguments containing whitespace" )
+ if $DEBUG && $fixed;
+
+ ### stringify it, so the special char isn't escaped as argument
+ ### to the program
+ $cmd = join ' ', @cmd;
+ }
+
+ return $cmd;
+ }
+}
+
+
+### XXX this is cribbed STRAIGHT from M::B 0.30 here:
+### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
+### XXX this *should* be integrated into text::parsewords
+sub _split_like_shell_win32 {
+ # As it turns out, Windows command-parsing is very different from
+ # Unix command-parsing. Double-quotes mean different things,
+ # backslashes don't necessarily mean escapes, and so on. So we
+ # can't use Text::ParseWords::shellwords() to break a command string
+ # into words. The algorithm below was bashed out by Randy and Ken
+ # (mostly Randy), and there are a lot of regression tests, so we
+ # should feel free to adjust if desired.
+
+ local $_ = shift;
+
+ my @argv;
+ return @argv unless defined() && length();
+
+ my $arg = '';
+ my( $i, $quote_mode ) = ( 0, 0 );
+
+ while ( $i < length() ) {
- __PACKAGE__->__reopen_fds( @fds_to_dup );
+ my $ch = substr( $_, $i , 1 );
+ my $next_ch = substr( $_, $i+1, 1 );
- return if $?;
- return 1;
+ if ( $ch eq '\\' && $next_ch eq '"' ) {
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
+ $arg .= '\\';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
+ $quote_mode = !$quote_mode;
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
+ ( $i + 2 == length() ||
+ substr( $_, $i + 2, 1 ) eq ' ' )
+ ) { # for cases like: a"" => [ 'a' ]
+ push( @argv, $arg );
+ $arg = '';
+ $i += 2;
+ } elsif ( $ch eq '"' ) {
+ $quote_mode = !$quote_mode;
+ } elsif ( $ch eq ' ' && !$quote_mode ) {
+ push( @argv, $arg ) if $arg;
+ $arg = '';
+ ++$i while substr( $_, $i + 1, 1 ) eq ' ';
+ } else {
+ $arg .= $ch;
+ }
+
+ $i++;
+ }
+
+ push( @argv, $arg ) if defined( $arg ) && length( $arg );
+ return @argv;
}
+
+
{ use File::Spec;
use Symbol;
@@ -660,9 +888,50 @@
return 1;
}
+sub _pp_child_error {
+ my $self = shift;
+ my $cmd = shift or return;
+ my $ce = shift or return;
+ my $pp_cmd = ref $cmd ? "@$cmd" : $cmd;
+
+
+ my $str;
+ if( $ce == -1 ) {
+ ### Include $! in the error message, so that the user can
+ ### see 'No such file or directory' versus 'Permission denied'
+ ### versus 'Cannot fork' or whatever the cause was.
+ $str = "Failed to execute '$pp_cmd': $!";
+
+ } elsif ( $ce & 127 ) {
+ ### some signal
+ $str = loc( "'%1' died with signal %d, %s coredump\n",
+ $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
+
+ } else {
+ ### Otherwise, the command run but gave error status.
+ $str = "'$pp_cmd' exited with value " . ($ce >> 8);
+ }
+
+ $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
+
+ return $str;
+}
1;
+=head2 $q = QUOTE
+
+Returns the character used for quoting strings on this platform. This is
+usually a C<'> (single quote) on most systems, but some systems use different
+quotes. For example, C<Win32> uses C<"> (double quote).
+
+You can use it as follows:
+
+ use IPC::Cmd qw[run QUOTE];
+ my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
+
+This makes sure that C<foo bar> is treated as a string, rather than two
+seperate arguments to the C<echo> function.
__END__
@@ -733,11 +1002,28 @@
=over 4
-=item Whitespace
+=item Whitespace and IPC::Open3 / system()
-When you provide a string as this argument, the string will be
-split on whitespace to determine the individual elements of your
-command. Although this will usually just Do What You Mean, it may
+When using C<IPC::Open3> or C<system>, if you provide a string as the
+C<command> argument, it is assumed to be appropriately escaped. You can
+use the C<QUOTE> constant to use as a portable quote character (see above).
+However, if you provide and C<Array Reference>, special rules apply:
+
+If your command contains C<Special Characters> (< > | &), it will
+be internally stringified before executing the command, to avoid that these
+special characters are escaped and passed as arguments instead of retaining
+their special meaning.
+
+However, if the command contained arguments that contained whitespace,
+stringifying the command would loose the significance of the whitespace.
+Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
+command if the command is passed as an arrayref and contains special characters.
+
+=item Whitespace and IPC::Run
+
+When using C<IPC::Run>, if you provide a string as the C<command> argument,
+the string will be split on whitespace to determine the individual elements
+of your command. Although this will usually just Do What You Mean, it may
break if you have files or commands with whitespace in them.
If you do not wish this to happen, you should provide an array
@@ -765,12 +1051,30 @@
Since this will lead to issues as described above.
+
=item IO Redirect
Currently it is too complicated to parse your command for IO
Redirections. For capturing STDOUT or STDERR there is a work around
however, since you can just inspect your buffers for the contents.
+=item Interleaving STDOUT/STDERR
+
+Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
+bursts of output from a program, ie this sample:
+
+ for ( 1..4 ) {
+ $_ % 2 ? print STDOUT $_ : print STDERR $_;
+ }
+
+IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
+the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
+
+It should have been 1, 2, 3, 4.
+
+This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
+STDOUT and STDERR
+
=back
=head1 See Also