cpan/Test-Harness/lib/Test/Harness.pm

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