From: Dave Mitchell Date: Wed, 4 May 2005 22:14:54 +0000 (+0000) Subject: strictify t/TEST X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=80ed0dea934fa8bbf41a6adb409c09ec7a4f3580;p=p5sagit%2Fp5-mst-13.2.git strictify t/TEST make most variables lexical, narrow their scope, and give some of them more meaningful names. Also fix a harmless bug where the wrong filehandles are closed (A+B rather than U+A) p4raw-id: //depot/perl@24389 --- diff --git a/t/TEST b/t/TEST index d60b4f6..7dd688d 100755 --- a/t/TEST +++ b/t/TEST @@ -7,6 +7,10 @@ $| = 1; +# for testing TEST only +#BEGIN { require '../lib/strict.pm'; strict->import() }; +#BEGIN { require '../lib/warnings.pm'; warnings->import() }; + # Let tests know they're running in the perl core. Useful for modules # which live dual lives on CPAN. $ENV{PERL_CORE} = 1; @@ -15,26 +19,26 @@ $ENV{PERL_CORE} = 1; @ARGV = grep($_,@ARGV) if $^O eq 'VMS'; # Cheesy version of Getopt::Std. Maybe we should replace it with that. -@argv = (); -if ($#ARGV >= 0) { +{ + my @argv = (); foreach my $idx (0..$#ARGV) { push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/; - $core = 1 if $1 eq 'core'; - $verbose = 1 if $1 eq 'v'; - $torture = 1 if $1 eq 'torture'; - $with_utf8 = 1 if $1 eq 'utf8'; - $with_utf16 = 1 if $1 eq 'utf16'; - $bytecompile = 1 if $1 eq 'bytecompile'; - $compile = 1 if $1 eq 'compile'; - $taintwarn = 1 if $1 eq 'taintwarn'; + $::core = 1 if $1 eq 'core'; + $::verbose = 1 if $1 eq 'v'; + $::torture = 1 if $1 eq 'torture'; + $::with_utf8 = 1 if $1 eq 'utf8'; + $::with_utf16 = 1 if $1 eq 'utf16'; + $::bytecompile = 1 if $1 eq 'bytecompile'; + $::compile = 1 if $1 eq 'compile'; + $::taintwarn = 1 if $1 eq 'taintwarn'; $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; if ($1 =~ /^deparse(,.+)?$/) { - $deparse = 1; - $deparse_opts = $1; + $::deparse = 1; + $::deparse_opts = $1; } } + @ARGV = @argv; } -@ARGV = @argv; chdir 't' if -f 't/TEST'; @@ -103,7 +107,7 @@ unless (@ARGV) { foreach my $dir (qw(base comp cmd run io op uni)) { _find_tests($dir); } - _find_tests("lib") unless $core; + _find_tests("lib") unless $::core; # Config.pm may be broken for make minitest. And this is only a refinement # for skipping tests on non-default builds, so it is allowed to fail. # What we want to to is make a list of extensions which we did not build. @@ -138,18 +142,18 @@ unless (@ARGV) { if (open(MANI, $mani)) { while () { # similar code in t/harness if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { - $t = $1; - $extension = $2; - if (!$core || $t =~ m!^lib/[a-z]!) + my $t = $1; + my $extension = $2; + if (!$::core || $t =~ m!^lib/[a-z]!) { if (defined $extension) { $extension =~ s!/t$!!; # XXX Do I want to warn that I'm skipping these? next if $skip{$extension}; } - $path = File::Spec->catfile($updir, $t); + my $path = File::Spec->catfile($updir, $t); push @ARGV, $path; - $name{$path} = $t; + $::path_to_name{$path} = $t; } } } @@ -157,27 +161,27 @@ unless (@ARGV) { } else { warn "$0: cannot open $mani: $!\n"; } - unless ($core) { + unless ($::core) { _find_tests('pod'); _find_tests('x2p'); - _find_tests('japh') if $torture; + _find_tests('japh') if $::torture; } } # Tests known to cause infinite loops for the perlcc tests. -# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); -%infinite = (); +# %::infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +%::infinite = (); -if ($deparse) { +if ($::deparse) { _testprogs('deparse', '', @ARGV); } -elsif( $compile ) { +elsif( $::compile ) { _testprogs('compile', '', @ARGV); } -elsif( $bytecompile ) { +elsif( $::bytecompile ) { _testprogs('bytecompile', '', @ARGV); } -elsif ($with_utf16) { +elsif ($::with_utf16) { for my $e (0, 1) { for my $b (0, 1) { print STDERR "# ENDIAN $e BOM $b\n"; @@ -193,9 +197,9 @@ elsif ($with_utf16) { while () { print U pack("$f*", unpack("C*", $_)); } - close(A); + close(U); } - close(B); + close(A); } } _testprogs('perl', '', @UARGV); @@ -209,9 +213,7 @@ else { } sub _testprogs { - $type = shift @_; - $args = shift; - @tests = @_; + my ($type, $args, @tests) = @_; print <<'EOT' if ($type eq 'compile'); ------------------------------------------------------------------------------ @@ -234,32 +236,35 @@ EOT $ENV{PERLCC_TIMEOUT} = 120 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); - $bad = 0; - $good = 0; - $total = @tests; - $files = 0; - $totmax = 0; + $::bad_files = 0; foreach my $t (@tests) { - unless (exists $name{$t}) { + unless (exists $::path_to_name{$t}) { my $tname = File::Spec->catfile('t',$t); $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS'; - $name{$t} = $tname; + $::path_to_name{$t} = $tname; } } my $maxlen = 0; - foreach (@name{@tests}) { + foreach (@::path_to_name{@tests}) { s/\.\w+\z/./; my $len = length ; $maxlen = $len if $len > $maxlen; } # + 3 : we want three dots between the test name and the "ok" - $dotdotdot = $maxlen + 3 ; + my $dotdotdot = $maxlen + 3 ; my $valgrind = 0; my $valgrind_log = 'current.valgrind'; + my $total_files = @tests; + my $good_files = 0; + my $tested_files = 0; + my $totmax = 0; + my $ok; + + my $test; while ($test = shift @tests) { - if ( $infinite{$test} && $type eq 'compile' ) { + if ( $::infinite{$test} && $type eq 'compile' ) { print STDERR "$test creates infinite loop! Skipping.\n"; next; } @@ -276,26 +281,29 @@ EOT next; } } - $te = $name{$test} . '.' x ($dotdotdot - length($name{$test})); + my $te = $::path_to_name{$test} . '.' + x ($dotdotdot - length($::path_to_name{$test})); if ($^O ne 'VMS') { # defer printing on VMS due to piping bug print $te; $te = ''; } - $test = $OVER{$test} if exists $OVER{$test}; + # XXX DAPM %OVER not defined anywhere + # $test = $OVER{$test} if exists $OVER{$test}; open(SCRIPT,"<$test") or die "Can't run $test.\n"; $_ =