| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 # -*- Mode: cperl; cperl-indent-level: 4 -*- 2 3 package Test::Harness; 4 5 require 5.00405; 6 use Test::Harness::Straps; 7 use Test::Harness::Assert; 8 use Exporter; 9 use Benchmark; 10 use Config; 11 use strict; 12 13 14 use vars qw( 15 $VERSION 16 @ISA @EXPORT @EXPORT_OK 17 $Verbose $Switches $Debug 18 $verbose $switches $debug 19 $Columns 20 $Timer 21 $ML $Last_ML_Print 22 $Strap 23 $has_time_hires 24 ); 25 26 BEGIN { 27 eval q{use Time::HiRes 'time'}; 28 $has_time_hires = !$@; 29 } 30 31 =head1 NAME 32 33 Test::Harness - Run Perl standard test scripts with statistics 34 35 =head1 VERSION 36 37 Version 2.64 38 39 =cut 40 41 $VERSION = '2.64'; 42 43 # Backwards compatibility for exportable variable names. 44 *verbose = *Verbose; 45 *switches = *Switches; 46 *debug = *Debug; 47 48 $ENV{HARNESS_ACTIVE} = 1; 49 $ENV{HARNESS_VERSION} = $VERSION; 50 51 END { 52 # For VMS. 53 delete $ENV{HARNESS_ACTIVE}; 54 delete $ENV{HARNESS_VERSION}; 55 } 56 57 my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR}; 58 59 # Stolen from Params::Util 60 sub _CLASS { 61 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s) ? $_[0] : undef; 62 } 63 64 # Strap Overloading 65 if ( $ENV{HARNESS_STRAPS_CLASS} ) { 66 die 'Set HARNESS_STRAP_CLASS, singular, not HARNESS_STRAPS_CLASS'; 67 } 68 my $HARNESS_STRAP_CLASS = $ENV{HARNESS_STRAP_CLASS} || 'Test::Harness::Straps'; 69 if ( $HARNESS_STRAP_CLASS =~ /\.pm$/ ) { 70 # "Class" is actually a filename, that should return the 71 # class name as its true return value. 72 $HARNESS_STRAP_CLASS = require $HARNESS_STRAP_CLASS; 73 if ( !_CLASS($HARNESS_STRAP_CLASS) ) { 74 die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name"; 75 } 76 } 77 else { 78 # It is a class name within the current @INC 79 if ( !_CLASS($HARNESS_STRAP_CLASS) ) { 80 die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name"; 81 } 82 eval "require $HARNESS_STRAP_CLASS"; 83 die $@ if $@; 84 } 85 if ( !$HARNESS_STRAP_CLASS->isa('Test::Harness::Straps') ) { 86 die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' must be a Test::Harness::Straps subclass"; 87 } 88 89 $Strap = $HARNESS_STRAP_CLASS->new; 90 91 sub strap { return $Strap }; 92 93 @ISA = ('Exporter'); 94 @EXPORT = qw(&runtests); 95 @EXPORT_OK = qw(&execute_tests $verbose $switches); 96 97 $Verbose = $ENV{HARNESS_VERBOSE} || 0; 98 $Debug = $ENV{HARNESS_DEBUG} || 0; 99 $Switches = '-w'; 100 $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; 101 $Columns--; # Some shells have trouble with a full line of text. 102 $Timer = $ENV{HARNESS_TIMER} || 0; 103 104 =head1 SYNOPSIS 105 106 use Test::Harness; 107 108 runtests(@test_files); 109 110 =head1 DESCRIPTION 111 112 B<STOP!> If all you want to do is write a test script, consider 113 using Test::Simple. Test::Harness is the module that reads the 114 output from Test::Simple, Test::More and other modules based on 115 Test::Builder. You don't need to know about Test::Harness to use 116 those modules. 117 118 Test::Harness runs tests and expects output from the test in a 119 certain format. That format is called TAP, the Test Anything 120 Protocol. It is defined in L<Test::Harness::TAP>. 121 122 C<Test::Harness::runtests(@tests)> runs all the testscripts named 123 as arguments and checks standard output for the expected strings 124 in TAP format. 125 126 The F<prove> utility is a thin wrapper around Test::Harness. 127 128 =head2 Taint mode 129 130 Test::Harness will honor the C<-T> or C<-t> in the #! line on your 131 test files. So if you begin a test with: 132 133 #!perl -T 134 135 the test will be run with taint mode on. 136 137 =head2 Configuration variables. 138 139 These variables can be used to configure the behavior of 140 Test::Harness. They are exported on request. 141 142 =over 4 143 144 =item C<$Test::Harness::Verbose> 145 146 The package variable C<$Test::Harness::Verbose> is exportable and can be 147 used to let C<runtests()> display the standard output of the script 148 without altering the behavior otherwise. The F<prove> utility's C<-v> 149 flag will set this. 150 151 =item C<$Test::Harness::switches> 152 153 The package variable C<$Test::Harness::switches> is exportable and can be 154 used to set perl command line options used for running the test 155 script(s). The default value is C<-w>. It overrides C<HARNESS_PERL_SWITCHES>. 156 157 =item C<$Test::Harness::Timer> 158 159 If set to true, and C<Time::HiRes> is available, print elapsed seconds 160 after each test file. 161 162 =back 163 164 165 =head2 Failure 166 167 When tests fail, analyze the summary report: 168 169 t/base..............ok 170 t/nonumbers.........ok 171 t/ok................ok 172 t/test-harness......ok 173 t/waterloo..........dubious 174 Test returned status 3 (wstat 768, 0x300) 175 DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19 176 Failed 10/20 tests, 50.00% okay 177 Failed Test Stat Wstat Total Fail List of Failed 178 --------------------------------------------------------------- 179 t/waterloo.t 3 768 20 10 1 3 5 7 9 11 13 15 17 19 180 Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay. 181 182 Everything passed but F<t/waterloo.t>. It failed 10 of 20 tests and 183 exited with non-zero status indicating something dubious happened. 184 185 The columns in the summary report mean: 186 187 =over 4 188 189 =item B<Failed Test> 190 191 The test file which failed. 192 193 =item B<Stat> 194 195 If the test exited with non-zero, this is its exit status. 196 197 =item B<Wstat> 198 199 The wait status of the test. 200 201 =item B<Total> 202 203 Total number of tests expected to run. 204 205 =item B<Fail> 206 207 Number which failed, either from "not ok" or because they never ran. 208 209 =item B<List of Failed> 210 211 A list of the tests which failed. Successive failures may be 212 abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and 213 20 failed). 214 215 =back 216 217 218 =head1 FUNCTIONS 219 220 The following functions are available. 221 222 =head2 runtests( @test_files ) 223 224 This runs all the given I<@test_files> and divines whether they passed 225 or failed based on their output to STDOUT (details above). It prints 226 out each individual test which failed along with a summary report and 227 a how long it all took. 228 229 It returns true if everything was ok. Otherwise it will C<die()> with 230 one of the messages in the DIAGNOSTICS section. 231 232 =cut 233 234 sub runtests { 235 my(@tests) = @_; 236 237 local ($\, $,); 238 239 my ($tot, $failedtests,$todo_passed) = execute_tests(tests => \@tests); 240 print get_results($tot, $failedtests,$todo_passed); 241 242 my $ok = _all_ok($tot); 243 244 assert(($ok xor keys %$failedtests), 245 q{ok status jives with $failedtests}); 246 247 if (! $ok) { 248 die("Failed $tot->{bad}/$tot->{tests} test programs. " . 249 "@{[$tot->{max} - $tot->{ok}]}/$tot->{max} subtests failed.\n"); 250 } 251 252 return $ok; 253 } 254 255 # my $ok = _all_ok(\%tot); 256 # Tells you if this test run is overall successful or not. 257 258 sub _all_ok { 259 my($tot) = shift; 260 261 return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0; 262 } 263 264 # Returns all the files in a directory. This is shorthand for backwards 265 # compatibility on systems where C<glob()> doesn't work right. 266 267 sub _globdir { 268 local *DIRH; 269 270 opendir DIRH, shift; 271 my @f = readdir DIRH; 272 closedir DIRH; 273 274 return @f; 275 } 276 277 =head2 execute_tests( tests => \@test_files, out => \*FH ) 278 279 Runs all the given C<@test_files> (just like C<runtests()>) but 280 doesn't generate the final report. During testing, progress 281 information will be written to the currently selected output 282 filehandle (usually C<STDOUT>), or to the filehandle given by the 283 C<out> parameter. The I<out> is optional. 284 285 Returns a list of two values, C<$total> and C<$failed>, describing the 286 results. C<$total> is a hash ref summary of all the tests run. Its 287 keys and values are this: 288 289 bonus Number of individual todo tests unexpectedly passed 290 max Number of individual tests ran 291 ok Number of individual tests passed 292 sub_skipped Number of individual tests skipped 293 todo Number of individual todo tests 294 295 files Number of test files ran 296 good Number of test files passed 297 bad Number of test files failed 298 tests Number of test files originally given 299 skipped Number of test files skipped 300 301 If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've 302 got a successful test. 303 304 C<$failed> is a hash ref of all the test scripts that failed. Each key 305 is the name of a test script, each value is another hash representing 306 how that script failed. Its keys are these: 307 308 name Name of the test which failed 309 estat Script's exit value 310 wstat Script's wait status 311 max Number of individual tests 312 failed Number which failed 313 canon List of tests which failed (as string). 314 315 C<$failed> should be empty if everything passed. 316 317 =cut 318 319 sub execute_tests { 320 my %args = @_; 321 my @tests = @{$args{tests}}; 322 my $out = $args{out} || select(); 323 324 # We allow filehandles that are symbolic refs 325 no strict 'refs'; 326 _autoflush($out); 327 _autoflush(\*STDERR); 328 329 my %failedtests; 330 my %todo_passed; 331 332 # Test-wide totals. 333 my(%tot) = ( 334 bonus => 0, 335 max => 0, 336 ok => 0, 337 files => 0, 338 bad => 0, 339 good => 0, 340 tests => scalar @tests, 341 sub_skipped => 0, 342 todo => 0, 343 skipped => 0, 344 bench => 0, 345 ); 346 347 my @dir_files; 348 @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir; 349 my $run_start_time = new Benchmark; 350 351 my $width = _leader_width(@tests); 352 foreach my $tfile (@tests) { 353 $Last_ML_Print = 0; # so each test prints at least once 354 my($leader, $ml) = _mk_leader($tfile, $width); 355 local $ML = $ml; 356 357 print $out $leader; 358 359 $tot{files}++; 360 361 $Strap->{_seen_header} = 0; 362 if ( $Test::Harness::Debug ) { 363 print $out "# Running: ", $Strap->_command_line($tfile), "\n"; 364 } 365 my $test_start_time = $Timer ? time : 0; 366 my $results = $Strap->analyze_file($tfile) or 367 do { warn $Strap->{error}, "\n"; next }; 368 my $elapsed; 369 if ( $Timer ) { 370 $elapsed = time - $test_start_time; 371 if ( $has_time_hires ) { 372 $elapsed = sprintf( " %8d ms", $elapsed*1000 ); 373 } 374 else { 375 $elapsed = sprintf( " %8s s", $elapsed ? $elapsed : "<1" ); 376 } 377 } 378 else { 379 $elapsed = ""; 380 } 381 382 # state of the current test. 383 my @failed = grep { !$results->details->[$_-1]{ok} } 384 1..@{$results->details}; 385 my @todo_pass = grep { $results->details->[$_-1]{actual_ok} && 386 $results->details->[$_-1]{type} eq 'todo' } 387 1..@{$results->details}; 388 389 my %test = ( 390 ok => $results->ok, 391 'next' => $Strap->{'next'}, 392 max => $results->max, 393 failed => \@failed, 394 todo_pass => \@todo_pass, 395 todo => $results->todo, 396 bonus => $results->bonus, 397 skipped => $results->skip, 398 skip_reason => $results->skip_reason, 399 skip_all => $Strap->{skip_all}, 400 ml => $ml, 401 ); 402 403 $tot{bonus} += $results->bonus; 404 $tot{max} += $results->max; 405 $tot{ok} += $results->ok; 406 $tot{todo} += $results->todo; 407 $tot{sub_skipped} += $results->skip; 408 409 my $estatus = $results->exit; 410 my $wstatus = $results->wait; 411 412 if ( $results->passing ) { 413 # XXX Combine these first two 414 if ($test{max} and $test{skipped} + $test{bonus}) { 415 my @msg; 416 push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}") 417 if $test{skipped}; 418 if ($test{bonus}) { 419 my ($txt, $canon) = _canondetail($test{todo},0,'TODO passed', 420 @{$test{todo_pass}}); 421 $todo_passed{$tfile} = { 422 canon => $canon, 423 max => $test{todo}, 424 failed => $test{bonus}, 425 name => $tfile, 426 estat => '', 427 wstat => '', 428 }; 429 430 push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded\n$txt"); 431 } 432 print $out "$test{ml}ok$elapsed\n ".join(', ', @msg)."\n"; 433 } 434 elsif ( $test{max} ) { 435 print $out "$test{ml}ok$elapsed\n"; 436 } 437 elsif ( defined $test{skip_all} and length $test{skip_all} ) { 438 print $out "skipped\n all skipped: $test{skip_all}\n"; 439 $tot{skipped}++; 440 } 441 else { 442 print $out "skipped\n all skipped: no reason given\n"; 443 $tot{skipped}++; 444 } 445 $tot{good}++; 446 } 447 else { 448 # List unrun tests as failures. 449 if ($test{'next'} <= $test{max}) { 450 push @{$test{failed}}, $test{'next'}..$test{max}; 451 } 452 # List overruns as failures. 453 else { 454 my $details = $results->details; 455 foreach my $overrun ($test{max}+1..@$details) { 456 next unless ref $details->[$overrun-1]; 457 push @{$test{failed}}, $overrun 458 } 459 } 460 461 if ($wstatus) { 462 $failedtests{$tfile} = _dubious_return(\%test, \%tot, 463 $estatus, $wstatus); 464 $failedtests{$tfile}{name} = $tfile; 465 } 466 elsif ( $results->seen ) { 467 if (@{$test{failed}} and $test{max}) { 468 my ($txt, $canon) = _canondetail($test{max},$test{skipped},'Failed', 469 @{$test{failed}}); 470 print $out "$test{ml}$txt"; 471 $failedtests{$tfile} = { canon => $canon, 472 max => $test{max}, 473 failed => scalar @{$test{failed}}, 474 name => $tfile, 475 estat => '', 476 wstat => '', 477 }; 478 } 479 else { 480 print $out "Don't know which tests failed: got $test{ok} ok, ". 481 "expected $test{max}\n"; 482 $failedtests{$tfile} = { canon => '??', 483 max => $test{max}, 484 failed => '??', 485 name => $tfile, 486 estat => '', 487 wstat => '', 488 }; 489 } 490 $tot{bad}++; 491 } 492 else { 493 print $out "FAILED before any test output arrived\n"; 494 $tot{bad}++; 495 $failedtests{$tfile} = { canon => '??', 496 max => '??', 497 failed => '??', 498 name => $tfile, 499 estat => '', 500 wstat => '', 501 }; 502 } 503 } 504 505 if (defined $Files_In_Dir) { 506 my @new_dir_files = _globdir $Files_In_Dir; 507 if (@new_dir_files != @dir_files) { 508 my %f; 509 @f{@new_dir_files} = (1) x @new_dir_files; 510 delete @f{@dir_files}; 511 my @f = sort keys %f; 512 print $out "LEAKED FILES: @f\n"; 513 @dir_files = @new_dir_files; 514 } 515 } 516 } # foreach test 517 $tot{bench} = timediff(new Benchmark, $run_start_time); 518 519 $Strap->_restore_PERL5LIB; 520 521 return(\%tot, \%failedtests, \%todo_passed); 522 } 523 524 # Turns on autoflush for the handle passed 525 sub _autoflush { 526 my $flushy_fh = shift; 527 my $old_fh = select $flushy_fh; 528 $| = 1; 529 select $old_fh; 530 } 531 532 =for private _mk_leader 533 534 my($leader, $ml) = _mk_leader($test_file, $width); 535 536 Generates the 't/foo........' leader for the given C<$test_file> as well 537 as a similar version which will overwrite the current line (by use of 538 \r and such). C<$ml> may be empty if Test::Harness doesn't think you're 539 on TTY. 540 541 The C<$width> is the width of the "yada/blah.." string. 542 543 =cut 544 545 sub _mk_leader { 546 my($te, $width) = @_; 547 chomp($te); 548 $te =~ s/\.\w+$/./; 549 550 if ($^O eq 'VMS') { 551 $te =~ s/^.*\.t\./\[.t./s; 552 } 553 my $leader = "$te" . '.' x ($width - length($te)); 554 my $ml = ""; 555 556 if ( -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose ) { 557 $ml = "\r" . (' ' x 77) . "\r$leader" 558 } 559 560 return($leader, $ml); 561 } 562 563 =for private _leader_width 564 565 my($width) = _leader_width(@test_files); 566 567 Calculates how wide the leader should be based on the length of the 568 longest test name. 569 570 =cut 571 572 sub _leader_width { 573 my $maxlen = 0; 574 my $maxsuflen = 0; 575 foreach (@_) { 576 my $suf = /\.(\w+)$/ ? $1 : ''; 577 my $len = length; 578 my $suflen = length $suf; 579 $maxlen = $len if $len > $maxlen; 580 $maxsuflen = $suflen if $suflen > $maxsuflen; 581 } 582 # + 3 : we want three dots between the test name and the "ok" 583 return $maxlen + 3 - $maxsuflen; 584 } 585 586 sub get_results { 587 my $tot = shift; 588 my $failedtests = shift; 589 my $todo_passed = shift; 590 591 my $out = ''; 592 593 my $bonusmsg = _bonusmsg($tot); 594 595 if (_all_ok($tot)) { 596 $out .= "All tests successful$bonusmsg.\n"; 597 if ($tot->{bonus}) { 598 my($fmt_top, $fmt) = _create_fmts("Passed TODO",$todo_passed); 599 # Now write to formats 600 $out .= swrite( $fmt_top ); 601 for my $script (sort keys %{$todo_passed||{}}) { 602 my $Curtest = $todo_passed->{$script}; 603 $out .= swrite( $fmt, @{ $Curtest }{qw(name estat wstat max failed canon)} ); 604 } 605 } 606 } 607 elsif (!$tot->{tests}){ 608 die "FAILED--no tests were run for some reason.\n"; 609 } 610 elsif (!$tot->{max}) { 611 my $blurb = $tot->{tests}==1 ? "script" : "scripts"; 612 die "FAILED--$tot->{tests} test $blurb could be run, ". 613 "alas--no output ever seen\n"; 614 } 615 else { 616 my $subresults = sprintf( " %d/%d subtests failed.", 617 $tot->{max} - $tot->{ok}, $tot->{max} ); 618 619 my($fmt_top, $fmt1, $fmt2) = _create_fmts("Failed Test",$failedtests); 620 621 # Now write to formats 622 $out .= swrite( $fmt_top ); 623 for my $script (sort keys %$failedtests) { 624 my $Curtest = $failedtests->{$script}; 625 $out .= swrite( $fmt1, @{ $Curtest }{qw(name estat wstat max failed canon)} ); 626 $out .= swrite( $fmt2, $Curtest->{canon} ); 627 } 628 if ($tot->{bad}) { 629 $bonusmsg =~ s/^,\s*//; 630 $out .= "$bonusmsg.\n" if $bonusmsg; 631 $out .= "Failed $tot->{bad}/$tot->{tests} test scripts.$subresults\n"; 632 } 633 } 634 635 $out .= sprintf("Files=%d, Tests=%d, %s\n", 636 $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop')); 637 return $out; 638 } 639 640 sub swrite { 641 my $format = shift; 642 $^A = ''; 643 formline($format,@_); 644 my $out = $^A; 645 $^A = ''; 646 return $out; 647 } 648 649 650 my %Handlers = ( 651 header => \&header_handler, 652 test => \&test_handler, 653 bailout => \&bailout_handler, 654 ); 655 656 $Strap->set_callback(\&strap_callback); 657 sub strap_callback { 658 my($self, $line, $type, $totals) = @_; 659 print $line if $Verbose; 660 661 my $meth = $Handlers{$type}; 662 $meth->($self, $line, $type, $totals) if $meth; 663 }; 664 665 666 sub header_handler { 667 my($self, $line, $type, $totals) = @_; 668 669 warn "Test header seen more than once!\n" if $self->{_seen_header}; 670 671 $self->{_seen_header}++; 672 673 warn "1..M can only appear at the beginning or end of tests\n" 674 if $totals->seen && ($totals->max < $totals->seen); 675 }; 676 677 sub test_handler { 678 my($self, $line, $type, $totals) = @_; 679 680 my $curr = $totals->seen; 681 my $next = $self->{'next'}; 682 my $max = $totals->max; 683 my $detail = $totals->details->[-1]; 684 685 if( $detail->{ok} ) { 686 _print_ml_less("ok $curr/$max"); 687 688 if( $detail->{type} eq 'skip' ) { 689 $totals->set_skip_reason( $detail->{reason} ) 690 unless defined $totals->skip_reason; 691 $totals->set_skip_reason( 'various reasons' ) 692 if $totals->skip_reason ne $detail->{reason}; 693 } 694 } 695 else { 696 _print_ml("NOK $curr/$max"); 697 } 698 699 if( $curr > $next ) { 700 print "Test output counter mismatch [test $curr]\n"; 701 } 702 elsif( $curr < $next ) { 703 print "Confused test output: test $curr answered after ". 704 "test ", $next - 1, "\n"; 705 } 706 707 }; 708 709 sub bailout_handler { 710 my($self, $line, $type, $totals) = @_; 711 712 die "FAILED--Further testing stopped" . 713 ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n"); 714 }; 715 716 717 sub _print_ml { 718 print join '', $ML, @_ if $ML; 719 } 720 721 722 # Print updates only once per second. 723 sub _print_ml_less { 724 my $now = CORE::time; 725 if ( $Last_ML_Print != $now ) { 726 _print_ml(@_); 727 $Last_ML_Print = $now; 728 } 729 } 730 731 sub _bonusmsg { 732 my($tot) = @_; 733 734 my $bonusmsg = ''; 735 $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : ''). 736 " UNEXPECTEDLY SUCCEEDED)") 737 if $tot->{bonus}; 738 739 if ($tot->{skipped}) { 740 $bonusmsg .= ", $tot->{skipped} test" 741 . ($tot->{skipped} != 1 ? 's' : ''); 742 if ($tot->{sub_skipped}) { 743 $bonusmsg .= " and $tot->{sub_skipped} subtest" 744 . ($tot->{sub_skipped} != 1 ? 's' : ''); 745 } 746 $bonusmsg .= ' skipped'; 747 } 748 elsif ($tot->{sub_skipped}) { 749 $bonusmsg .= ", $tot->{sub_skipped} subtest" 750 . ($tot->{sub_skipped} != 1 ? 's' : '') 751 . " skipped"; 752 } 753 return $bonusmsg; 754 } 755 756 # Test program go boom. 757 sub _dubious_return { 758 my($test, $tot, $estatus, $wstatus) = @_; 759 760 my $failed = '??'; 761 my $canon = '??'; 762 763 printf "$test->{ml}dubious\n\tTest returned status $estatus ". 764 "(wstat %d, 0x%x)\n", 765 $wstatus,$wstatus; 766 print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; 767 768 $tot->{bad}++; 769 770 if ($test->{max}) { 771 if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) { 772 print "\tafter all the subtests completed successfully\n"; 773 $failed = 0; # But we do not set $canon! 774 } 775 else { 776 push @{$test->{failed}}, $test->{'next'}..$test->{max}; 777 $failed = @{$test->{failed}}; 778 (my $txt, $canon) = _canondetail($test->{max},$test->{skipped},'Failed',@{$test->{failed}}); 779 print "DIED. ",$txt; 780 } 781 } 782 783 return { canon => $canon, max => $test->{max} || '??', 784 failed => $failed, 785 estat => $estatus, wstat => $wstatus, 786 }; 787 } 788 789 790 sub _create_fmts { 791 my $failed_str = shift; 792 my $failedtests = shift; 793 794 my ($type) = split /\s/,$failed_str; 795 my $short = substr($type,0,4); 796 my $total = $short eq 'Pass' ? 'TODOs' : 'Total'; 797 my $middle_str = " Stat Wstat $total $short "; 798 my $list_str = "List of $type"; 799 800 # Figure out our longest name string for formatting purposes. 801 my $max_namelen = length($failed_str); 802 foreach my $script (keys %$failedtests) { 803 my $namelen = length $failedtests->{$script}->{name}; 804 $max_namelen = $namelen if $namelen > $max_namelen; 805 } 806 807 my $list_len = $Columns - length($middle_str) - $max_namelen; 808 if ($list_len < length($list_str)) { 809 $list_len = length($list_str); 810 $max_namelen = $Columns - length($middle_str) - $list_len; 811 if ($max_namelen < length($failed_str)) { 812 $max_namelen = length($failed_str); 813 $Columns = $max_namelen + length($middle_str) + $list_len; 814 } 815 } 816 817 my $fmt_top = sprintf("%-$max_namelen}s", $failed_str) 818 . $middle_str 819 . $list_str . "\n" 820 . "-" x $Columns 821 . "\n"; 822 823 my $fmt1 = "@" . "<" x ($max_namelen - 1) 824 . " @>> @>>>> @>>>> @>>> " 825 . "^" . "<" x ($list_len - 1) . "\n"; 826 my $fmt2 = "~~" . " " x ($Columns - $list_len - 2) . "^" 827 . "<" x ($list_len - 1) . "\n"; 828 829 return($fmt_top, $fmt1, $fmt2); 830 } 831 832 sub _canondetail { 833 my $max = shift; 834 my $skipped = shift; 835 my $type = shift; 836 my @detail = @_; 837 my %seen; 838 @detail = sort {$a <=> $b} grep !$seen{$_}++, @detail; 839 my $detail = @detail; 840 my @result = (); 841 my @canon = (); 842 my $min; 843 my $last = $min = shift @detail; 844 my $canon; 845 my $uc_type = uc($type); 846 if (@detail) { 847 for (@detail, $detail[-1]) { # don't forget the last one 848 if ($_ > $last+1 || $_ == $last) { 849 push @canon, ($min == $last) ? $last : "$min-$last"; 850 $min = $_; 851 } 852 $last = $_; 853 } 854 local $" = ", "; 855 push @result, "$uc_type tests @canon\n"; 856 $canon = join ' ', @canon; 857 } 858 else { 859 push @result, "$uc_type test $last\n"; 860 $canon = $last; 861 } 862 863 return (join("", @result), $canon) 864 if $type=~/todo/i; 865 push @result, "\t$type $detail/$max tests, "; 866 if ($max) { 867 push @result, sprintf("%.2f",100*(1-$detail/$max)), "% okay"; 868 } 869 else { 870 push @result, "?% okay"; 871 } 872 my $ender = 's' x ($skipped > 1); 873 if ($skipped) { 874 my $good = $max - $detail - $skipped; 875 my $skipmsg = " (less $skipped skipped test$ender: $good okay, "; 876 if ($max) { 877 my $goodper = sprintf("%.2f",100*($good/$max)); 878 $skipmsg .= "$goodper%)"; 879 } 880 else { 881 $skipmsg .= "?%)"; 882 } 883 push @result, $skipmsg; 884 } 885 push @result, "\n"; 886 my $txt = join "", @result; 887 return ($txt, $canon); 888 } 889 890 1; 891 __END__ 892 893 894 =head1 EXPORT 895 896 C<&runtests> is exported by Test::Harness by default. 897 898 C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are 899 exported upon request. 900 901 =head1 DIAGNOSTICS 902 903 =over 4 904 905 =item C<All tests successful.\nFiles=%d, Tests=%d, %s> 906 907 If all tests are successful some statistics about the performance are 908 printed. 909 910 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.> 911 912 For any single script that has failing subtests statistics like the 913 above are printed. 914 915 =item C<Test returned status %d (wstat %d)> 916 917 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> 918 and C<$?> are printed in a message similar to the above. 919 920 =item C<Failed 1 test, %.2f%% okay. %s> 921 922 =item C<Failed %d/%d tests, %.2f%% okay. %s> 923 924 If not all tests were successful, the script dies with one of the 925 above messages. 926 927 =item C<FAILED--Further testing stopped: %s> 928 929 If a single subtest decides that further testing will not make sense, 930 the script dies with this message. 931 932 =back 933 934 =head1 ENVIRONMENT VARIABLES THAT TEST::HARNESS SETS 935 936 Test::Harness sets these before executing the individual tests. 937 938 =over 4 939 940 =item C<HARNESS_ACTIVE> 941 942 This is set to a true value. It allows the tests to determine if they 943 are being executed through the harness or by any other means. 944 945 =item C<HARNESS_VERSION> 946 947 This is the version of Test::Harness. 948 949 =back 950 951 =head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS 952 953 =over 4 954 955 =item C<HARNESS_COLUMNS> 956 957 This value will be used for the width of the terminal. If it is not 958 set then it will default to C<COLUMNS>. If this is not set, it will 959 default to 80. Note that users of Bourne-sh based shells will need to 960 C<export COLUMNS> for this module to use that variable. 961 962 =item C<HARNESS_COMPILE_TEST> 963 964 When true it will make harness attempt to compile the test using 965 C<perlcc> before running it. 966 967 B<NOTE> This currently only works when sitting in the perl source 968 directory! 969 970 =item C<HARNESS_DEBUG> 971 972 If true, Test::Harness will print debugging information about itself as 973 it runs the tests. This is different from C<HARNESS_VERBOSE>, which prints 974 the output from the test being run. Setting C<$Test::Harness::Debug> will 975 override this, or you can use the C<-d> switch in the F<prove> utility. 976 977 =item C<HARNESS_FILELEAK_IN_DIR> 978 979 When set to the name of a directory, harness will check after each 980 test whether new files appeared in that directory, and report them as 981 982 LEAKED FILES: scr.tmp 0 my.db 983 984 If relative, directory name is with respect to the current directory at 985 the moment runtests() was called. Putting absolute path into 986 C<HARNESS_FILELEAK_IN_DIR> may give more predictable results. 987 988 =item C<HARNESS_NOTTY> 989 990 When set to a true value, forces it to behave as though STDOUT were 991 not a console. You may need to set this if you don't want harness to 992 output more frequent progress messages using carriage returns. Some 993 consoles may not handle carriage returns properly (which results in a 994 somewhat messy output). 995 996 =item C<HARNESS_PERL> 997 998 Usually your tests will be run by C<$^X>, the currently-executing Perl. 999 However, you may want to have it run by a different executable, such as 1000 a threading perl, or a different version. 1001 1002 If you're using the F<prove> utility, you can use the C<--perl> switch. 1003 1004 =item C<HARNESS_PERL_SWITCHES> 1005 1006 Its value will be prepended to the switches used to invoke perl on 1007 each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will 1008 run all tests with all warnings enabled. 1009 1010 =item C<HARNESS_TIMER> 1011 1012 Setting this to true will make the harness display the number of 1013 milliseconds each test took. You can also use F<prove>'s C<--timer> 1014 switch. 1015 1016 =item C<HARNESS_VERBOSE> 1017 1018 If true, Test::Harness will output the verbose results of running 1019 its tests. Setting C<$Test::Harness::verbose> will override this, 1020 or you can use the C<-v> switch in the F<prove> utility. 1021 1022 If true, Test::Harness will output the verbose results of running 1023 its tests. Setting C<$Test::Harness::verbose> will override this, 1024 or you can use the C<-v> switch in the F<prove> utility. 1025 1026 =item C<HARNESS_STRAP_CLASS> 1027 1028 Defines the Test::Harness::Straps subclass to use. The value may either 1029 be a filename or a class name. 1030 1031 If HARNESS_STRAP_CLASS is a class name, the class must be in C<@INC> 1032 like any other class. 1033 1034 If HARNESS_STRAP_CLASS is a filename, the .pm file must return the name 1035 of the class, instead of the canonical "1". 1036 1037 =back 1038 1039 =head1 EXAMPLE 1040 1041 Here's how Test::Harness tests itself 1042 1043 $ cd ~/src/devel/Test-Harness 1044 $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose); 1045 $verbose=0; runtests @ARGV;' t/*.t 1046 Using /home/schwern/src/devel/Test-Harness/blib 1047 t/base..............ok 1048 t/nonumbers.........ok 1049 t/ok................ok 1050 t/test-harness......ok 1051 All tests successful. 1052 Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU) 1053 1054 =head1 SEE ALSO 1055 1056 The included F<prove> utility for running test scripts from the command line, 1057 L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for 1058 the underlying timing routines, and L<Devel::Cover> for test coverage 1059 analysis. 1060 1061 =head1 TODO 1062 1063 Provide a way of running tests quietly (ie. no printing) for automated 1064 validation of tests. This will probably take the form of a version 1065 of runtests() which rather than printing its output returns raw data 1066 on the state of the tests. (Partially done in Test::Harness::Straps) 1067 1068 Document the format. 1069 1070 Fix HARNESS_COMPILE_TEST without breaking its core usage. 1071 1072 Figure a way to report test names in the failure summary. 1073 1074 Rework the test summary so long test names are not truncated as badly. 1075 (Partially done with new skip test styles) 1076 1077 Add option for coverage analysis. 1078 1079 Trap STDERR. 1080 1081 Implement Straps total_results() 1082 1083 Remember exit code 1084 1085 Completely redo the print summary code. 1086 1087 Straps->analyze_file() not taint clean, don't know if it can be 1088 1089 Fix that damned VMS nit. 1090 1091 Add a test for verbose. 1092 1093 Change internal list of test results to a hash. 1094 1095 Fix stats display when there's an overrun. 1096 1097 Fix so perls with spaces in the filename work. 1098 1099 Keeping whittling away at _run_all_tests() 1100 1101 Clean up how the summary is printed. Get rid of those damned formats. 1102 1103 =head1 BUGS 1104 1105 Please report any bugs or feature requests to 1106 C<bug-test-harness at rt.cpan.org>, or through the web interface at 1107 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. 1108 I will be notified, and then you'll automatically be notified of progress on 1109 your bug as I make changes. 1110 1111 =head1 SUPPORT 1112 1113 You can find documentation for this module with the F<perldoc> command. 1114 1115 perldoc Test::Harness 1116 1117 You can get docs for F<prove> with 1118 1119 prove --man 1120 1121 You can also look for information at: 1122 1123 =over 4 1124 1125 =item * AnnoCPAN: Annotated CPAN documentation 1126 1127 L<http://annocpan.org/dist/Test-Harness> 1128 1129 =item * CPAN Ratings 1130 1131 L<http://cpanratings.perl.org/d/Test-Harness> 1132 1133 =item * RT: CPAN's request tracker 1134 1135 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Harness> 1136 1137 =item * Search CPAN 1138 1139 L<http://search.cpan.org/dist/Test-Harness> 1140 1141 =back 1142 1143 =head1 SOURCE CODE 1144 1145 The source code repository for Test::Harness is at 1146 L<http://svn.perl.org/modules/Test-Harness>. 1147 1148 =head1 AUTHORS 1149 1150 Either Tim Bunce or Andreas Koenig, we don't know. What we know for 1151 sure is, that it was inspired by Larry Wall's F<TEST> script that came 1152 with perl distributions for ages. Numerous anonymous contributors 1153 exist. Andreas Koenig held the torch for many years, and then 1154 Michael G Schwern. 1155 1156 Current maintainer is Andy Lester C<< <andy at petdance.com> >>. 1157 1158 =head1 COPYRIGHT 1159 1160 Copyright 2002-2006 1161 by Michael G Schwern C<< <schwern at pobox.com> >>, 1162 Andy Lester C<< <andy at petdance.com> >>. 1163 1164 This program is free software; you can redistribute it and/or 1165 modify it under the same terms as Perl itself. 1166 1167 See L<http://www.perl.com/perl/misc/Artistic.html>. 1168 1169 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |