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