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