X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d638aca26c38bab9310e5c2f873f4faf27ece6c7..fa07f620619b7e6ff96ee2044fadd2ca7cc948ff:/t/TEST diff --git a/t/TEST b/t/TEST index a302e66..1329205 100755 --- a/t/TEST +++ b/t/TEST @@ -1,105 +1,313 @@ #!./perl -# Last change: Fri Jan 10 09:57:03 WET 1997 - # This is written in a peculiar style, since we're trying to avoid # most of the constructs we'll be testing for. $| = 1; -if ($#ARGV >= 0 && $ARGV[0] eq '-v') { - $verbose = 1; - shift; +# Let tests know they're running in the perl core. Useful for modules +# which live dual lives on CPAN. +$ENV{PERL_CORE} = 1; + +# remove empty elements due to insertion of empty symbols via "''p1'" syntax +@ARGV = grep($_,@ARGV) if $^O eq 'VMS'; + +# Cheesy version of Getopt::Std. Maybe we should replace it with that. +@argv = (); +if ($#ARGV >= 0) { + 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_utf= 1 if $1 eq 'utf8'; + $byte_compile = 1 if $1 eq 'bytecompile'; + $compile = 1 if $1 eq 'compile'; + if ($1 =~ /^deparse(,.+)?$/) { + $deparse = 1; + $deparse_opts = $1; + } + } } +@ARGV = @argv; chdir 't' if -f 't/TEST'; die "You need to run \"make test\" first to set things up.\n" - unless -e 'perl' or -e 'perl.exe'; + unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; + +if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack + unless (-x 'perl.third') { + unless (-x '../perl.third') { + die "You need to run \"make perl.third first.\n"; + } + else { + print "Symlinking ../perl.third as perl.third...\n"; + die "Failed to symlink: $!\n" + unless symlink("../perl.third", "perl.third"); + die "Symlinked but no executable perl.third: $!\n" + unless -x 'perl.third'; + } + } +} + +# check leakage for embedders +$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; -#$ENV{PERL_DESTRUCT_LEVEL} = '2'; $ENV{EMXSHELL} = 'sh'; # For OS/2 -if ($#ARGV == -1) { - @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); +# Roll your own File::Find! +use TestInit; +use File::Spec; +my $curdir = File::Spec->curdir; +my $updir = File::Spec->updir; + +sub _find_tests { + my($dir) = @_; + opendir DIR, $dir || die "Trouble opening $dir: $!"; + foreach my $f (sort { $a cmp $b } readdir DIR) { + next if $f eq $curdir or $f eq $updir; + + my $fullpath = File::Spec->catfile($dir, $f); + + _find_tests($fullpath) if -d $fullpath; + $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS'; + push @ARGV, $fullpath if $f =~ /\.t$/; + } +} + +sub _quote_args { + my ($args) = @_; + my $argstring = ''; + + foreach (split(/\s+/,$args)) { + # In VMS protect with doublequotes because otherwise + # DCL will lowercase -- unless already doublequoted. + $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; + $argstring .= ' ' . $_; + } + return $argstring; +} + +unless (@ARGV) { + foreach my $dir (qw(base comp cmd run io op uni)) { + _find_tests($dir); + } + _find_tests("lib") unless $core; + my $mani = File::Spec->catfile($updir, "MANIFEST"); + if (open(MANI, $mani)) { + while () { # similar code in t/harness + if (m!^(ext/\S+/?([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { + $t = $1; + if (!$core || $t =~ m!^lib/[a-z]!) + { + $path = File::Spec->catfile($updir, $t); + push @ARGV, $path; + $name{$path} = $t; + } + } + } + close MANI; + } else { + warn "$0: cannot open $mani: $!\n"; + } + unless ($core) { + _find_tests('pod'); + _find_tests('x2p'); + _find_tests('japh') if $torture; + } } -%infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +# Tests known to cause infinite loops for the perlcc tests. +# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +%infinite = (); -_testprogs('perl', @ARGV); -_testprogs('compile', @ARGV) if (-e "../testcompile"); +if ($deparse) { + _testprogs('deparse', '', @ARGV); +} +elsif( $compile || $byte_compile ) { + _testprogs('compile', '', @ARGV) if $compile; + _testprogs('compile', '-B', @ARGV) if $byte_compile; +} +else { + _testprogs('compile', '', @ARGV) if -e "../testcompile"; + _testprogs('perl', '', @ARGV); +} sub _testprogs { $type = shift @_; + $args = shift; @tests = @_; - print <<'EOT' if ($type eq 'compile'); --------------------------------------------------------------------------------- +------------------------------------------------------------------------------ TESTING COMPILER --------------------------------------------------------------------------------- +------------------------------------------------------------------------------ EOT + print <<'EOT' if ($type eq 'deparse'); +------------------------------------------------------------------------------ +TESTING DEPARSER +------------------------------------------------------------------------------ +EOT + + $ENV{PERLCC_TIMEOUT} = 120 + if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); + $bad = 0; $good = 0; $total = @tests; $files = 0; $totmax = 0; + + foreach my $t (@tests) { + unless (exists $name{$t}) { + my $tname = File::Spec->catfile('t',$t); + $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS'; + $name{$t} = $tname; + } + } + my $maxlen = 0; + foreach (@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 ; while ($test = shift @tests) { if ( $infinite{$test} && $type eq 'compile' ) { - print STDERR "$test creates infinite loop! Skipping.\n"; + print STDERR "$test creates infinite loop! Skipping.\n"; next; } if ($test =~ /^$/) { next; } - $te = $test; - chop($te); - print "$te" . '.' x (18 - length($te)); - - open(SCRIPT,"<$test") or die "Can't run $test.\n"; - $_ =