rpms/perl/devel perl-5.10.0-IPC_Cmd-0.42.patch, NONE, 1.1 .cvsignore, 1.16, 1.17 perl.spec, 1.201, 1.202 sources, 1.16, 1.17
Marcela Mašláňová
mmaslano at fedoraproject.org
Tue Feb 3 06:47:02 UTC 2009
- Previous message: rpms/gnome-games/devel .cvsignore, 1.92, 1.93 gnome-games.spec, 1.196, 1.197 sources, 1.97, 1.98
- Next message: rpms/virtaal/devel .cvsignore, 1.3, 1.4 sources, 1.3, 1.4 virtaal.spec, 1.2, 1.3 virtaal-0.3beta1-version.patch, 1.1, NONE
- Messages sorted by:
[ date ]
[ thread ]
[ subject ]
[ author ]
Author: mmaslano
Update of /cvs/pkgs/rpms/perl/devel
In directory cvs1.fedora.phx.redhat.com:/tmp/cvs-serv20491
Modified Files:
.cvsignore perl.spec sources
Added Files:
perl-5.10.0-IPC_Cmd-0.42.patch
Log Message:
* Tue Feb 3 2009 Marcela Mašláňová <mmaslano at redhat.com> - 4:5.10.0-55
- update IPC::Cmd to v 0.42
perl-5.10.0-IPC_Cmd-0.42.patch:
--- NEW FILE perl-5.10.0-IPC_Cmd-0.42.patch ---
diff -up perl-5.10.0/lib/IPC/Cmd.pm.ddd perl-5.10.0/lib/IPC/Cmd.pm
--- perl-5.10.0/lib/IPC/Cmd.pm.ddd 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd.pm 2008-10-10 11:44:19.000000000 +0200
@@ -4,16 +4,19 @@ use strict;
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 @@ BEGIN {
$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 @@ IPC::Cmd - finding and running system co
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 @@ IPC::Cmd - finding and running system co
### 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 @@ as adhere to your verbosity settings.
=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 @@ sub can_use_ipc_run {
);
### 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 @@ sub can_use_ipc_open3 {
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 @@ sub can_run {
}
}
-=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 @@ and inspect the individual buffers.
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 @@ In list context, you will be returned a
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 @@ what modules or function calls to use wh
=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 @@ sub run {
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 @@ sub run {
### 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 @@ sub run {
### 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 @@ sub _open3_run {
? 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 @@ sub _open3_run {
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 @@ sub _open3_run {
### 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 @@ sub _system_run {
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 @@ sub _debug {
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 @@ Defaults to true. Turn this off at your
=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 @@ But take care not to pass it as, for exa
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
diff -up perl-5.10.0/lib/IPC/Cmd/t/01_IPC-Cmd.t.ddd perl-5.10.0/lib/IPC/Cmd/t/01_IPC-Cmd.t
--- perl-5.10.0/lib/IPC/Cmd/t/01_IPC-Cmd.t.ddd 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd/t/01_IPC-Cmd.t 2008-10-09 16:08:48.000000000 +0200
@@ -4,30 +4,43 @@ BEGIN { chdir 't' if -d 't' };
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 @@ my @Prefs = (
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 @@ my @Prefs = (
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 -up perl-5.10.0/lib/IPC/Cmd/t/02_Interactive.t.ddd perl-5.10.0/lib/IPC/Cmd/t/02_Interactive.t
--- perl-5.10.0/lib/IPC/Cmd/t/02_Interactive.t.ddd 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd/t/02_Interactive.t 2007-10-16 11:01:27.000000000 +0200
@@ -1,110 +1,110 @@
-BEGIN { chdir 't' if -d 't' };
-BEGIN { use lib '../lib' };
-
-use strict;
-use File::Spec;
-
-### only run interactive tests when there's someone that can answer them
-use Test::More -t STDOUT
- ? 'no_plan'
- : ( skip_all => "No interactive tests from harness" );
-
-my $Class = 'IPC::Cmd';
-my $Child = File::Spec->catfile( qw[src child.pl] );
-my @FDs = 0..20;
-my $IsWin32 = $^O eq 'MSWin32';
-
-use_ok( $Class, 'run' );
-$IPC::Cmd::DEBUG = 1;
-
-my $Have_IPC_Run = $Class->can_use_ipc_run;
-my $Have_IPC_Open3 = $Class->can_use_ipc_open3;
-
-### configurations to test IPC::Cmd with
-my @Conf = (
- [ $Have_IPC_Run, $Have_IPC_Open3 ],
- [ 0, $Have_IPC_Open3 ],
- [ 0, 0 ]
-);
-
-
-
-
-### first, check which FD's are open. they should be open
-### /after/ we run our tests as well.
-### 0, 1 and 2 should be open, as they are STDOUT, STDERR and STDIN
-### XXX 2 are opened by Test::Builder at least.. this is 'whitebox'
-### knowledge, so unsafe to test against. around line 1322:
-# sub _open_testhandles {
-# return if $Opened_Testhandles;
-# # We dup STDOUT and STDERR so people can change them in their
-# # test suites while still getting normal test output.
-# open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
-# open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
-# $Opened_Testhandles = 1;
-# }
-
-my @Opened;
-{ for ( @FDs ) {
- my $fh;
- my $rv = open $fh, "<&$_";
- push @Opened, $_ if $rv;
- }
- diag( "Opened FDs: @Opened" );
- cmp_ok( scalar(@Opened), '>=', 3,
- "At least 3 FDs are opened" );
-}
-
-for my $aref ( @Conf ) {
-
- ### stupid warnings
- local $IPC::Cmd::USE_IPC_RUN = $aref->[0];
- local $IPC::Cmd::USE_IPC_RUN = $aref->[0];
-
- local $IPC::Cmd::USE_IPC_OPEN3 = $aref->[1];
- local $IPC::Cmd::USE_IPC_OPEN3 = $aref->[1];
-
- diag("Config: IPC::Run = $aref->[0] IPC::Open3 = $aref->[1]");
- ok( -t STDIN, "STDIN attached to a tty" );
-
- for my $cmd ( qq[$^X $Child], qq[$^X $Child | $^X -neprint] ) {
-
- diag("Please enter some input. It will be echo'd back to you");
- my $buffer;
- my $ok = run( command => $cmd, verbose => 1, buffer => \$buffer );
-
- ok( $ok, " Command '$cmd' ran succesfully" );
-
- SKIP: {
- skip "No buffers available", 1 unless $Class->can_capture_buffer;
- ok( defined $buffer, " Input captured" );
- }
- }
-}
-
-### check we didnt leak any FHs
-{ ### should be opened
- my %open = map { $_ => 1 } @Opened;
-
- for ( @FDs ) {
- my $fh;
- my $rv = open $fh, "<&=$_";
-
- ### these should be open
- if( $open{$_} ) {
- ok( $rv, "FD $_ opened" );
- ok( $fh, " FH indeed opened" );
- is( fileno($fh), $_, " Opened at the correct fileno($_)" );
- } else {
- ok( !$rv, "FD $_ not opened" );
- ok( !(fileno($fh)), " FH indeed closed" );
-
- ### extra debug info if tests fail
-# use Devel::Peek;
-# use Data::Dumper;
-# diag( "RV=$rv FH=$fh Fileno=". fileno($fh). Dump($fh) ) if $rv;
-# diag( Dumper( [stat $fh] ) ) if $rv;
-
- }
- }
-}
+BEGIN { chdir 't' if -d 't'; };
+BEGIN { use lib '../lib'; };
+
+use strict;
+use File::Spec;
+
+### only run interactive tests when there's someone that can answer them
+use Test::More -t STDOUT
+ ? 'no_plan'
+ : ( skip_all => "No interactive tests from harness" );
+
+my $Class = 'IPC::Cmd';
+my $Child = File::Spec->catfile( qw[src child.pl] );
+my @FDs = 0..20;
+my $IsWin32 = $^O eq 'MSWin32';
+
+use_ok( $Class, 'run' );
+$IPC::Cmd::DEBUG = 1;
+
+my $Have_IPC_Run = $Class->can_use_ipc_run;
+my $Have_IPC_Open3 = $Class->can_use_ipc_open3;
+
+### configurations to test IPC::Cmd with
+my @Conf = (
+ [ $Have_IPC_Run, $Have_IPC_Open3 ],
+ [ 0, $Have_IPC_Open3 ],
+ [ 0, 0 ]
+);
+
+
+
+
+### first, check which FD's are open. they should be open
+### /after/ we run our tests as well.
+### 0, 1 and 2 should be open, as they are STDOUT, STDERR and STDIN
+### XXX 2 are opened by Test::Builder at least.. this is 'whitebox'
+### knowledge, so unsafe to test against. around line 1322:
+# sub _open_testhandles {
+# return if $Opened_Testhandles;
+# # We dup STDOUT and STDERR so people can change them in their
+# # test suites while still getting normal test output.
+# open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
+# open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
+# $Opened_Testhandles = 1;
+# }
+
+my @Opened;
+{ for ( @FDs ) {
+ my $fh;
+ my $rv = open $fh, "<&$_";
+ push @Opened, $_ if $rv;
+ }
+ diag( "Opened FDs: @Opened" );
+ cmp_ok( scalar(@Opened), '>=', 3,
+ "At least 3 FDs are opened" );
+}
+
+for my $aref ( @Conf ) {
+
+ ### stupid warnings
+ local $IPC::Cmd::USE_IPC_RUN = $aref->[0];
+ local $IPC::Cmd::USE_IPC_RUN = $aref->[0];
+
+ local $IPC::Cmd::USE_IPC_OPEN3 = $aref->[1];
+ local $IPC::Cmd::USE_IPC_OPEN3 = $aref->[1];
+
+ diag("Config: IPC::Run = $aref->[0] IPC::Open3 = $aref->[1]");
+ ok( -t STDIN, "STDIN attached to a tty" );
+
+ for my $cmd ( qq[$^X $Child], qq[$^X $Child | $^X -neprint] ) {
+
+ diag("Please enter some input. It will be echo'd back to you");
+ my $buffer;
+ my $ok = run( command => $cmd, verbose => 1, buffer => \$buffer );
+
+ ok( $ok, " Command '$cmd' ran succesfully" );
+
+ SKIP: {
+ skip "No buffers available", 1 unless $Class->can_capture_buffer;
+ ok( defined $buffer, " Input captured" );
+ }
+ }
+}
+
+### check we didnt leak any FHs
+{ ### should be opened
+ my %open = map { $_ => 1 } @Opened;
+
+ for ( @FDs ) {
+ my $fh;
+ my $rv = open $fh, "<&=$_";
+
+ ### these should be open
+ if( $open{$_} ) {
+ ok( $rv, "FD $_ opened" );
+ ok( $fh, " FH indeed opened" );
+ is( fileno($fh), $_, " Opened at the correct fileno($_)" );
+ } else {
+ ok( !$rv, "FD $_ not opened" );
+ ok( !(fileno($fh)), " FH indeed closed" );
+
+ ### extra debug info if tests fail
+# use Devel::Peek;
+# use Data::Dumper;
+# diag( "RV=$rv FH=$fh Fileno=". fileno($fh). Dump($fh) ) if $rv;
+# diag( Dumper( [stat $fh] ) ) if $rv;
+
+ }
+ }
+}
diff -urN perl-5.10.0/lib/IPC/Cmd/t/src.bbb/output.pl perl-5.10.0/lib/IPC/Cmd/t/src/output.pl
--- perl-5.10.0/lib/IPC/Cmd/t/src.bbb/output.pl 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/IPC/Cmd/t/src/output.pl 2008-07-14 15:33:46.000000000 +0200
@@ -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 $_;
+}
Binary files perl-5.10.0/lib/IPC/Cmd/t/src.bbb/x.tgz and perl-5.10.0/lib/IPC/Cmd/t/src/x.tgz differ
Index: .cvsignore
===================================================================
RCS file: /cvs/pkgs/rpms/perl/devel/.cvsignore,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- .cvsignore 12 Dec 2008 14:37:24 -0000 1.16
+++ .cvsignore 3 Feb 2009 06:46:31 -0000 1.17
@@ -1,2 +1,3 @@
perl-5.10.0.tar.gz
Tar-Archive.tar.gz
+x.tgz
Index: perl.spec
===================================================================
RCS file: /cvs/pkgs/rpms/perl/devel/perl.spec,v
retrieving revision 1.201
retrieving revision 1.202
diff -u -r1.201 -r1.202
--- perl.spec 19 Jan 2009 08:36:43 -0000 1.201
+++ perl.spec 3 Feb 2009 06:46:31 -0000 1.202
@@ -7,7 +7,7 @@
Name: perl
Version: %{perl_version}
-Release: 54%{?dist}
+Release: 55%{?dist}
Epoch: %{perl_epoch}
Summary: Practical Extraction and Report Language
Group: Development/Languages
@@ -17,6 +17,8 @@
Url: http://www.perl.org/
Source0: http://search.cpan.org/CPAN/authors/id/R/RG/RGARCIA/perl-%{perl_version}.tar.gz
Source1: Tar-Archive.tar.gz
+# tgz which help testing module IPC::Cmd
+Source2: x.tgz
Source11: filter-requires.sh
Source12: perl-5.8.0-libnet.cfg
# Specific to Fedora/RHEL
@@ -124,6 +126,7 @@
Patch32: perl-5.10.0-ArchiveTar1.40.patch
Patch33: perl-5.10.0-PerlIO-via-change34025.patch
+Patch34: perl-5.10.0-IPC_Cmd-0.42.patch
BuildRoot: %{_tmppath}/%{name}-%{perl_version}-%{release}-root-%(%{__id_u} -n)
BuildRequires: tcsh, dos2unix, man, groff
@@ -495,8 +498,8 @@
License: GPL+ or Artistic
# Epoch bump for clean upgrade over old standalone package
Epoch: 1
-# Really 0.40_1, but we drop the _1.
-Version: 0.40
+# do not upgrade in the future to _something version. They are testing!
+Version: 0.42
Requires: perl = %{perl_epoch}:%{perl_version}-%{release}
%description IPC-Cmd
@@ -865,6 +868,7 @@
%patch31 -p1
%patch32 -p1
%patch33 -p1
+%patch34 -p1
#
# Candidates for doc recoding (need case by case review):
@@ -1100,6 +1104,7 @@
perl -x patchlevel.h '33897 Replaced the WEXITSTATUS, WIFEXITED, WIFSIGNALED, WIFSTOPPED, WSTOPSIG'
perl -x patchlevel.h 'Fedora Patch32: CVE-2007-4829 Update Archive::Tar to 1.40'
perl -x patchlevel.h '54934 Change 34025 refcount of the globs generated by PerlIO::via balanced'
+perl -x patchlevel.h 'Fedora Patch34: Update to IPC::Cmd 0.42'
%clean
rm -rf $RPM_BUILD_ROOT
@@ -1707,6 +1712,9 @@
# Old changelog entries are preserved in CVS.
%changelog
+* Tue Feb 3 2009 Marcela Mašláňová <mmaslano at redhat.com> - 4:5.10.0-55
+- update IPC::Cmd to v 0.42
+
* Mon Jan 19 2009 Marcela Mašláňová <mmaslano at redhat.com> - 4:5.10.0-54
- 455410 http://rt.perl.org/rt3/Public/Bug/Display.html?id=54934
Attempt to free unreferenced scalar fiddling with the symbol table
Index: sources
===================================================================
RCS file: /cvs/pkgs/rpms/perl/devel/sources,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- sources 12 Dec 2008 14:37:24 -0000 1.16
+++ sources 3 Feb 2009 06:46:31 -0000 1.17
@@ -1,2 +1,3 @@
d2c39b002ebfd2c3c5dba589365c5a71 perl-5.10.0.tar.gz
20fc625176668dd02a8b07ef0acd451d Tar-Archive.tar.gz
+62965ff8dacdd3855fcb801ebe336332 x.tgz
- Previous message: rpms/gnome-games/devel .cvsignore, 1.92, 1.93 gnome-games.spec, 1.196, 1.197 sources, 1.97, 1.98
- Next message: rpms/virtaal/devel .cvsignore, 1.3, 1.4 sources, 1.3, 1.4 virtaal.spec, 1.2, 1.3 virtaal-0.3beta1-version.patch, 1.1, NONE
- Messages sorted by:
[ date ]
[ thread ]
[ subject ]
[ author ]
More information about the scm-commits
mailing list