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