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. (This comment is 5# probably obsolete on the avoidance side, though still currrent 6# on the peculiarity side.) 7 8$| = 1; 9 10# for testing TEST only 11#BEGIN { require '../lib/strict.pm'; strict->import() }; 12#BEGIN { require '../lib/warnings.pm'; warnings->import() }; 13 14# Let tests know they're running in the perl core. Useful for modules 15# which live dual lives on CPAN. 16$ENV{PERL_CORE} = 1; 17 18# remove empty elements due to insertion of empty symbols via "''p1'" syntax 19@ARGV = grep($_,@ARGV) if $^O eq 'VMS'; 20our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; 21 22# Cheesy version of Getopt::Std. Maybe we should replace it with that. 23{ 24 my @argv = (); 25 foreach my $idx (0..$#ARGV) { 26 push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/; 27 $::core = 1 if $1 eq 'core'; 28 $::verbose = 1 if $1 eq 'v'; 29 $::torture = 1 if $1 eq 'torture'; 30 $::with_utf8 = 1 if $1 eq 'utf8'; 31 $::with_utf16 = 1 if $1 eq 'utf16'; 32 $::taintwarn = 1 if $1 eq 'taintwarn'; 33 $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; 34 if ($1 =~ /^deparse(,.+)?$/) { 35 $::deparse = 1; 36 $::deparse_opts = $1; 37 } 38 } 39 @ARGV = @argv; 40} 41 42chdir 't' if -f 't/TEST'; 43 44die "You need to run \"make test\" first to set things up.\n" 45 unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; 46 47if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack 48 unless (-x 'perl.third') { 49 unless (-x '../perl.third') { 50 die "You need to run \"make perl.third first.\n"; 51 } 52 else { 53 print "Symlinking ../perl.third as perl.third...\n"; 54 die "Failed to symlink: $!\n" 55 unless symlink("../perl.third", "perl.third"); 56 die "Symlinked but no executable perl.third: $!\n" 57 unless -x 'perl.third'; 58 } 59 } 60} 61 62# check leakage for embedders 63$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; 64 65$ENV{EMXSHELL} = 'sh'; # For OS/2 66 67# Roll your own File::Find! 68use TestInit; 69use File::Spec; 70if ($show_elapsed_time) { require Time::HiRes } 71my $curdir = File::Spec->curdir; 72my $updir = File::Spec->updir; 73 74sub _find_tests { 75 my($dir) = @_; 76 opendir DIR, $dir or die "Trouble opening $dir: $!"; 77 foreach my $f (sort { $a cmp $b } readdir DIR) { 78 next if $f eq $curdir or $f eq $updir or 79 $f =~ /^(?:CVS|RCS|SCCS|\.svn)$/; 80 81 my $fullpath = File::Spec->catfile($dir, $f); 82 83 _find_tests($fullpath) if -d $fullpath; 84 $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS'; 85 push @ARGV, $fullpath if $f =~ /\.t$/; 86 } 87} 88 89sub _quote_args { 90 my ($args) = @_; 91 my $argstring = ''; 92 93 foreach (split(/\s+/,$args)) { 94 # In VMS protect with doublequotes because otherwise 95 # DCL will lowercase -- unless already doublequoted. 96 $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; 97 $argstring .= ' ' . $_; 98 } 99 return $argstring; 100} 101 102sub _populate_hash { 103 return map {$_, 1} split /\s+/, $_[0]; 104} 105 106unless (@ARGV) { 107 foreach my $dir (qw(base comp cmd run io op uni mro)) { 108 _find_tests($dir); 109 } 110 _find_tests("lib") unless $::core; 111 # Config.pm may be broken for make minitest. And this is only a refinement 112 # for skipping tests on non-default builds, so it is allowed to fail. 113 # What we want to to is make a list of extensions which we did not build. 114 my $configsh = File::Spec->catfile($updir, "config.sh"); 115 my %skip; 116 if (-f $configsh) { 117 my (%extensions, %known_extensions); 118 open FH, $configsh or die "Can't open $configsh: $!"; 119 while (<FH>) { 120 if (/^extensions=['"](.*)['"]$/) { 121 # Deliberate string interpolation to avoid triggering possible 122 # $1 resetting bugs. 123 %extensions = _populate_hash ("$1"); 124 } 125 elsif (/^known_extensions=['"](.*)['"]$/) { 126 %known_extensions = _populate_hash ($1); 127 } 128 } 129 if (%extensions) { 130 if (%known_extensions) { 131 foreach (keys %known_extensions) { 132 $skip{$_}++ unless $extensions{$_}; 133 } 134 } else { 135 warn "No known_extensions line found in $configsh"; 136 } 137 } else { 138 warn "No extensions line found in $configsh"; 139 } 140 } 141 my $mani = File::Spec->catfile($updir, "MANIFEST"); 142 if (open(MANI, $mani)) { 143 my $ext_pat = $^O eq 'MSWin32' ? '(?:win32/)?ext' : 'ext'; 144 while (<MANI>) { # similar code in t/harness 145 if (m!^($ext_pat/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { 146 my $t = $1; 147 my $extension = $2; 148 if (!$::core || $t =~ m!^lib/[a-z]!) 149 { 150 if (defined $extension) { 151 $extension =~ s!/t$!!; 152 # XXX Do I want to warn that I'm skipping these? 153 next if $skip{$extension}; 154 } 155 my $path = File::Spec->catfile($updir, $t); 156 push @ARGV, $path; 157 $::path_to_name{$path} = $t; 158 } 159 } 160 } 161 close MANI; 162 } else { 163 warn "$0: cannot open $mani: $!\n"; 164 } 165 unless ($::core) { 166 _find_tests('Module_Pluggable'); 167 _find_tests('pod'); 168 _find_tests('x2p'); 169 _find_tests('japh') if $::torture; 170 } 171} 172 173if ($::deparse) { 174 _testprogs('deparse', '', @ARGV); 175} 176elsif ($::with_utf16) { 177 for my $e (0, 1) { 178 for my $b (0, 1) { 179 print STDERR "# ENDIAN $e BOM $b\n"; 180 my @UARGV; 181 for my $a (@ARGV) { 182 my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : ""); 183 my $f = $e ? "v" : "n"; 184 push @UARGV, $u; 185 unlink($u); 186 if (open(A, $a)) { 187 if (open(U, ">$u")) { 188 print U pack("$f", 0xFEFF) if $b; 189 while (<A>) { 190 print U pack("$f*", unpack("C*", $_)); 191 } 192 close(U); 193 } 194 close(A); 195 } 196 } 197 _testprogs('perl', '', @UARGV); 198 unlink(@UARGV); 199 } 200 } 201} 202else { 203 _testprogs('perl', '', @ARGV); 204} 205 206sub _testprogs { 207 my ($type, $args, @tests) = @_; 208 209 print <<'EOT' if ($type eq 'deparse'); 210------------------------------------------------------------------------------ 211TESTING DEPARSER 212------------------------------------------------------------------------------ 213EOT 214 215 $::bad_files = 0; 216 217 foreach my $t (@tests) { 218 unless (exists $::path_to_name{$t}) { 219 my $tname = File::Spec->catfile('t',$t); 220 $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS'; 221 $::path_to_name{$t} = $tname; 222 } 223 } 224 my $maxlen = 0; 225 foreach (@::path_to_name{@tests}) { 226 s/\.\w+\z/./; 227 my $len = length ; 228 $maxlen = $len if $len > $maxlen; 229 } 230 # + 3 : we want three dots between the test name and the "ok" 231 my $dotdotdot = $maxlen + 3 ; 232 my $valgrind = 0; 233 my $valgrind_log = 'current.valgrind'; 234 my $total_files = @tests; 235 my $good_files = 0; 236 my $tested_files = 0; 237 my $totmax = 0; 238 my %failed_tests; 239 240 while (my $test = shift @tests) { 241 my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0; 242 243 if ($test =~ /^$/) { 244 next; 245 } 246 if ($type eq 'deparse') { 247 if ($test eq "comp/redef.t") { 248 # Redefinition happens at compile time 249 next; 250 } 251 elsif ($test =~ m{lib/Switch/t/}) { 252 # B::Deparse doesn't support source filtering 253 next; 254 } 255 } 256 my $te = $::path_to_name{$test} . '.' 257 x ($dotdotdot - length($::path_to_name{$test})); 258 259 if ($^O ne 'VMS') { # defer printing on VMS due to piping bug 260 print $te; 261 $te = ''; 262 } 263 264 # XXX DAPM %OVER not defined anywhere 265 # $test = $OVER{$test} if exists $OVER{$test}; 266 267 open(SCRIPT,"<",$test) or die "Can't run $test.\n"; 268 $_ = <SCRIPT>; 269 close(SCRIPT) unless ($type eq 'deparse'); 270 if ($::with_utf16) { 271 $_ =~ tr/\0//d; 272 } 273 my $switch; 274 if (/#!.*\bperl.*\s-\w*([tT])/) { 275 $switch = qq{"-$1"}; 276 } 277 else { 278 if ($::taintwarn) { 279 # not all tests are expected to pass with this option 280 $switch = '"-t"'; 281 } 282 else { 283 $switch = ''; 284 } 285 } 286 287 my $file_opts = ""; 288 if ($type eq 'deparse') { 289 # Look for #line directives which change the filename 290 while (<SCRIPT>) { 291 $file_opts .= ",-f$3$4" 292 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; 293 } 294 close(SCRIPT); 295 } 296 297 my $utf8 = $::with_utf8 ? '-I../lib -Mutf8' : ''; 298 my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC 299 if ($type eq 'deparse') { 300 my $deparse_cmd = 301 "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,-sv1.,". 302 "-l$::deparse_opts$file_opts ". 303 "$test > $test.dp ". 304 "&& ./perl $testswitch $switch -I../lib $test.dp |"; 305 open(RESULTS, $deparse_cmd) 306 or print "can't deparse '$deparse_cmd': $!.\n"; 307 } 308 elsif ($type eq 'perl') { 309 my $perl = $ENV{PERL} || './perl'; 310 my $redir = $^O eq 'VMS' ? '2>&1' : ''; 311 if ($ENV{PERL_VALGRIND}) { 312 my $valgrind = $ENV{VALGRIND} // 'valgrind'; 313 my $vg_opts = $ENV{VG_OPTS} 314 // "--suppressions=perl.supp --leak-check=yes " 315 . "--leak-resolution=high --show-reachable=yes " 316 . "--num-callers=50"; 317 $perl = "$valgrind --log-fd=3 $vg_opts $perl"; 318 $redir = "3>$valgrind_log"; 319 } 320 my $run = "$perl" . _quote_args("$testswitch $switch $utf8") 321 . " $test $redir|"; 322 open(RESULTS,$run) or print "can't run '$run': $!.\n"; 323 } 324 # Our environment may force us to use UTF-8, but we can't be sure that 325 # anything we're reading from will be generating (well formed) UTF-8 326 # This may not be the best way - possibly we should unset ${^OPEN} up 327 # top? 328 binmode RESULTS; 329 330 my $failure; 331 my $next = 0; 332 my $seen_leader = 0; 333 my $seen_ok = 0; 334 my $trailing_leader = 0; 335 my $max; 336 my %todo; 337 while (<RESULTS>) { 338 next if /^\s*$/; # skip blank lines 339 if ($::verbose) { 340 print $_; 341 } 342 unless (/^\#/) { 343 if ($trailing_leader) { 344 # shouldn't be anything following a postfix 1..n 345 $failure = 'FAILED--extra output after trailing 1..n'; 346 last; 347 } 348 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { 349 if ($seen_leader) { 350 $failure = 'FAILED--seen duplicate leader'; 351 last; 352 } 353 $max = $1; 354 %todo = map { $_ => 1 } split / /, $3 if $3; 355 $totmax += $max; 356 $tested_files++; 357 if ($seen_ok) { 358 # 1..n appears at end of file 359 $trailing_leader = 1; 360 if ($next != $max) { 361 $failure = "FAILED--expected $max tests, saw $next"; 362 last; 363 } 364 } 365 else { 366 $next = 0; 367 } 368 $seen_leader = 1; 369 } 370 else { 371 if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) { 372 unless ($seen_leader) { 373 unless ($seen_ok) { 374 $next = 0; 375 } 376 } 377 $seen_ok = 1; 378 $next++; 379 my($not, $num, $extra, $istodo) = ($1, $2, $3, 0); 380 $num = $next unless $num; 381 382 if ($num == $next) { 383 384 # SKIP is essentially the same as TODO for t/TEST 385 # this still conforms to TAP: 386 # http://search.cpan.org/dist/Test-Harness/lib/Test/Harness/TAP.pod 387 $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/; 388 $istodo = 1 if $todo{$num}; 389 390 if( $not && !$istodo ) { 391 $failure = "FAILED at test $num"; 392 last; 393 } 394 } 395 else { 396 $failure ="FAILED--expected test $next, saw test $num"; 397 last; 398 } 399 } 400 elsif (/^Bail out!\s*(.*)/i) { # magic words 401 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); 402 } 403 else { 404 # module tests are allowed extra output, 405 # because Test::Harness allows it 406 next if $test =~ /^\W*(ext|lib)\b/; 407 $failure = "FAILED--unexpected output at test $next"; 408 last; 409 } 410 } 411 } 412 } 413 close RESULTS; 414 415 if (not defined $failure) { 416 $failure = 'FAILED--no leader found' unless $seen_leader; 417 } 418 419 if ($ENV{PERL_VALGRIND}) { 420 my @valgrind; 421 if (-e $valgrind_log) { 422 if (open(V, $valgrind_log)) { 423 @valgrind = <V>; 424 close V; 425 } else { 426 warn "$0: Failed to open '$valgrind_log': $!\n"; 427 } 428 } 429 if ($ENV{VG_OPTS} =~ /cachegrind/) { 430 if (rename $valgrind_log, "$test.valgrind") { 431 $valgrind++; 432 } else { 433 warn "$0: Failed to create '$test.valgrind': $!\n"; 434 } 435 } 436 elsif (@valgrind) { 437 my $leaks = 0; 438 my $errors = 0; 439 for my $i (0..$#valgrind) { 440 local $_ = $valgrind[$i]; 441 if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) { 442 $errors += $1; # there may be multiple error summaries 443 } elsif (/^==\d+== LEAK SUMMARY:/) { 444 for my $off (1 .. 4) { 445 if ($valgrind[$i+$off] =~ 446 /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) { 447 $leaks += $1; 448 } 449 } 450 } 451 } 452 if ($errors or $leaks) { 453 if (rename $valgrind_log, "$test.valgrind") { 454 $valgrind++; 455 } else { 456 warn "$0: Failed to create '$test.valgrind': $!\n"; 457 } 458 } 459 } else { 460 warn "No valgrind output?\n"; 461 } 462 if (-e $valgrind_log) { 463 unlink $valgrind_log 464 or warn "$0: Failed to unlink '$valgrind_log': $!\n"; 465 } 466 } 467 if ($type eq 'deparse') { 468 unlink "./$test.dp"; 469 } 470 if ($ENV{PERL_3LOG}) { 471 my $tpp = $test; 472 $tpp =~ s:^\.\./::; 473 $tpp =~ s:/:_:g; 474 $tpp =~ s:\.t$:.3log:; 475 rename("perl.3log", $tpp) || 476 die "rename: perl3.log to $tpp: $!\n"; 477 } 478 if (not defined $failure and $next != $max) { 479 $failure="FAILED--expected $max tests, saw $next"; 480 } 481 482 if( !defined $failure # don't mask a test failure 483 and $? ) 484 { 485 $failure = "FAILED--non-zero wait status: $?"; 486 } 487 488 if (defined $failure) { 489 print "${te}$failure\n"; 490 $::bad_files++; 491 if ($test =~ /^base/) { 492 die "Failed a basic test ($test) -- cannot continue.\n"; 493 } 494 ++$failed_tests{$test}; 495 } 496 else { 497 if ($max) { 498 my $elapsed; 499 if ( $show_elapsed_time ) { 500 $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 ); 501 } 502 else { 503 $elapsed = ""; 504 } 505 print "${te}ok$elapsed\n"; 506 $good_files++; 507 } 508 else { 509 print "${te}skipped\n"; 510 $tested_files -= 1; 511 } 512 } 513 } # while tests 514 515 if ($::bad_files == 0) { 516 if ($good_files) { 517 print "All tests successful.\n"; 518 # XXX add mention of 'perlbug -ok' ? 519 } 520 else { 521 die "FAILED--no tests were run for some reason.\n"; 522 } 523 } 524 else { 525 my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00"; 526 my $s = $::bad_files == 1 ? "" : "s"; 527 warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n"; 528 for my $test ( sort keys %failed_tests ) { 529 print "\t$test\n"; 530 } 531 warn <<'SHRDLU_1'; 532### Since not all tests were successful, you may want to run some of 533### them individually and examine any diagnostic messages they produce. 534### See the INSTALL document's section on "make test". 535SHRDLU_1 536 warn <<'SHRDLU_2' if $good_files / $total_files > 0.8; 537### You have a good chance to get more information by running 538### ./perl harness 539### in the 't' directory since most (>=80%) of the tests succeeded. 540SHRDLU_2 541 if (eval {require Config; import Config; 1}) { 542 if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) { 543 warn <<SHRDLU_3; 544### You may have to set your dynamic library search path, 545### $p, to point to the build directory: 546SHRDLU_3 547 if (exists $ENV{$p} && $ENV{$p} ne '') { 548 warn <<SHRDLU_4a; 549### setenv $p `pwd`:\$$p; cd t; ./perl harness 550### $p=`pwd`:\$$p; export $p; cd t; ./perl harness 551### export $p=`pwd`:\$$p; cd t; ./perl harness 552SHRDLU_4a 553 } else { 554 warn <<SHRDLU_4b; 555### setenv $p `pwd`; cd t; ./perl harness 556### $p=`pwd`; export $p; cd t; ./perl harness 557### export $p=`pwd`; cd t; ./perl harness 558SHRDLU_4b 559 } 560 warn <<SHRDLU_5; 561### for csh-style shells, like tcsh; or for traditional/modern 562### Bourne-style shells, like bash, ksh, and zsh, respectively. 563SHRDLU_5 564 } 565 } 566 } 567 my ($user,$sys,$cuser,$csys) = times; 568 print sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d\n", 569 $user,$sys,$cuser,$csys,$tested_files,$totmax); 570 if ($ENV{PERL_VALGRIND}) { 571 my $s = $valgrind == 1 ? '' : 's'; 572 print "$valgrind valgrind report$s created.\n", ; 573 } 574} 575exit ($::bad_files != 0); 576 577# ex: set ts=8 sts=4 sw=4 noet: 578