lib/Test/Harness.pm

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