diff --git a/.cvsignore b/.cvsignore index 9e8351f..28c65b7 100644 --- a/.cvsignore +++ b/.cvsignore @@ -1,2 +1,3 @@ perl-5.10.0.tar.gz Tar-Archive.tar.gz +x.tgz diff --git a/perl-5.10.0-IPC_Cmd-0.42.patch b/perl-5.10.0-IPC_Cmd-0.42.patch new file mode 100644 index 0000000..76089e8 --- /dev/null +++ b/perl-5.10.0-IPC_Cmd-0.42.patch @@ -0,0 +1,1469 @@ +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 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 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 takes 3 arguments: ++C 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 call. If the timeout is triggered, the ++C in the return value will be set to an object of the ++C class. See the C section below for ++details. ++ ++Defaults to C<0>, meaning no timeout is set. ++ + =back + + C will return a simple C or C 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 for details on ++what they can contain. ++If the error was a timeout, the C will be prefixed with ++the string C, 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 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 is treated as a string, rather than two ++seperate arguments to the C 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 or C, if you provide a string as the ++C argument, it is assumed to be appropriately escaped. You can ++use the C constant to use as a portable quote character (see above). ++However, if you provide and C, special rules apply: ++ ++If your command contains C (< > | &), 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 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, if you provide a string as the C 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 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 diff --git a/perl.spec b/perl.spec index 08d278d..f12e1de 100644 --- a/perl.spec +++ b/perl.spec @@ -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 @@ License: (GPL+ or Artistic) and (GPLv2+ or Artistic) 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 @@ Patch31: perl-5.10.0-Change33897.patch 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 @@ Group: Development/Libraries 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 @@ upstream tarball from perl.org. %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 '33896 Eliminate POSIX::int_macro_int, and all the complex 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 @@ make test # Old changelog entries are preserved in CVS. %changelog +* Tue Feb 3 2009 Marcela Mašláňová - 4:5.10.0-55 +- update IPC::Cmd to v 0.42 + * Mon Jan 19 2009 Marcela Mašláňová - 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 diff --git a/sources b/sources index 505a500..d392520 100644 --- a/sources +++ b/sources @@ -1,2 +1,3 @@ d2c39b002ebfd2c3c5dba589365c5a71 perl-5.10.0.tar.gz 20fc625176668dd02a8b07ef0acd451d Tar-Archive.tar.gz +62965ff8dacdd3855fcb801ebe336332 x.tgz