1package Test::Harness; 2 3require 5.00405; 4 5use strict; 6 7use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); 8use constant IS_VMS => ( $^O eq 'VMS' ); 9 10use TAP::Harness (); 11use TAP::Parser::Aggregator (); 12use TAP::Parser::Source (); 13use TAP::Parser::SourceHandler::Perl (); 14 15use TAP::Parser::Utils qw( split_shell ); 16 17use Config; 18use Exporter; 19 20# TODO: Emulate at least some of these 21use vars qw( 22 $VERSION 23 @ISA @EXPORT @EXPORT_OK 24 $Verbose $Switches $Debug 25 $verbose $switches $debug 26 $Columns 27 $Color 28 $Directives 29 $Timer 30 $Strap 31 $HarnessSubclass 32 $has_time_hires 33 $IgnoreExit 34); 35 36# $ML $Last_ML_Print 37 38BEGIN { 39 eval q{use Time::HiRes 'time'}; 40 $has_time_hires = !$@; 41} 42 43=head1 NAME 44 45Test::Harness - Run Perl standard test scripts with statistics 46 47=head1 VERSION 48 49Version 3.26 50 51=cut 52 53$VERSION = '3.26'; 54 55# Backwards compatibility for exportable variable names. 56*verbose = *Verbose; 57*switches = *Switches; 58*debug = *Debug; 59 60$ENV{HARNESS_ACTIVE} = 1; 61$ENV{HARNESS_VERSION} = $VERSION; 62 63END { 64 65 # For VMS. 66 delete $ENV{HARNESS_ACTIVE}; 67 delete $ENV{HARNESS_VERSION}; 68} 69 70@ISA = ('Exporter'); 71@EXPORT = qw(&runtests); 72@EXPORT_OK = qw(&execute_tests $verbose $switches); 73 74$Verbose = $ENV{HARNESS_VERBOSE} || 0; 75$Debug = $ENV{HARNESS_DEBUG} || 0; 76$Switches = ''; 77$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; 78$Columns--; # Some shells have trouble with a full line of text. 79$Timer = $ENV{HARNESS_TIMER} || 0; 80$Color = $ENV{HARNESS_COLOR} || 0; 81$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0; 82 83=head1 SYNOPSIS 84 85 use Test::Harness; 86 87 runtests(@test_files); 88 89=head1 DESCRIPTION 90 91Although, for historical reasons, the L<Test::Harness> distribution 92takes its name from this module it now exists only to provide 93L<TAP::Harness> with an interface that is somewhat backwards compatible 94with L<Test::Harness> 2.xx. If you're writing new code consider using 95L<TAP::Harness> directly instead. 96 97Emulation is provided for C<runtests> and C<execute_tests> but the 98pluggable 'Straps' interface that previous versions of L<Test::Harness> 99supported is not reproduced here. Straps is now available as a stand 100alone module: L<Test::Harness::Straps>. 101 102See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this 103distribution. 104 105=head1 FUNCTIONS 106 107The following functions are available. 108 109=head2 runtests( @test_files ) 110 111This runs all the given I<@test_files> and divines whether they passed 112or failed based on their output to STDOUT (details above). It prints 113out each individual test which failed along with a summary report and 114a how long it all took. 115 116It returns true if everything was ok. Otherwise it will C<die()> with 117one of the messages in the DIAGNOSTICS section. 118 119=cut 120 121sub _has_taint { 122 my $test = shift; 123 return TAP::Parser::SourceHandler::Perl->get_taint( 124 TAP::Parser::Source->shebang($test) ); 125} 126 127sub _aggregate { 128 my ( $harness, $aggregate, @tests ) = @_; 129 130 # Don't propagate to our children 131 local $ENV{HARNESS_OPTIONS}; 132 133 _apply_extra_INC($harness); 134 _aggregate_tests( $harness, $aggregate, @tests ); 135} 136 137# Make sure the child sees all the extra junk in @INC 138sub _apply_extra_INC { 139 my $harness = shift; 140 141 $harness->callback( 142 parser_args => sub { 143 my ( $args, $test ) = @_; 144 push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); 145 } 146 ); 147} 148 149sub _aggregate_tests { 150 my ( $harness, $aggregate, @tests ) = @_; 151 $aggregate->start(); 152 $harness->aggregate_tests( $aggregate, @tests ); 153 $aggregate->stop(); 154 155} 156 157sub runtests { 158 my @tests = @_; 159 160 # shield against -l 161 local ( $\, $, ); 162 163 my $harness = _new_harness(); 164 my $aggregate = TAP::Parser::Aggregator->new(); 165 166 _aggregate( $harness, $aggregate, @tests ); 167 168 $harness->formatter->summary($aggregate); 169 170 my $total = $aggregate->total; 171 my $passed = $aggregate->passed; 172 my $failed = $aggregate->failed; 173 174 my @parsers = $aggregate->parsers; 175 176 my $num_bad = 0; 177 for my $parser (@parsers) { 178 $num_bad++ if $parser->has_problems; 179 } 180 181 die(sprintf( 182 "Failed %d/%d test programs. %d/%d subtests failed.\n", 183 $num_bad, scalar @parsers, $failed, $total 184 ) 185 ) if $num_bad; 186 187 return $total && $total == $passed; 188} 189 190sub _canon { 191 my @list = sort { $a <=> $b } @_; 192 my @ranges = (); 193 my $count = scalar @list; 194 my $pos = 0; 195 196 while ( $pos < $count ) { 197 my $end = $pos + 1; 198 $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1; 199 push @ranges, ( $end == $pos + 1 ) 200 ? $list[$pos] 201 : join( '-', $list[$pos], $list[ $end - 1 ] ); 202 $pos = $end; 203 } 204 205 return join( ' ', @ranges ); 206} 207 208sub _new_harness { 209 my $sub_args = shift || {}; 210 211 my ( @lib, @switches ); 212 my @opt = split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ); 213 while ( my $opt = shift @opt ) { 214 if ( $opt =~ /^ -I (.*) $ /x ) { 215 push @lib, length($1) ? $1 : shift @opt; 216 } 217 else { 218 push @switches, $opt; 219 } 220 } 221 222 # Do things the old way on VMS... 223 push @lib, _filtered_inc() if IS_VMS; 224 225 # If $Verbose isn't numeric default to 1. This helps core. 226 my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 ); 227 228 my $args = { 229 timer => $Timer, 230 directives => $Directives, 231 lib => \@lib, 232 switches => \@switches, 233 color => $Color, 234 verbosity => $verbosity, 235 ignore_exit => $IgnoreExit, 236 }; 237 238 $args->{stdout} = $sub_args->{out} 239 if exists $sub_args->{out}; 240 241 my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; 242 if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { 243 for my $opt ( split /:/, $env_opt ) { 244 if ( $opt =~ /^j(\d*)$/ ) { 245 $args->{jobs} = $1 || 9; 246 } 247 elsif ( $opt eq 'c' ) { 248 $args->{color} = 1; 249 } 250 elsif ( $opt =~ m/^f(.*)$/ ) { 251 my $fmt = $1; 252 $fmt =~ s/-/::/g; 253 $args->{formatter_class} = $fmt; 254 } 255 elsif ( $opt =~ m/^a(.*)$/ ) { 256 my $archive = $1; 257 $class = "TAP::Harness::Archive"; 258 $args->{archive} = $archive; 259 } 260 else { 261 die "Unknown HARNESS_OPTIONS item: $opt\n"; 262 } 263 } 264 } 265 266 return TAP::Harness->_construct( $class, $args ); 267} 268 269# Get the parts of @INC which are changed from the stock list AND 270# preserve reordering of stock directories. 271sub _filtered_inc { 272 my @inc = grep { !ref } @INC; #28567 273 274 if (IS_VMS) { 275 276 # VMS has a 255-byte limit on the length of %ENV entries, so 277 # toss the ones that involve perl_root, the install location 278 @inc = grep !/perl_root/i, @inc; 279 280 } 281 elsif (IS_WIN32) { 282 283 # Lose any trailing backslashes in the Win32 paths 284 s/[\\\/]+$// for @inc; 285 } 286 287 my @default_inc = _default_inc(); 288 289 my @new_inc; 290 my %seen; 291 for my $dir (@inc) { 292 next if $seen{$dir}++; 293 294 if ( $dir eq ( $default_inc[0] || '' ) ) { 295 shift @default_inc; 296 } 297 else { 298 push @new_inc, $dir; 299 } 300 301 shift @default_inc while @default_inc and $seen{ $default_inc[0] }; 302 } 303 304 return @new_inc; 305} 306 307{ 308 309 # Cache this to avoid repeatedly shelling out to Perl. 310 my @inc; 311 312 sub _default_inc { 313 return @inc if @inc; 314 315 local $ENV{PERL5LIB}; 316 local $ENV{PERLLIB}; 317 318 my $perl = $ENV{HARNESS_PERL} || $^X; 319 320 # Avoid using -l for the benefit of Perl 6 321 chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` ); 322 return @inc; 323 } 324} 325 326sub _check_sequence { 327 my @list = @_; 328 my $prev; 329 while ( my $next = shift @list ) { 330 return if defined $prev && $next <= $prev; 331 $prev = $next; 332 } 333 334 return 1; 335} 336 337sub execute_tests { 338 my %args = @_; 339 340 my $harness = _new_harness( \%args ); 341 my $aggregate = TAP::Parser::Aggregator->new(); 342 343 my %tot = ( 344 bonus => 0, 345 max => 0, 346 ok => 0, 347 bad => 0, 348 good => 0, 349 files => 0, 350 tests => 0, 351 sub_skipped => 0, 352 todo => 0, 353 skipped => 0, 354 bench => undef, 355 ); 356 357 # Install a callback so we get to see any plans the 358 # harness executes. 359 $harness->callback( 360 made_parser => sub { 361 my $parser = shift; 362 $parser->callback( 363 plan => sub { 364 my $plan = shift; 365 if ( $plan->directive eq 'SKIP' ) { 366 $tot{skipped}++; 367 } 368 } 369 ); 370 } 371 ); 372 373 _aggregate( $harness, $aggregate, @{ $args{tests} } ); 374 375 $tot{bench} = $aggregate->elapsed; 376 my @tests = $aggregate->descriptions; 377 378 # TODO: Work out the circumstances under which the files 379 # and tests totals can differ. 380 $tot{files} = $tot{tests} = scalar @tests; 381 382 my %failedtests = (); 383 my %todo_passed = (); 384 385 for my $test (@tests) { 386 my ($parser) = $aggregate->parsers($test); 387 388 my @failed = $parser->failed; 389 390 my $wstat = $parser->wait; 391 my $estat = $parser->exit; 392 my $planned = $parser->tests_planned; 393 my @errors = $parser->parse_errors; 394 my $passed = $parser->passed; 395 my $actual_passed = $parser->actual_passed; 396 397 my $ok_seq = _check_sequence( $parser->actual_passed ); 398 399 # Duplicate exit, wait status semantics of old version 400 $estat ||= '' unless $wstat; 401 $wstat ||= ''; 402 403 $tot{max} += ( $planned || 0 ); 404 $tot{bonus} += $parser->todo_passed; 405 $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed; 406 $tot{sub_skipped} += $parser->skipped; 407 $tot{todo} += $parser->todo; 408 409 if ( @failed || $estat || @errors ) { 410 $tot{bad}++; 411 412 my $huh_planned = $planned ? undef : '??'; 413 my $huh_errors = $ok_seq ? undef : '??'; 414 415 $failedtests{$test} = { 416 'canon' => $huh_planned 417 || $huh_errors 418 || _canon(@failed) 419 || '??', 420 'estat' => $estat, 421 'failed' => $huh_planned 422 || $huh_errors 423 || scalar @failed, 424 'max' => $huh_planned || $planned, 425 'name' => $test, 426 'wstat' => $wstat 427 }; 428 } 429 else { 430 $tot{good}++; 431 } 432 433 my @todo = $parser->todo_passed; 434 if (@todo) { 435 $todo_passed{$test} = { 436 'canon' => _canon(@todo), 437 'estat' => $estat, 438 'failed' => scalar @todo, 439 'max' => scalar $parser->todo, 440 'name' => $test, 441 'wstat' => $wstat 442 }; 443 } 444 } 445 446 return ( \%tot, \%failedtests, \%todo_passed ); 447} 448 449=head2 execute_tests( tests => \@test_files, out => \*FH ) 450 451Runs all the given C<@test_files> (just like C<runtests()>) but 452doesn't generate the final report. During testing, progress 453information will be written to the currently selected output 454filehandle (usually C<STDOUT>), or to the filehandle given by the 455C<out> parameter. The I<out> is optional. 456 457Returns a list of two values, C<$total> and C<$failed>, describing the 458results. C<$total> is a hash ref summary of all the tests run. Its 459keys and values are this: 460 461 bonus Number of individual todo tests unexpectedly passed 462 max Number of individual tests ran 463 ok Number of individual tests passed 464 sub_skipped Number of individual tests skipped 465 todo Number of individual todo tests 466 467 files Number of test files ran 468 good Number of test files passed 469 bad Number of test files failed 470 tests Number of test files originally given 471 skipped Number of test files skipped 472 473If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've 474got a successful test. 475 476C<$failed> is a hash ref of all the test scripts that failed. Each key 477is the name of a test script, each value is another hash representing 478how that script failed. Its keys are these: 479 480 name Name of the test which failed 481 estat Script's exit value 482 wstat Script's wait status 483 max Number of individual tests 484 failed Number which failed 485 canon List of tests which failed (as string). 486 487C<$failed> should be empty if everything passed. 488 489=cut 490 4911; 492__END__ 493 494=head1 EXPORT 495 496C<&runtests> is exported by C<Test::Harness> by default. 497 498C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are 499exported upon request. 500 501=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS 502 503C<Test::Harness> sets these before executing the individual tests. 504 505=over 4 506 507=item C<HARNESS_ACTIVE> 508 509This is set to a true value. It allows the tests to determine if they 510are being executed through the harness or by any other means. 511 512=item C<HARNESS_VERSION> 513 514This is the version of C<Test::Harness>. 515 516=back 517 518=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS 519 520=over 4 521 522=item C<HARNESS_TIMER> 523 524Setting this to true will make the harness display the number of 525milliseconds each test took. You can also use F<prove>'s C<--timer> 526switch. 527 528=item C<HARNESS_VERBOSE> 529 530If true, C<Test::Harness> will output the verbose results of running 531its tests. Setting C<$Test::Harness::verbose> will override this, 532or you can use the C<-v> switch in the F<prove> utility. 533 534=item C<HARNESS_OPTIONS> 535 536Provide additional options to the harness. Currently supported options are: 537 538=over 539 540=item C<< j<n> >> 541 542Run <n> (default 9) parallel jobs. 543 544=item C<< c >> 545 546Try to color output. See L<TAP::Formatter::Base/"new">. 547 548=item C<< a<file.tgz> >> 549 550Will use L<TAP::Harness::Archive> as the harness class, and save the TAP to 551C<file.tgz> 552 553=item C<< fPackage-With-Dashes >> 554 555Set the formatter_class of the harness being run. Since the C<HARNESS_OPTIONS> 556is seperated by C<:>, we use C<-> instead. 557 558=back 559 560Multiple options may be separated by colons: 561 562 HARNESS_OPTIONS=j9:c make test 563 564=item C<HARNESS_SUBCLASS> 565 566Specifies a TAP::Harness subclass to be used in place of TAP::Harness. 567 568=back 569 570=head1 Taint Mode 571 572Normally when a Perl program is run in taint mode the contents of the 573C<PERL5LIB> environment variable do not appear in C<@INC>. 574 575Because C<PERL5LIB> is often used during testing to add build 576directories to C<@INC> C<Test::Harness> passes the names of any 577directories found in C<PERL5LIB> as -I switches. The net effect of this 578is that C<PERL5LIB> is honoured even in taint mode. 579 580=head1 SEE ALSO 581 582L<TAP::Harness> 583 584=head1 BUGS 585 586Please report any bugs or feature requests to 587C<bug-test-harness at rt.cpan.org>, or through the web interface at 588L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be 589notified, and then you'll automatically be notified of progress on your bug 590as I make changes. 591 592=head1 AUTHORS 593 594Andy Armstrong C<< <andy@hexten.net> >> 595 596L<Test::Harness> 2.64 (maintained by Andy Lester and on which this 597module is based) has this attribution: 598 599 Either Tim Bunce or Andreas Koenig, we don't know. What we know for 600 sure is, that it was inspired by Larry Wall's F<TEST> script that came 601 with perl distributions for ages. Numerous anonymous contributors 602 exist. Andreas Koenig held the torch for many years, and then 603 Michael G Schwern. 604 605=head1 LICENCE AND COPYRIGHT 606 607Copyright (c) 2007-2011, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved. 608 609This module is free software; you can redistribute it and/or 610modify it under the same terms as Perl itself. See L<perlartistic>. 611 612