Author: jrieks
Date: Fri Apr 15 01:39:07 2005
New Revision: 7836
Modified:
trunk/languages/parrot_compiler/lib/Parrot/Test/ParrotCompiler.pm
trunk/lib/Parrot/Test.pm
trunk/lib/Parrot/Test/Python.pm
trunk/lib/Parrot/Test/Tcl.pm
trunk/lib/Parrot/Test/m4.pm
trunk/t/library/pcre.t
Log:
[perl #34978] lib/Parrot/Test.pm should not use "&&" in commands
The cross-platform version of
system("cd $dir && command");
is
my($dir, @command) = @_;
my $orig_dir = cwd;
chdir $dir;
my $ret = system(@command);
chdir $orig_dir;
return $ret;
which I have added to Parrot::Test::_run_command() and made it publicly
available. Lots of code was using it already anyway.
Also languages/m4/M4/Test.pm, languages/perl6/P6C/TestCompiler.pm,
languages/scheme/Scheme/Test.pm, lib/Parrot/Configure/Step.pm, have their
own probably duplicate _run_commands() which should probably be eliminated
but I'm not going to do in this patch.
I've also left the "cd dir && foo" idiom used in documentation alone,
though again this should probably be changed.
Finally I haven't fixed the m4 tests as they're just straight `` not going
through run_command() and require a bit more time to fix than I have at the
moment.
Courtesy of Michael G Schwern <[EMAIL PROTECTED]>
Modified: trunk/languages/parrot_compiler/lib/Parrot/Test/ParrotCompiler.pm
==============================================================================
--- trunk/languages/parrot_compiler/lib/Parrot/Test/ParrotCompiler.pm
(original)
+++ trunk/languages/parrot_compiler/lib/Parrot/Test/ParrotCompiler.pm Fri Apr
15 01:39:07 2005
@@ -47,14 +47,17 @@
my $out_f = Parrot::Test::per_test( '.out', $test_no );
my $test_prog_args = $ENV{TEST_PROG_ARGS} || '';
- my $cmd = "(cd $self->{relpath} && $self->{parrot}
languages/parrot_compiler/$test_prog_args < languages/$code_f)";
+ my $cmd = "$self->{parrot} languages/parrot_compiler/$test_prog_args <
languages/$code_f";
my $parrotdir = File::Basename::dirname( $self->{parrot} );
Parrot::Test::generate_code( $code, $parrotdir, $test_no, $code_f );
# STDERR is written into same output file
my $diag = '';
- my $parrot_exit_code = Parrot::Test::_run_command( $cmd, STDOUT => $out_f,
STDERR => $out_f );
+ my $parrot_exit_code = Parrot::Test::run_command( $cmd,
+ CD => $self->{relpath},
+ STDOUT => $out_f,
+ STDERR => $out_f );
$diag .= "'$cmd' failed with exit code $parrot_exit_code." if
$parrot_exit_code;
$self->{builder}->diag( $diag ) if $diag;
Modified: trunk/lib/Parrot/Test.pm
==============================================================================
--- trunk/lib/Parrot/Test.pm (original)
+++ trunk/lib/Parrot/Test.pm Fri Apr 15 01:39:07 2005
@@ -125,6 +125,22 @@
Use within a C<SKIP: { ... }> block to indicate why and how many test
are being skipped. Just like in Test::More.
+=item C<run_command($command, %options)>
+
+Run the given $command in a cross-platform manner.
+
+%options include...
+
+ STDOUT filehandle to redirect STDOUT to
+ STDERR filehandle to redirect STDERR to
+ CD directory to run the command in
+
+For example:
+
+ # equivalent to "cd some_dir && make test"
+ run_command("make test", CD => "some_dir");
+
+
=back
=cut
@@ -136,6 +152,7 @@
use Parrot::Config;
use File::Spec;
use Data::Dumper;
+use Cwd;
require Exporter;
require Test::Builder;
@@ -149,7 +166,9 @@
pir_2_pasm_is pir_2_pasm_like pir_2_pasm_isnt
c_output_is c_output_like c_output_isnt
language_output_is
- skip );
+ skip
+ run_command
+ );
@ISA = qw(Exporter);
# tell parrot it's being tested. this disables searching of installed
libraries
@@ -170,9 +189,12 @@
# this kludge is an hopefully portable way of having
# redirections ( tested on Linux and Win2k )
# An alternative is using Test::Output
-sub _run_command {
+sub run_command {
my($command, %redir) = @_;
+ # To run the command in a different directory.
+ my $chdir = delete $redir{CD};
+
foreach (keys %redir) {
m/^STD(OUT|ERR)$/ or die "I don't know how to redirect '$_' yet! ";
}
@@ -198,8 +220,18 @@
open STDERR, ">$err" or die "Can't redirect stderr" if $err;
$command = "$ENV{VALGRIND} $command" if defined $ENV{VALGRIND};
+
+ my $orig_dir;
+ if( $chdir ) {
+ $orig_dir = cwd;
+ chdir $chdir;
+ }
system( $command );
+ if( $chdir ) {
+ chdir $orig_dir;
+ }
+
my $exit_code = $? >> 8;
close STDOUT or die "Can't close stdout" if $out;
@@ -319,16 +351,19 @@
if ( $args =~ s/--run-exec// ) {
$run_exec = 1;
my $pbc_f = per_test('.pbc', $test_no);
- my $cmd = qq{(cd $path_to_parrot && $parrot ${args} -o $pbc_f
"$code_f")};
- _run_command($cmd, STDOUT => $out_f, STDERR => $out_f);
+ my $cmd = qq{$parrot ${args} -o $pbc_f "$code_f"};
+ run_command($cmd, CD => $path_to_parrot,
+ STDOUT => $out_f, STDERR => $out_f);
my $o_f = per_test('.o', $test_no);
- $cmd = qq{(cd $path_to_parrot && $parrot ${args} -o $o_f
"$pbc_f")};
- _run_command($cmd, STDOUT => $out_f, STDERR => $out_f);
+ $cmd = qq{$parrot ${args} -o $o_f "$pbc_f"};
+ run_command($cmd, CD => $path_to_parrot,
+ STDOUT => $out_f, STDERR => $out_f);
my $noext_f = per_test('', $test_no);
- $cmd = qq{(cd $path_to_parrot && make EXEC=$noext_f exec)};
- _run_command($cmd, STDOUT => $out_f, STDERR => $out_f);
+ $cmd = qq{make EXEC=$noext_f exec};
+ run_command($cmd, CD => $path_to_parrot,
+ STDOUT => $out_f, STDERR => $out_f);
}
if ( $func =~ /^pbc_output_/ && $args =~ /-r / ) {
# native tests with --run-pbc don't make sense
@@ -353,8 +388,9 @@
my $pbc_f = per_test('.pbc', $test_no);
$args = qq{$args -o "$pbc_f" -r -r};
}
- $cmd = qq{(cd $path_to_parrot && $parrot $args "$code_f")};
- $exit_code = _run_command($cmd, STDOUT => $out_f, STDERR =>
$out_f);
+ $cmd = qq{$parrot $args "$code_f"};
+ $exit_code = run_command($cmd, CD => $path_to_parrot,
+ STDOUT => $out_f, STDERR => $out_f);
}
my $meth = $parrot_test_map{$func};
@@ -466,7 +502,7 @@
$cmd = "$PConfig{cc} $PConfig{ccflags} $PConfig{cc_debug} " .
" -I./include -c " .
"$PConfig{cc_o_out}$obj_f $source_f";
- $exit_code = _run_command($cmd,
+ $exit_code = run_command($cmd,
'STDOUT' => $build_f,
'STDERR' => $build_f);
$builder->diag("'$cmd' failed with exit code $exit_code")
@@ -483,7 +519,7 @@
$cmd = "$PConfig{link} $PConfig{linkflags} $PConfig{ld_debug} " .
"$obj_f $PConfig{ld_out}$exe_f " .
"$libparrot $iculibs $PConfig{libs}";
- $exit_code = _run_command($cmd,
+ $exit_code = run_command($cmd,
'STDOUT' => $build_f,
'STDERR' => $build_f);
$builder->diag("'$cmd' failed with exit code $exit_code")
@@ -499,7 +535,7 @@
}
$cmd = ".$PConfig{slash}$exe_f";
- $exit_code = _run_command($cmd, 'STDOUT' => $out_f, 'STDERR' =>
$out_f);
+ $exit_code = run_command($cmd, 'STDOUT' => $out_f, 'STDERR' =>
$out_f);
my $meth = $c_test_map{$func};
my $pass = $builder->$meth(slurp_file($out_f), $expected, $desc);
Modified: trunk/lib/Parrot/Test/Python.pm
==============================================================================
--- trunk/lib/Parrot/Test/Python.pm (original)
+++ trunk/lib/Parrot/Test/Python.pm Fri Apr 15 01:39:07 2005
@@ -45,11 +45,11 @@
# For some reason, if you redirect both STDERR and STDOUT here,
# you get a 38M file of garbage. We'll temporarily assume everything
# works and ignore stderr.
- $exit_code = Parrot::Test::_run_command($pycmd, STDOUT => $py_out_f);
+ $exit_code = Parrot::Test::run_command($pycmd, STDOUT => $py_out_f);
my $py_file = Parrot::Test::slurp_file($py_out_f);
my $pirate_file;
- $exit_code |= Parrot::Test::_run_command($cmd,
+ $exit_code |= Parrot::Test::run_command($cmd,
STDOUT => $pirate_out_f);
$pirate_file = Parrot::Test::slurp_file($pirate_out_f);
$pass = $self->{builder}->is_eq( $pirate_file, $py_file, $desc );
Modified: trunk/lib/Parrot/Test/Tcl.pm
==============================================================================
--- trunk/lib/Parrot/Test/Tcl.pm (original)
+++ trunk/lib/Parrot/Test/Tcl.pm Fri Apr 15 01:39:07 2005
@@ -42,12 +42,13 @@
my $exit_code = 0;
my $pass = 0;
- $cmd = "(cd " . $self->{relpath} . " && " . $self->{parrot} . " ${args}
languages/tcl/tcl.pbc $lang_f)";
+ $cmd = "$self->{parrot} $args languages/tcl/tcl.pbc $lang_f";
# For some reason, if you redirect both STDERR and STDOUT here,
# you get a 38M file of garbage. We'll temporarily assume everything
# works and ignore stderr.
- $exit_code = Parrot::Test::_run_command($cmd, STDOUT => $out_f);
+ $exit_code = Parrot::Test::run_command($cmd, CD => $self->{relpath},
+ STDOUT => $out_f);
unless ($pass) {
my $file = Parrot::Test::slurp_file($out_f);
Modified: trunk/lib/Parrot/Test/m4.pm
==============================================================================
--- trunk/lib/Parrot/Test/m4.pm (original)
+++ trunk/lib/Parrot/Test/m4.pm Fri Apr 15 01:39:07 2005
@@ -2,10 +2,11 @@
use strict;
-use Data::Dumper;
+package Parrot::Test::m4;
+
+require Parrot::Test;
use File::Basename;
-package Parrot::Test::m4;
=head1 NAME
@@ -48,16 +49,24 @@
my $gnu_m4_out_f = Parrot::Test::per_test( '.gnu_out', $count );
my $test_prog_args = $ENV{TEST_PROG_ARGS} || '';
- my $parrot_m4 = "(cd $self->{relpath} && $self->{parrot}
languages/m4/m4.pbc ${test_prog_args} languages/${lang_f})";
- my $gnu_m4 = "(cd $self->{relpath} && m4 ${test_prog_args}
languages/${lang_f})";
+ my $parrot_m4 = "$self->{parrot} languages/m4/m4.pbc ${test_prog_args}
languages/${lang_f}";
+ my $gnu_m4 = "m4 ${test_prog_args} languages/${lang_f}";
# This does nor create byte code, but m4 code
- my $parrotdir = File::Basename::dirname( $self->{parrot} );
+ my $parrotdir = dirname( $self->{parrot} );
Parrot::Test::generate_code( $code, $parrotdir, $count, $lang_f );
# STDERR is written into same output file
- my $parrot_exit_code = Parrot::Test::_run_command( $parrot_m4, STDOUT =>
$parrot_m4_out_f, STDERR => $parrot_m4_out_f );
- my $gnu_exit_code = Parrot::Test::_run_command( $gnu_m4, STDOUT =>
$gnu_m4_out_f, STDERR => $gnu_m4_out_f );
+ my $parrot_exit_code = Parrot::Test::run_command(
+ $parrot_m4,
+ CD => $self->{relpath},
+ STDOUT => $parrot_m4_out_f, STDERR => $parrot_m4_out_f
+ );
+ my $gnu_exit_code = Parrot::Test::run_command(
+ $gnu_m4,
+ CD => $self->{relpath},
+ STDOUT => $gnu_m4_out_f, STDERR => $gnu_m4_out_f
+ );
my $pass = $self->{builder}->is_eq(
Parrot::Test::slurp_file($parrot_m4_out_f) .
Parrot::Test::slurp_file($gnu_m4_out_f),
$output . $output,
Modified: trunk/t/library/pcre.t
==============================================================================
--- trunk/t/library/pcre.t (original)
+++ trunk/t/library/pcre.t Fri Apr 15 01:39:07 2005
@@ -22,7 +22,7 @@
use Parrot::Test tests => 1;
# if we keep pcre, we need a config test
-my $has_pcre = Parrot::Test::_run_command("pcre-config --version",
+my $has_pcre = Parrot::Test::run_command("pcre-config --version",
STDERR => '/dev/null') == 0;
SKIP: {
