vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/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   $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.12
  48
  49 =cut
  50
  51 $VERSION = '3.12';
  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     if (IS_VMS) {
 132
 133         # Jiggery pokery doesn't appear to work on VMS - so disable it
 134         # pending investigation.
 135         _aggregate_tests( $harness, $aggregate, @tests );
 136     }
 137     else {
 138         my $path_sep  = $Config{path_sep};
 139         my $path_pat  = qr{$path_sep};
 140         my @extra_inc = _filtered_inc();
 141
 142         # Supply -I switches in taint mode
 143         $harness->callback(
 144             parser_args => sub {
 145                 my ( $args, $test ) = @_;
 146                 if ( _has_taint( $test->[0] ) ) {
 147                     push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
 148                 }
 149             }
 150         );
 151
 152         my $previous = $ENV{PERL5LIB};
 153         local $ENV{PERL5LIB};
 154
 155         if ($previous) {
 156             push @extra_inc, split( $path_pat, $previous );
 157         }
 158
 159         if (@extra_inc) {
 160             $ENV{PERL5LIB} = join( $path_sep, @extra_inc );
 161         }
 162
 163         _aggregate_tests( $harness, $aggregate, @tests );
 164     }
 165 }
 166
 167 sub _aggregate_tests {
 168     my ( $harness, $aggregate, @tests ) = @_;
 169     $aggregate->start();
 170     $harness->aggregate_tests( $aggregate, @tests );
 171     $aggregate->stop();
 172
 173 }
 174
 175 sub runtests {
 176     my @tests = @_;
 177
 178     # shield against -l
 179     local ( $\, $, );
 180
 181     my $harness   = _new_harness();
 182     my $aggregate = TAP::Parser::Aggregator->new();
 183
 184     _aggregate( $harness, $aggregate, @tests );
 185
 186     $harness->formatter->summary($aggregate);
 187
 188     my $total  = $aggregate->total;
 189     my $passed = $aggregate->passed;
 190     my $failed = $aggregate->failed;
 191
 192     my @parsers = $aggregate->parsers;
 193
 194     my $num_bad = 0;
 195     for my $parser (@parsers) {
 196         $num_bad++ if $parser->has_problems;
 197     }
 198
 199     die(sprintf(
 200             "Failed %d/%d test programs. %d/%d subtests failed.\n",
 201             $num_bad, scalar @parsers, $failed, $total
 202         )
 203     ) if $num_bad;
 204
 205     return $total && $total == $passed;
 206 }
 207
 208 sub _canon {
 209     my @list   = sort { $a <=> $b } @_;
 210     my @ranges = ();
 211     my $count  = scalar @list;
 212     my $pos    = 0;
 213
 214     while ( $pos < $count ) {
 215         my $end = $pos + 1;
 216         $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
 217         push @ranges, ( $end == $pos + 1 )
 218           ? $list[$pos]
 219           : join( '-', $list[$pos], $list[ $end - 1 ] );
 220         $pos = $end;
 221     }
 222
 223     return join( ' ', @ranges );
 224 }
 225
 226 sub _new_harness {
 227     my $sub_args = shift || {};
 228
 229     my ( @lib, @switches );
 230     for my $opt ( split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ) ) {
 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         ignore_exit => $IgnoreExit,
 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 Taint Mode
 560
 561 Normally when a Perl program is run in taint mode the contents of the
 562 C<PERL5LIB> environment variable do not appear in C<@INC>.
 563
 564 Because C<PERL5LIB> is often used during testing to add build
 565 directories to C<@INC> C<Test::Harness> (actually
 566 L<TAP::Parser::Source::Perl>) passes the names of any directories found
 567 in C<PERL5LIB> as -I switches. The net effect of this is that
 568 C<PERL5LIB> is honoured even in taint mode.
 569
 570 =head1 SEE ALSO
 571
 572 L<TAP::Harness>
 573
 574 =head1 BUGS
 575
 576 Please report any bugs or feature requests to
 577 C<bug-test-harness at rt.cpan.org>, or through the web interface at
 578 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.  I will be
 579 notified, and then you'll automatically be notified of progress on your bug
 580 as I make changes.
 581
 582 =head1 AUTHORS
 583
 584 Andy Armstrong  C<< <andy@hexten.net> >>
 585
 586 L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
 587 module is based) has this attribution:
 588
 589     Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 590     sure is, that it was inspired by Larry Wall's F<TEST> script that came
 591     with perl distributions for ages. Numerous anonymous contributors
 592     exist.  Andreas Koenig held the torch for many years, and then
 593     Michael G Schwern.
 594
 595 =head1 LICENCE AND COPYRIGHT
 596
 597 Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
 598
 599 This module is free software; you can redistribute it and/or
 600 modify it under the same terms as Perl itself. See L<perlartistic>.
 601