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.08
  45
  46 =cut
  47
  48 $VERSION = '3.08';
  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     my $sub_args = shift || {};
 223
 224     if ( defined( my $env_sw = $ENV{HARNESS_PERL_SWITCHES} ) ) {
 225         $Switches .= ' ' . $env_sw if ( length($env_sw) );
 226     }
 227
 228     # This is a bit crufty. The switches have all been joined into a
 229     # single string so we have to try and recover them.
 230     my ( @lib, @switches );
 231     for my $opt ( split( /\s+(?=-)/, $Switches ) ) {
 232         if ( $opt =~ /^ -I (.*) $ /x ) {
 233             push @lib, $1;
 234         }
 235         else {
 236             push @switches, $opt;
 237         }
 238     }
 239
 240     # Do things the old way on VMS...
 241     push @lib, _filtered_inc() if IS_VMS;
 242
 243     # If $Verbose isn't numeric default to 1. This helps core.
 244     my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
 245
 246     my $args = {
 247         timer      => $Timer,
 248         directives => $Directives,
 249         lib        => \@lib,
 250         switches   => \@switches,
 251         color      => $Color,
 252         verbosity  => $verbosity,
 253     };
 254
 255     $args->{stdout} = $sub_args->{out}
 256       if exists $sub_args->{out};
 257
 258     if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
 259         for my $opt ( split /:/, $env_opt ) {
 260             if ( $opt =~ /^j(\d*)$/ ) {
 261                 $args->{jobs} = $1 || 9;
 262             }
 263             elsif ( $opt eq 'f' ) {
 264                 $args->{fork} = 1;
 265             }
 266             elsif ( $opt eq 'c' ) {
 267                 $args->{color} = 1;
 268             }
 269             else {
 270                 die "Unknown HARNESS_OPTIONS item: $opt\n";
 271             }
 272         }
 273     }
 274
 275     return TAP::Harness->new($args);
 276 }
 277
 278 # Get the parts of @INC which are changed from the stock list AND
 279 # preserve reordering of stock directories.
 280 sub _filtered_inc {
 281     my @inc = grep { !ref } @INC;    #28567
 282
 283     if (IS_VMS) {
 284
 285         # VMS has a 255-byte limit on the length of %ENV entries, so
 286         # toss the ones that involve perl_root, the install location
 287         @inc = grep !/perl_root/i, @inc;
 288
 289     }
 290     elsif (IS_WIN32) {
 291
 292         # Lose any trailing backslashes in the Win32 paths
 293         s/[\\\/+]$// foreach @inc;
 294     }
 295
 296     my @default_inc = _default_inc();
 297
 298     my @new_inc;
 299     my %seen;
 300     for my $dir (@inc) {
 301         next if $seen{$dir}++;
 302
 303         if ( $dir eq ( $default_inc[0] || '' ) ) {
 304             shift @default_inc;
 305         }
 306         else {
 307             push @new_inc, $dir;
 308         }
 309
 310         shift @default_inc while @default_inc and $seen{ $default_inc[0] };
 311     }
 312
 313     return @new_inc;
 314 }
 315
 316 {
 317
 318     # Cache this to avoid repeatedly shelling out to Perl.
 319     my @inc;
 320
 321     sub _default_inc {
 322         return @inc if @inc;
 323         my $perl = $ENV{HARNESS_PERL} || $^X;
 324         chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` );
 325         return @inc;
 326     }
 327 }
 328
 329 sub _check_sequence {
 330     my @list = @_;
 331     my $prev;
 332     while ( my $next = shift @list ) {
 333         return if defined $prev && $next <= $prev;
 334         $prev = $next;
 335     }
 336
 337     return 1;
 338 }
 339
 340 sub execute_tests {
 341     my %args = @_;
 342
 343     my $harness   = _new_harness( \%args );
 344     my $aggregate = TAP::Parser::Aggregator->new();
 345
 346     my %tot = (
 347         bonus       => 0,
 348         max         => 0,
 349         ok          => 0,
 350         bad         => 0,
 351         good        => 0,
 352         files       => 0,
 353         tests       => 0,
 354         sub_skipped => 0,
 355         todo        => 0,
 356         skipped     => 0,
 357         bench       => undef,
 358     );
 359
 360     # Install a callback so we get to see any plans the
 361     # harness executes.
 362     $harness->callback(
 363         made_parser => sub {
 364             my $parser = shift;
 365             $parser->callback(
 366                 plan => sub {
 367                     my $plan = shift;
 368                     if ( $plan->directive eq 'SKIP' ) {
 369                         $tot{skipped}++;
 370                     }
 371                 }
 372             );
 373         }
 374     );
 375
 376     _aggregate( $harness, $aggregate, @{ $args{tests} } );
 377
 378     $tot{bench} = $aggregate->elapsed;
 379     my @tests = $aggregate->descriptions;
 380
 381     # TODO: Work out the circumstances under which the files
 382     # and tests totals can differ.
 383     $tot{files} = $tot{tests} = scalar @tests;
 384
 385     my %failedtests = ();
 386     my %todo_passed = ();
 387
 388     for my $test (@tests) {
 389         my ($parser) = $aggregate->parsers($test);
 390
 391         my @failed = $parser->failed;
 392
 393         my $wstat         = $parser->wait;
 394         my $estat         = $parser->exit;
 395         my $planned       = $parser->tests_planned;
 396         my @errors        = $parser->parse_errors;
 397         my $passed        = $parser->passed;
 398         my $actual_passed = $parser->actual_passed;
 399
 400         my $ok_seq = _check_sequence( $parser->actual_passed );
 401
 402         # Duplicate exit, wait status semantics of old version
 403         $estat ||= '' unless $wstat;
 404         $wstat ||= '';
 405
 406         $tot{max} += ( $planned || 0 );
 407         $tot{bonus} += $parser->todo_passed;
 408         $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
 409         $tot{sub_skipped} += $parser->skipped;
 410         $tot{todo}        += $parser->todo;
 411
 412         if ( @failed || $estat || @errors ) {
 413             $tot{bad}++;
 414
 415             my $huh_planned = $planned ? undef : '??';
 416             my $huh_errors  = $ok_seq  ? undef : '??';
 417
 418             $failedtests{$test} = {
 419                 'canon' => $huh_planned
 420                   || $huh_errors
 421                   || _canon(@failed)
 422                   || '??',
 423                 'estat'  => $estat,
 424                 'failed' => $huh_planned
 425                   || $huh_errors
 426                   || scalar @failed,
 427                 'max' => $huh_planned || $planned,
 428                 'name'  => $test,
 429                 'wstat' => $wstat
 430             };
 431         }
 432         else {
 433             $tot{good}++;
 434         }
 435
 436         my @todo = $parser->todo_passed;
 437         if (@todo) {
 438             $todo_passed{$test} = {
 439                 'canon'  => _canon(@todo),
 440                 'estat'  => $estat,
 441                 'failed' => scalar @todo,
 442                 'max'    => scalar $parser->todo,
 443                 'name'   => $test,
 444                 'wstat'  => $wstat
 445             };
 446         }
 447     }
 448
 449     return ( \%tot, \%failedtests, \%todo_passed );
 450 }
 451
 452 =head2 execute_tests( tests => \@test_files, out => \*FH )
 453
 454 Runs all the given C<@test_files> (just like C<runtests()>) but
 455 doesn't generate the final report.  During testing, progress
 456 information will be written to the currently selected output
 457 filehandle (usually C<STDOUT>), or to the filehandle given by the
 458 C<out> parameter.  The I<out> is optional.
 459
 460 Returns a list of two values, C<$total> and C<$failed>, describing the
 461 results.  C<$total> is a hash ref summary of all the tests run.  Its
 462 keys and values are this:
 463
 464     bonus           Number of individual todo tests unexpectedly passed
 465     max             Number of individual tests ran
 466     ok              Number of individual tests passed
 467     sub_skipped     Number of individual tests skipped
 468     todo            Number of individual todo tests
 469
 470     files           Number of test files ran
 471     good            Number of test files passed
 472     bad             Number of test files failed
 473     tests           Number of test files originally given
 474     skipped         Number of test files skipped
 475
 476 If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
 477 got a successful test.
 478
 479 C<$failed> is a hash ref of all the test scripts that failed.  Each key
 480 is the name of a test script, each value is another hash representing
 481 how that script failed.  Its keys are these:
 482
 483     name        Name of the test which failed
 484     estat       Script's exit value
 485     wstat       Script's wait status
 486     max         Number of individual tests
 487     failed      Number which failed
 488     canon       List of tests which failed (as string).
 489
 490 C<$failed> should be empty if everything passed.
 491
 492 =cut
 493
 494 1;
 495 __END__
 496
 497 =head1 EXPORT
 498
 499 C<&runtests> is exported by C<Test::Harness> by default.
 500
 501 C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
 502 exported upon request.
 503
 504 =head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
 505
 506 C<Test::Harness> sets these before executing the individual tests.
 507
 508 =over 4
 509
 510 =item C<HARNESS_ACTIVE>
 511
 512 This is set to a true value.  It allows the tests to determine if they
 513 are being executed through the harness or by any other means.
 514
 515 =item C<HARNESS_VERSION>
 516
 517 This is the version of C<Test::Harness>.
 518
 519 =back
 520
 521 =head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
 522
 523 =over 4
 524
 525 =item C<HARNESS_TIMER>
 526
 527 Setting this to true will make the harness display the number of
 528 milliseconds each test took.  You can also use F<prove>'s C<--timer>
 529 switch.
 530
 531 =item C<HARNESS_VERBOSE>
 532
 533 If true, C<Test::Harness> will output the verbose results of running
 534 its tests.  Setting C<$Test::Harness::verbose> will override this,
 535 or you can use the C<-v> switch in the F<prove> utility.
 536
 537 =item C<HARNESS_OPTIONS>
 538
 539 Provide additional options to the harness. Currently supported options are:
 540
 541 =over
 542
 543 =item C<< j<n> >>
 544
 545 Run <n> (default 9) parallel jobs.
 546
 547 =item C<< f >>
 548
 549 Use forked parallelism.
 550
 551 =back
 552
 553 Multiple options may be separated by colons:
 554
 555     HARNESS_OPTIONS=j9:f make test
 556
 557 =back
 558
 559 =head1 SEE ALSO
 560
 561 L<TAP::Harness>
 562
 563 =head1 BUGS
 564
 565 Please report any bugs or feature requests to
 566 C<bug-test-harness at rt.cpan.org>, or through the web interface at
 567 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.  I will be
 568 notified, and then you'll automatically be notified of progress on your bug
 569 as I make changes.
 570
 571 =head1 AUTHORS
 572
 573 Andy Armstrong  C<< <andy@hexten.net> >>
 574
 575 L<Test::Harness> (on which this module is based) has this attribution:
 576
 577     Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 578     sure is, that it was inspired by Larry Wall's F<TEST> script that came
 579     with perl distributions for ages. Numerous anonymous contributors
 580     exist.  Andreas Koenig held the torch for many years, and then
 581     Michael G Schwern.
 582
 583 =head1 LICENCE AND COPYRIGHT
 584
 585 Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
 586
 587 This module is free software; you can redistribute it and/or
 588 modify it under the same terms as Perl itself. See L<perlartistic>.
 589