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