1#!./perl 2 3# This is written in a peculiar style, since we're trying to avoid 4# most of the constructs we'll be testing for. 5 6$| = 1; 7 8# Let tests know they're running in the perl core. Useful for modules 9# which live dual lives on CPAN. 10$ENV{PERL_CORE} = 1; 11 12# remove empty elements due to insertion of empty symbols via "''p1'" syntax 13@ARGV = grep($_,@ARGV) if $^O eq 'VMS'; 14 15# Cheesy version of Getopt::Std. Maybe we should replace it with that. 16@argv = (); 17if ($#ARGV >= 0) { 18 foreach my $idx (0..$#ARGV) { 19 push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/; 20 $core = 1 if $1 eq 'core'; 21 $verbose = 1 if $1 eq 'v'; 22 $torture = 1 if $1 eq 'torture'; 23 $with_utf= 1 if $1 eq 'utf8'; 24 $byte_compile = 1 if $1 eq 'bytecompile'; 25 $compile = 1 if $1 eq 'compile'; 26 if ($1 =~ /^deparse(,.+)?$/) { 27 $deparse = 1; 28 $deparse_opts = $1; 29 } 30 } 31} 32@ARGV = @argv; 33 34chdir 't' if -f 't/TEST'; 35 36die "You need to run \"make test\" first to set things up.\n" 37 unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; 38 39if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack 40 unless (-x 'perl.third') { 41 unless (-x '../perl.third') { 42 die "You need to run \"make perl.third first.\n"; 43 } 44 else { 45 print "Symlinking ../perl.third as perl.third...\n"; 46 die "Failed to symlink: $!\n" 47 unless symlink("../perl.third", "perl.third"); 48 die "Symlinked but no executable perl.third: $!\n" 49 unless -x 'perl.third'; 50 } 51 } 52} 53 54# check leakage for embedders 55$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; 56 57$ENV{EMXSHELL} = 'sh'; # For OS/2 58 59# Roll your own File::Find! 60use TestInit; 61use File::Spec; 62my $curdir = File::Spec->curdir; 63my $updir = File::Spec->updir; 64 65sub _find_tests { 66 my($dir) = @_; 67 opendir DIR, $dir || die "Trouble opening $dir: $!"; 68 foreach my $f (sort { $a cmp $b } readdir DIR) { 69 next if $f eq $curdir or $f eq $updir; 70 71 my $fullpath = File::Spec->catfile($dir, $f); 72 73 _find_tests($fullpath) if -d $fullpath; 74 $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS'; 75 push @ARGV, $fullpath if $f =~ /\.t$/; 76 } 77} 78 79sub _quote_args { 80 my ($args) = @_; 81 my $argstring = ''; 82 83 foreach (split(/\s+/,$args)) { 84 # In VMS protect with doublequotes because otherwise 85 # DCL will lowercase -- unless already doublequoted. 86 $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; 87 $argstring .= ' ' . $_; 88 } 89 return $argstring; 90} 91 92unless (@ARGV) { 93 foreach my $dir (qw(base comp cmd run io op uni)) { 94 _find_tests($dir); 95 } 96 _find_tests("lib") unless $core; 97 my $mani = File::Spec->catfile($updir, "MANIFEST"); 98 if (open(MANI, $mani)) { 99 while (<MANI>) { # similar code in t/harness 100 if (m!^(ext/\S+/?(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { 101 $t = $1; 102 if (!$core || $t =~ m!^lib/[a-z]!) 103 { 104 $path = File::Spec->catfile($updir, $t); 105 push @ARGV, $path; 106 $name{$path} = $t; 107 } 108 } 109 } 110 close MANI; 111 } else { 112 warn "$0: cannot open $mani: $!\n"; 113 } 114 unless ($core) { 115 _find_tests('pod'); 116 _find_tests('x2p'); 117 _find_tests('japh') if $torture; 118 } 119} 120 121# Tests known to cause infinite loops for the perlcc tests. 122# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); 123%infinite = (); 124 125if ($deparse) { 126 _testprogs('deparse', '', @ARGV); 127} 128elsif( $compile || $byte_compile ) { 129 _testprogs('compile', '', @ARGV) if $compile; 130 _testprogs('compile', '-B', @ARGV) if $byte_compile; 131} 132else { 133 _testprogs('compile', '', @ARGV) if -e "../testcompile"; 134 _testprogs('perl', '', @ARGV); 135} 136 137sub _testprogs { 138 $type = shift @_; 139 $args = shift; 140 @tests = @_; 141 142 print <<'EOT' if ($type eq 'compile'); 143------------------------------------------------------------------------------ 144TESTING COMPILER 145------------------------------------------------------------------------------ 146EOT 147 148 print <<'EOT' if ($type eq 'deparse'); 149------------------------------------------------------------------------------ 150TESTING DEPARSER 151------------------------------------------------------------------------------ 152EOT 153 154 $ENV{PERLCC_TIMEOUT} = 120 155 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); 156 157 $bad = 0; 158 $good = 0; 159 $total = @tests; 160 $files = 0; 161 $totmax = 0; 162 163 foreach my $t (@tests) { 164 unless (exists $name{$t}) { 165 my $tname = File::Spec->catfile('t',$t); 166 $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS'; 167 $name{$t} = $tname; 168 } 169 } 170 my $maxlen = 0; 171 foreach (@name{@tests}) { 172 s/\.\w+\z/./; 173 my $len = length ; 174 $maxlen = $len if $len > $maxlen; 175 } 176 # + 3 : we want three dots between the test name and the "ok" 177 $dotdotdot = $maxlen + 3 ; 178 while ($test = shift @tests) { 179 180 if ( $infinite{$test} && $type eq 'compile' ) { 181 print STDERR "$test creates infinite loop! Skipping.\n"; 182 next; 183 } 184 if ($test =~ /^$/) { 185 next; 186 } 187 if ($type eq 'deparse') { 188 if ($test eq "comp/redef.t") { 189 # Redefinition happens at compile time 190 next; 191 } 192 elsif ($test eq "lib/switch.t") { 193 # B::Deparse doesn't support source filtering 194 next; 195 } 196 } 197 $te = $name{$test} . '.' x ($dotdotdot - length($name{$test})); 198 199 if ($^O ne 'VMS') { # defer printing on VMS due to piping bug 200 print $te; 201 $te = ''; 202 } 203 204 $test = $OVER{$test} if exists $OVER{$test}; 205 206 open(SCRIPT,"<$test") or die "Can't run $test.\n"; 207 $_ = <SCRIPT>; 208 close(SCRIPT) unless ($type eq 'deparse'); 209 if (/#!.*\bperl.*\s-\w*([tT])/) { 210 $switch = qq{"-$1"}; 211 } 212 else { 213 $switch = ''; 214 } 215 216 my $test_executable; # for 'compile' tests 217 my $file_opts = ""; 218 if ($type eq 'deparse') { 219 # Look for #line directives which change the filename 220 while (<SCRIPT>) { 221 $file_opts .= ",-f$3$4" 222 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; 223 } 224 close(SCRIPT); 225 } 226 227 my $utf = $with_utf ? '-I../lib -Mutf8' : ''; 228 my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC 229 if ($type eq 'deparse') { 230 my $deparse = 231 "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,". 232 "-l$deparse_opts$file_opts ". 233 "$test > $test.dp ". 234 "&& ./perl $testswitch $switch -I../lib $test.dp |"; 235 open(RESULTS, $deparse) 236 or print "can't deparse '$deparse': $!.\n"; 237 } 238 elsif ($type eq 'perl') { 239 my $perl = $ENV{PERL} || './perl'; 240 my $redir = ($^O eq 'VMS' ? '2>&1' : ''); 241 my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|"; 242 open(RESULTS,$run) or print "can't run '$run': $!.\n"; 243 } 244 else { 245 my $compile; 246 my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " . 247 # -O9 for good measure, -fcog is broken ATM 248 "$switch -Wb=-O9,-fno-cog -L .. " . 249 "-I \".. ../lib/CORE\" $args $utf $test -o "; 250 251 if( $^O eq 'MSWin32' ) { 252 $test_executable = "$test.exe"; 253 # hopefully unused name... 254 open HACK, "> xweghyz.pl"; 255 print HACK <<EOT; 256#!./perl 257 258open HACK, '.\\perl $pl2c $test_executable |'; 259# cl.exe prints the name of the .c file on stdout (\%^\$^#) 260while(<HACK>) {m/^\\w+\\.[cC]\$/ && next;print} 261open HACK, '$test_executable |'; 262while(<HACK>) {print} 263EOT 264 close HACK; 265 $compile = 'xweghyz.pl |'; 266 } 267 else { 268 $test_executable = "$test.plc"; 269 $compile = "./perl $pl2c $test_executable && $test_executable |"; 270 } 271 unlink $test_executable if -f $test_executable; 272 open(RESULTS, $compile) 273 or print "can't compile '$compile': $!.\n"; 274 } 275 276 $ok = 0; 277 $next = 0; 278 while (<RESULTS>) { 279 next if /^\s*$/; # skip blank lines 280 if ($verbose) { 281 print $_; 282 } 283 unless (/^#/) { 284 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { 285 $max = $1; 286 %todo = map { $_ => 1 } split / /, $3 if $3; 287 $totmax += $max; 288 $files += 1; 289 $next = 1; 290 $ok = 1; 291 } 292 else { 293 if (/^(not )?ok (\d+)[^#]*(\s*#.*)?/ && 294 $2 == $next) 295 { 296 my($not, $num, $extra) = ($1, $2, $3); 297 my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra; 298 $istodo = 1 if $todo{$num}; 299 300 if( $not && !$istodo ) { 301 $ok = 0; 302 $next = $num; 303 last; 304 } 305 else { 306 $next = $next + 1; 307 } 308 } 309 elsif (/^Bail out!\s*(.*)/i) { # magic words 310 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); 311 } 312 else { 313 $ok = 0; 314 } 315 } 316 } 317 } 318 close RESULTS; 319 if ($type eq 'deparse') { 320 unlink "./$test.dp"; 321 } 322 if ($ENV{PERL_3LOG}) { 323 my $tpp = $test; 324 $tpp =~ s:^\.\./::; 325 $tpp =~ s:/:_:g; 326 $tpp =~ s:\.t$:.3log:; 327 rename("perl.3log", $tpp) || 328 die "rename: perl3.log to $tpp: $!\n"; 329 } 330 $next = $next - 1; 331 # test if the compiler compiled something 332 if( $type eq 'compile' && !-e "$test_executable" ) { 333 $ok = 0; 334 print "Test did not compile\n"; 335 } 336 if ($ok && $next == $max ) { 337 if ($max) { 338 print "${te}ok\n"; 339 $good = $good + 1; 340 } 341 else { 342 print "${te}skipping test on this platform\n"; 343 $files -= 1; 344 } 345 } 346 else { 347 $next += 1; 348 print "${te}FAILED at test $next\n"; 349 $bad = $bad + 1; 350 $_ = $test; 351 if (/^base/) { 352 die "Failed a basic test--cannot continue.\n"; 353 } 354 } 355 } 356 357 if ($bad == 0) { 358 if ($ok) { 359 print "All tests successful.\n"; 360 # XXX add mention of 'perlbug -ok' ? 361 } 362 else { 363 die "FAILED--no tests were run for some reason.\n"; 364 } 365 } 366 else { 367 $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00"; 368 if ($bad == 1) { 369 warn "Failed 1 test script out of $files, $pct% okay.\n"; 370 } 371 else { 372 warn "Failed $bad test scripts out of $files, $pct% okay.\n"; 373 } 374 warn <<'SHRDLU_1'; 375### Since not all tests were successful, you may want to run some of 376### them individually and examine any diagnostic messages they produce. 377### See the INSTALL document's section on "make test". 378SHRDLU_1 379 warn <<'SHRDLU_2' if $good / $total > 0.8; 380### You have a good chance to get more information by running 381### ./perl harness 382### in the 't' directory since most (>=80%) of the tests succeeded. 383SHRDLU_2 384 if (eval {require Config; import Config; 1}) { 385 if ($Config{usedl} && (my $p = $Config{ldlibpthname})) { 386 warn <<SHRDLU_3; 387### You may have to set your dynamic library search path, 388### $p, to point to the build directory: 389SHRDLU_3 390 if (exists $ENV{$p} && $ENV{$p} ne '') { 391 warn <<SHRDLU_4a; 392### setenv $p `pwd`:\$$p; cd t; ./perl harness 393### $p=`pwd`:\$$p; export $p; cd t; ./perl harness 394### export $p=`pwd`:\$$p; cd t; ./perl harness 395SHRDLU_4a 396 } else { 397 warn <<SHRDLU_4b; 398### setenv $p `pwd`; cd t; ./perl harness 399### $p=`pwd`; export $p; cd t; ./perl harness 400### export $p=`pwd`; cd t; ./perl harness 401SHRDLU_4b 402 } 403 warn <<SHRDLU_5; 404### for csh-style shells, like tcsh; or for traditional/modern 405### Bourne-style shells, like bash, ksh, and zsh, respectively. 406SHRDLU_5 407 } 408 } 409 } 410 ($user,$sys,$cuser,$csys) = times; 411 print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", 412 $user,$sys,$cuser,$csys,$files,$totmax); 413} 414exit ($bad != 0); 415