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# t/TEST and t/harness need to share code. The logical way to do this would be 9# to have the common code in a file both require or use. However, t/TEST needs 10# to still work, to generate test results, even if require isn't working, so 11# we cannot do that. t/harness has no such restriction, so it is quite 12# acceptable to have it require t/TEST. 13 14# In which case, we need to stop t/TEST actually running tests, as all 15# t/harness needs are its subroutines. 16 17 18# directories with special sets of test switches 19my %dir_to_switch = 20 (base => '', 21 comp => '', 22 run => '', 23 '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/ 24 ); 25 26# "not absolute" is the the default, as it saves some fakery within TestInit 27# which can peturb tests, and takes CPU. Working with the upstream author of 28# any of these, to figure out how to remove them from this list, considered 29# "a good thing". 30my %abs = ( 31 '../cpan/Archive-Extract' => 1, 32 '../cpan/Archive-Tar' => 1, 33 '../cpan/AutoLoader' => 1, 34 '../cpan/CPAN' => 1, 35 '../cpan/Class-ISA' => 1, 36 '../cpan/Cwd' => 1, 37 '../cpan/Devel-PPPort' => 1, 38 '../cpan/Encode' => 1, 39 '../cpan/ExtUtils-Command' => 1, 40 '../cpan/ExtUtils-Constant' => 1, 41 '../cpan/ExtUtils-MakeMaker' => 1, 42 '../cpan/ExtUtils-Manifest' => 1, 43 '../cpan/ExtUtils-ParseXS' => 1, 44 '../cpan/File-Fetch' => 1, 45 '../cpan/IPC-Cmd' => 1, 46 '../cpan/IPC-SysV' => 1, 47 '../cpan/Locale-Codes' => 1, 48 '../cpan/Log-Message' => 1, 49 '../cpan/Math-BigInt' => 1, 50 '../cpan/Math-BigRat' => 1, 51 '../cpan/Math-Complex' => 1, 52 '../cpan/Module-Build' => 1, 53 '../cpan/Module-Load' => 1, 54 '../cpan/Module-Load-Conditional' => 1, 55 '../cpan/Object-Accessor' => 1, 56 '../cpan/Package-Constants' => 1, 57 '../cpan/Parse-CPAN-Meta' => 1, 58 '../cpan/Pod-Simple' => 1, 59 '../cpan/Term-UI' => 1, 60 '../cpan/Test-Simple' => 1, 61 '../cpan/Tie-File' => 1, 62 '../cpan/bignum' => 1, 63 '../cpan/podlators' => 1, 64 '../dist/ExtUtils-Install' => 1, 65 ); 66 67my %temp_no_core = 68 ('../cpan/B-Debug' => 1, 69 '../cpan/Compress-Raw-Bzip2' => 1, 70 '../cpan/Compress-Raw-Zlib' => 1, 71 '../cpan/Devel-PPPort' => 1, 72 '../cpan/Getopt-Long' => 1, 73 '../cpan/IO-Compress' => 1, 74 '../cpan/Math-BigInt' => 1, 75 '../cpan/Math-BigRat' => 1, 76 '../cpan/MIME-Base64' => 1, 77 '../cpan/NEXT' => 1, 78 '../cpan/parent' => 1, 79 '../cpan/Parse-CPAN-Meta' => 1, 80 '../cpan/Pod-Simple' => 1, 81 '../cpan/podlators' => 1, 82 '../cpan/Test-Simple' => 1, 83 '../cpan/Tie-RefHash' => 1, 84 '../cpan/Time-HiRes' => 1, 85 '../cpan/Unicode-Collate' => 1, 86 '../cpan/Unicode-Normalize' => 1, 87 ); 88 89if ($::do_nothing) { 90 return 1; 91} 92 93# Location to put the Valgrind log. 94my $Valgrind_Log = 'current.valgrind'; 95 96$| = 1; 97 98# for testing TEST only 99#BEGIN { require '../lib/strict.pm'; "strict"->import() }; 100#BEGIN { require '../lib/warnings.pm'; "warnings"->import() }; 101 102# delete env vars that may influence the results 103# but allow override via *_TEST env var if wanted 104# (e.g. PERL5OPT_TEST=-d:NYTProf) 105for my $envname (qw(PERL5LIB PERLLIB PERL5OPT)) { 106 my $override = $ENV{"${envname}_TEST"}; 107 if (defined $override) { 108 warn "$0: $envname=$override\n"; 109 $ENV{$envname} = $override; 110 } 111 else { 112 delete $ENV{$envname}; 113 } 114} 115 116# remove empty elements due to insertion of empty symbols via "''p1'" syntax 117@ARGV = grep($_,@ARGV) if $^O eq 'VMS'; 118our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; 119 120# Cheesy version of Getopt::Std. We can't replace it with that, because we 121# can't rely on require working. 122{ 123 my @argv = (); 124 foreach my $idx (0..$#ARGV) { 125 push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/; 126 $::benchmark = 1 if $1 eq 'benchmark'; 127 $::core = 1 if $1 eq 'core'; 128 $::verbose = 1 if $1 eq 'v'; 129 $::torture = 1 if $1 eq 'torture'; 130 $::with_utf8 = 1 if $1 eq 'utf8'; 131 $::with_utf16 = 1 if $1 eq 'utf16'; 132 $::taintwarn = 1 if $1 eq 'taintwarn'; 133 $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; 134 if ($1 =~ /^deparse(,.+)?$/) { 135 $::deparse = 1; 136 $::deparse_opts = $1; 137 } 138 } 139 @ARGV = @argv; 140} 141 142chdir 't' if -f 't/TEST'; 143if (-f 'TEST' && -f 'harness' && -d '../lib') { 144 @INC = '../lib'; 145} 146 147die "You need to run \"make test\" first to set things up.\n" 148 unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; 149 150if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack 151 unless (-x 'perl.third') { 152 unless (-x '../perl.third') { 153 die "You need to run \"make perl.third first.\n"; 154 } 155 else { 156 print "Symlinking ../perl.third as perl.third...\n"; 157 die "Failed to symlink: $!\n" 158 unless symlink("../perl.third", "perl.third"); 159 die "Symlinked but no executable perl.third: $!\n" 160 unless -x 'perl.third'; 161 } 162 } 163} 164 165# check leakage for embedders 166$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; 167 168$ENV{EMXSHELL} = 'sh'; # For OS/2 169 170if ($show_elapsed_time) { require Time::HiRes } 171 172my %skip = ( 173 '.' => 1, 174 '..' => 1, 175 'CVS' => 1, 176 'RCS' => 1, 177 'SCCS' => 1, 178 '.svn' => 1, 179 ); 180 181# Roll your own File::Find! 182sub _find_tests { 183 my($dir) = @_; 184 opendir DIR, $dir or die "Trouble opening $dir: $!"; 185 foreach my $f (sort { $a cmp $b } readdir DIR) { 186 next if $skip{$f}; 187 188 my $fullpath = "$dir/$f"; 189 190 if (-d $fullpath) { 191 _find_tests($fullpath); 192 } elsif ($f =~ /\.t$/) { 193 push @ARGV, $fullpath; 194 } 195 } 196} 197 198 199# Scan the text of the test program to find switches and special options 200# we might need to apply. 201sub _scan_test { 202 my($test, $type) = @_; 203 204 open(my $script, "<", $test) or die "Can't read $test.\n"; 205 my $first_line = <$script>; 206 207 $first_line =~ tr/\0//d if $::with_utf16; 208 209 my $switch = ""; 210 if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) { 211 $switch = "-$1"; 212 } else { 213 if ($::taintwarn) { 214 # not all tests are expected to pass with this option 215 $switch = '-t'; 216 } else { 217 $switch = ''; 218 } 219 } 220 221 my $file_opts = ""; 222 if ($type eq 'deparse') { 223 # Look for #line directives which change the filename 224 while (<$script>) { 225 $file_opts = $file_opts . ",-f$3$4" 226 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; 227 } 228 } 229 230 close $script; 231 232 my $perl = './perl'; 233 my $lib = '../lib'; 234 my $run_dir; 235 my $return_dir; 236 237 $test =~ /^(.+)\/[^\/]+/; 238 my $dir = $1; 239 my $testswitch = $dir_to_switch{$dir}; 240 if (!defined $testswitch) { 241 if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) { 242 $run_dir = $1; 243 $return_dir = '../../t'; 244 $lib = '../../lib'; 245 $perl = '../../t/perl'; 246 $testswitch = "-I../.. -MTestInit=U2T"; 247 if ($2 eq 'cpan' || $2 eq 'dist') { 248 if($abs{$run_dir}) { 249 $testswitch = $testswitch . ',A'; 250 } 251 if ($temp_no_core{$run_dir}) { 252 $testswitch = $testswitch . ',NC'; 253 } 254 } 255 } else { 256 $testswitch = '-I.. -MTestInit'; # -T will remove . from @INC 257 } 258 } 259 260 my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : ''; 261 262 my %options = ( 263 perl => $perl, 264 lib => $lib, 265 test => $test, 266 run_dir => $run_dir, 267 return_dir => $return_dir, 268 testswitch => $testswitch, 269 utf8 => $utf8, 270 file => $file_opts, 271 switch => $switch, 272 ); 273 274 return \%options; 275} 276 277sub _cmd { 278 my($options, $type) = @_; 279 280 my $test = $options->{test}; 281 282 my $cmd; 283 if ($type eq 'deparse') { 284 my $perl = "$options->{perl} $options->{testswitch}"; 285 my $lib = $options->{lib}; 286 287 $cmd = ( 288 "$perl $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,". 289 "-l$::deparse_opts$options->{file} ". 290 "$test > $test.dp ". 291 "&& $perl $options->{switch} -I$lib $test.dp" 292 ); 293 } 294 elsif ($type eq 'perl') { 295 my $perl = $options->{perl}; 296 my $redir = $^O eq 'VMS' ? '2>&1' : ''; 297 298 if ($ENV{PERL_VALGRIND}) { 299 my $valgrind = $ENV{VALGRIND} // 'valgrind'; 300 my $vg_opts = $ENV{VG_OPTS} 301 // "--suppressions=perl.supp --leak-check=yes " 302 . "--leak-resolution=high --show-reachable=yes " 303 . "--num-callers=50"; 304 $perl = "$valgrind --log-fd=3 $vg_opts $perl"; 305 $redir = "3>$Valgrind_Log"; 306 } 307 308 my $args = "$options->{testswitch} $options->{switch} $options->{utf8}"; 309 $cmd = $perl . _quote_args($args) . " $test $redir"; 310 } 311 312 return $cmd; 313} 314 315sub _before_fork { 316 my ($options) = @_; 317 318 if ($options->{run_dir}) { 319 my $run_dir = $options->{run_dir}; 320 chdir $run_dir or die "Can't chdir to '$run_dir': $!"; 321 } 322 323 return; 324} 325 326sub _after_fork { 327 my ($options) = @_; 328 329 if ($options->{return_dir}) { 330 my $return_dir = $options->{return_dir}; 331 chdir $return_dir 332 or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!"; 333 } 334 335 return; 336} 337 338sub _run_test { 339 my ($test, $type) = @_; 340 341 my $options = _scan_test($test, $type); 342 # $test might have changed if we're in ext/Foo, so don't use it anymore 343 # from now on. Use $options->{test} instead. 344 345 _before_fork($options); 346 347 my $cmd = _cmd($options, $type); 348 349 open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n"; 350 351 _after_fork($options); 352 353 # Our environment may force us to use UTF-8, but we can't be sure that 354 # anything we're reading from will be generating (well formed) UTF-8 355 # This may not be the best way - possibly we should unset ${^OPEN} up 356 # top? 357 binmode $results; 358 359 return $results; 360} 361 362sub _quote_args { 363 my ($args) = @_; 364 my $argstring = ''; 365 366 foreach (split(/\s+/,$args)) { 367 # In VMS protect with doublequotes because otherwise 368 # DCL will lowercase -- unless already doublequoted. 369 $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; 370 $argstring = $argstring . ' ' . $_; 371 } 372 return $argstring; 373} 374 375sub _populate_hash { 376 return unless defined $_[0]; 377 return map {$_, 1} split /\s+/, $_[0]; 378} 379 380sub _tests_from_manifest { 381 my ($extensions, $known_extensions) = @_; 382 my %skip; 383 my %extensions = _populate_hash($extensions); 384 my %known_extensions = _populate_hash($known_extensions); 385 386 foreach (keys %known_extensions) { 387 $skip{$_} = 1 unless $extensions{$_}; 388 } 389 390 my @results; 391 my $mani = '../MANIFEST'; 392 if (open(MANI, $mani)) { 393 while (<MANI>) { 394 if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { 395 my $t = $1; 396 my $extension = $2; 397 if (!$::core || $t =~ m!^lib/[a-z]!) { 398 if (defined $extension) { 399 $extension =~ s!/t$!!; 400 # XXX Do I want to warn that I'm skipping these? 401 next if $skip{$extension}; 402 my $flat_extension = $extension; 403 $flat_extension =~ s!-!/!g; 404 next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar 405 } 406 my $path = "../$t"; 407 push @results, $path; 408 $::path_to_name{$path} = $t; 409 } 410 } 411 } 412 close MANI; 413 } else { 414 warn "$0: cannot open $mani: $!\n"; 415 } 416 return @results; 417} 418 419unless (@ARGV) { 420 # base first, as TEST bails out if that can't run 421 # then comp, to validate that require works 422 # then run, to validate that -M works 423 # then we know we can -MTestInit for everything else, making life simpler 424 foreach my $dir (qw(base comp run cmd io re op uni mro)) { 425 _find_tests($dir); 426 } 427 _find_tests("lib") unless $::core; 428 # Config.pm may be broken for make minitest. And this is only a refinement 429 # for skipping tests on non-default builds, so it is allowed to fail. 430 # What we want to to is make a list of extensions which we did not build. 431 my $configsh = '../config.sh'; 432 my ($extensions, $known_extensions); 433 if (-f $configsh) { 434 open FH, $configsh or die "Can't open $configsh: $!"; 435 while (<FH>) { 436 if (/^extensions=['"](.*)['"]$/) { 437 $extensions = $1; 438 } 439 elsif (/^known_extensions=['"](.*)['"]$/) { 440 $known_extensions = $1; 441 } 442 } 443 if (!defined $known_extensions) { 444 warn "No known_extensions line found in $configsh"; 445 } 446 if (!defined $extensions) { 447 warn "No extensions line found in $configsh"; 448 } 449 } 450 # The "complex" constructions of list return from a subroutine, and push of 451 # a list, might fail if perl is really hosed, but they aren't needed for 452 # make minitest, and the building of extensions will likely also fail if 453 # something is that badly wrong. 454 push @ARGV, _tests_from_manifest($extensions, $known_extensions); 455 unless ($::core) { 456 _find_tests('x2p'); 457 _find_tests('porting'); 458 _find_tests('japh') if $::torture; 459 _find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK}; 460 } 461} 462 463if ($::deparse) { 464 _testprogs('deparse', '', @ARGV); 465} 466elsif ($::with_utf16) { 467 for my $e (0, 1) { 468 for my $b (0, 1) { 469 print STDERR "# ENDIAN $e BOM $b\n"; 470 my @UARGV; 471 for my $a (@ARGV) { 472 my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : ""); 473 my $f = $e ? "v" : "n"; 474 push @UARGV, $u; 475 unlink($u); 476 if (open(A, $a)) { 477 if (open(U, ">$u")) { 478 print U pack("$f", 0xFEFF) if $b; 479 while (<A>) { 480 print U pack("$f*", unpack("C*", $_)); 481 } 482 close(U); 483 } 484 close(A); 485 } 486 } 487 _testprogs('perl', '', @UARGV); 488 unlink(@UARGV); 489 } 490 } 491} 492else { 493 _testprogs('perl', '', @ARGV); 494} 495 496sub _testprogs { 497 my ($type, $args, @tests) = @_; 498 499 print <<'EOT' if ($type eq 'deparse'); 500------------------------------------------------------------------------------ 501TESTING DEPARSER 502------------------------------------------------------------------------------ 503EOT 504 505 $::bad_files = 0; 506 507 foreach my $t (@tests) { 508 unless (exists $::path_to_name{$t}) { 509 my $tname = "t/$t"; 510 $::path_to_name{$t} = $tname; 511 } 512 } 513 my $maxlen = 0; 514 foreach (@::path_to_name{@tests}) { 515 s/\.\w+\z/./; 516 my $len = length ; 517 $maxlen = $len if $len > $maxlen; 518 } 519 # + 3 : we want three dots between the test name and the "ok" 520 my $dotdotdot = $maxlen + 3 ; 521 my $valgrind = 0; 522 my $total_files = @tests; 523 my $good_files = 0; 524 my $tested_files = 0; 525 my $totmax = 0; 526 my %failed_tests; 527 528 while (my $test = shift @tests) { 529 my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0; 530 531 if ($test =~ /^$/) { 532 next; 533 } 534 if ($type eq 'deparse') { 535 if ($test eq "comp/redef.t") { 536 # Redefinition happens at compile time 537 next; 538 } 539 elsif ($test =~ m{lib/Switch/t/}) { 540 # B::Deparse doesn't support source filtering 541 next; 542 } 543 } 544 my $te = $::path_to_name{$test} . '.' 545 x ($dotdotdot - length($::path_to_name{$test})); 546 547 if ($^O ne 'VMS') { # defer printing on VMS due to piping bug 548 print $te; 549 $te = ''; 550 } 551 552 my $results = _run_test($test, $type); 553 554 my $failure; 555 my $next = 0; 556 my $seen_leader = 0; 557 my $seen_ok = 0; 558 my $trailing_leader = 0; 559 my $max; 560 my %todo; 561 while (<$results>) { 562 next if /^\s*$/; # skip blank lines 563 if (/^1..$/ && ($^O eq 'VMS')) { 564 # VMS pipe bug inserts blank lines. 565 my $l2 = <RESULTS>; 566 if ($l2 =~ /^\s*$/) { 567 $l2 = <RESULTS>; 568 } 569 $_ = '1..' . $l2; 570 } 571 if ($::verbose) { 572 print $_; 573 } 574 unless (/^\#/) { 575 if ($trailing_leader) { 576 # shouldn't be anything following a postfix 1..n 577 $failure = 'FAILED--extra output after trailing 1..n'; 578 last; 579 } 580 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { 581 if ($seen_leader) { 582 $failure = 'FAILED--seen duplicate leader'; 583 last; 584 } 585 $max = $1; 586 %todo = map { $_ => 1 } split / /, $3 if $3; 587 $totmax = $totmax + $max; 588 $tested_files = $tested_files + 1; 589 if ($seen_ok) { 590 # 1..n appears at end of file 591 $trailing_leader = 1; 592 if ($next != $max) { 593 $failure = "FAILED--expected $max tests, saw $next"; 594 last; 595 } 596 } 597 else { 598 $next = 0; 599 } 600 $seen_leader = 1; 601 } 602 else { 603 if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) { 604 unless ($seen_leader) { 605 unless ($seen_ok) { 606 $next = 0; 607 } 608 } 609 $seen_ok = 1; 610 $next = $next + 1; 611 my($not, $num, $extra, $istodo) = ($1, $2, $3, 0); 612 $num = $next unless $num; 613 614 if ($num == $next) { 615 616 # SKIP is essentially the same as TODO for t/TEST 617 # this still conforms to TAP: 618 # http://search.cpan.org/dist/TAP/TAP.pm 619 $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/; 620 $istodo = 1 if $todo{$num}; 621 622 if( $not && !$istodo ) { 623 $failure = "FAILED at test $num"; 624 last; 625 } 626 } 627 else { 628 $failure ="FAILED--expected test $next, saw test $num"; 629 last; 630 } 631 } 632 elsif (/^Bail out!\s*(.*)/i) { # magic words 633 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); 634 } 635 else { 636 # module tests are allowed extra output, 637 # because Test::Harness allows it 638 next if $test =~ /^\W*(cpan|dist|ext|lib)\b/; 639 $failure = "FAILED--unexpected output at test $next"; 640 last; 641 } 642 } 643 } 644 } 645 close $results; 646 647 if (not defined $failure) { 648 $failure = 'FAILED--no leader found' unless $seen_leader; 649 } 650 651 if ($ENV{PERL_VALGRIND}) { 652 my @valgrind; 653 if (-e $Valgrind_Log) { 654 if (open(V, $Valgrind_Log)) { 655 @valgrind = <V>; 656 close V; 657 } else { 658 warn "$0: Failed to open '$Valgrind_Log': $!\n"; 659 } 660 } 661 if ($ENV{VG_OPTS} =~ /cachegrind/) { 662 if (rename $Valgrind_Log, "$test.valgrind") { 663 $valgrind = $valgrind + 1; 664 } else { 665 warn "$0: Failed to create '$test.valgrind': $!\n"; 666 } 667 } 668 elsif (@valgrind) { 669 my $leaks = 0; 670 my $errors = 0; 671 for my $i (0..$#valgrind) { 672 local $_ = $valgrind[$i]; 673 if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) { 674 $errors = $errors + $1; # there may be multiple error summaries 675 } elsif (/^==\d+== LEAK SUMMARY:/) { 676 for my $off (1 .. 4) { 677 if ($valgrind[$i+$off] =~ 678 /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) { 679 $leaks = $leaks + $1; 680 } 681 } 682 } 683 } 684 if ($errors or $leaks) { 685 if (rename $Valgrind_Log, "$test.valgrind") { 686 $valgrind = $valgrind + 1; 687 } else { 688 warn "$0: Failed to create '$test.valgrind': $!\n"; 689 } 690 } 691 } else { 692 warn "No valgrind output?\n"; 693 } 694 if (-e $Valgrind_Log) { 695 unlink $Valgrind_Log 696 or warn "$0: Failed to unlink '$Valgrind_Log': $!\n"; 697 } 698 } 699 if ($type eq 'deparse') { 700 unlink "./$test.dp"; 701 } 702 if ($ENV{PERL_3LOG}) { 703 my $tpp = $test; 704 $tpp =~ s:^\.\./::; 705 $tpp =~ s:/:_:g; 706 $tpp =~ s:\.t$:.3log:; 707 rename("perl.3log", $tpp) || 708 die "rename: perl3.log to $tpp: $!\n"; 709 } 710 if (not defined $failure and $next != $max) { 711 $failure="FAILED--expected $max tests, saw $next"; 712 } 713 714 if( !defined $failure # don't mask a test failure 715 and $? ) 716 { 717 $failure = "FAILED--non-zero wait status: $?"; 718 } 719 720 if (defined $failure) { 721 print "${te}$failure\n"; 722 $::bad_files = $::bad_files + 1; 723 if ($test =~ /^base/) { 724 die "Failed a basic test ($test) -- cannot continue.\n"; 725 } 726 $failed_tests{$test} = 1; 727 } 728 else { 729 if ($max) { 730 my $elapsed; 731 if ( $show_elapsed_time ) { 732 $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 ); 733 } 734 else { 735 $elapsed = ""; 736 } 737 print "${te}ok$elapsed\n"; 738 $good_files = $good_files + 1; 739 } 740 else { 741 print "${te}skipped\n"; 742 $tested_files = $tested_files - 1; 743 } 744 } 745 } # while tests 746 747 if ($::bad_files == 0) { 748 if ($good_files) { 749 print "All tests successful.\n"; 750 # XXX add mention of 'perlbug -ok' ? 751 } 752 else { 753 die "FAILED--no tests were run for some reason.\n"; 754 } 755 } 756 else { 757 my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00"; 758 my $s = $::bad_files == 1 ? "" : "s"; 759 warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n"; 760 for my $test ( sort keys %failed_tests ) { 761 print "\t$test\n"; 762 } 763 warn <<'SHRDLU_1'; 764### Since not all tests were successful, you may want to run some of 765### them individually and examine any diagnostic messages they produce. 766### See the INSTALL document's section on "make test". 767SHRDLU_1 768 warn <<'SHRDLU_2' if $good_files / $total_files > 0.8; 769### You have a good chance to get more information by running 770### ./perl harness 771### in the 't' directory since most (>=80%) of the tests succeeded. 772SHRDLU_2 773 if (eval {require Config; import Config; 1}) { 774 if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) { 775 warn <<SHRDLU_3; 776### You may have to set your dynamic library search path, 777### $p, to point to the build directory: 778SHRDLU_3 779 if (exists $ENV{$p} && $ENV{$p} ne '') { 780 warn <<SHRDLU_4a; 781### setenv $p `pwd`:\$$p; cd t; ./perl harness 782### $p=`pwd`:\$$p; export $p; cd t; ./perl harness 783### export $p=`pwd`:\$$p; cd t; ./perl harness 784SHRDLU_4a 785 } else { 786 warn <<SHRDLU_4b; 787### setenv $p `pwd`; cd t; ./perl harness 788### $p=`pwd`; export $p; cd t; ./perl harness 789### export $p=`pwd`; cd t; ./perl harness 790SHRDLU_4b 791 } 792 warn <<SHRDLU_5; 793### for csh-style shells, like tcsh; or for traditional/modern 794### Bourne-style shells, like bash, ksh, and zsh, respectively. 795SHRDLU_5 796 } 797 } 798 } 799 my ($user,$sys,$cuser,$csys) = times; 800 print sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d\n", 801 $user,$sys,$cuser,$csys,$tested_files,$totmax); 802 if ($ENV{PERL_VALGRIND}) { 803 my $s = $valgrind == 1 ? '' : 's'; 804 print "$valgrind valgrind report$s created.\n", ; 805 } 806} 807exit ($::bad_files != 0); 808 809# ex: set ts=8 sts=4 sw=4 noet: 810