619 lines
16 KiB
Perl
619 lines
16 KiB
Perl
package Test::Harness;
|
||
|
||
use 5.006;
|
||
|
||
use strict;
|
||
use warnings;
|
||
|
||
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
|
||
use constant IS_VMS => ( $^O eq 'VMS' );
|
||
|
||
use TAP::Harness ();
|
||
use TAP::Parser::Aggregator ();
|
||
use TAP::Parser::Source ();
|
||
use TAP::Parser::SourceHandler::Perl ();
|
||
|
||
use Text::ParseWords qw(shellwords);
|
||
|
||
use Config;
|
||
use base 'Exporter';
|
||
|
||
# $ML $Last_ML_Print
|
||
|
||
BEGIN {
|
||
eval q{use Time::HiRes 'time'};
|
||
our $has_time_hires = !$@;
|
||
}
|
||
|
||
=head1 NAME
|
||
|
||
Test::Harness - Run Perl standard test scripts with statistics
|
||
|
||
=head1 VERSION
|
||
|
||
Version 3.42
|
||
|
||
=cut
|
||
|
||
our $VERSION = '3.42';
|
||
|
||
# Backwards compatibility for exportable variable names.
|
||
*verbose = *Verbose;
|
||
*switches = *Switches;
|
||
*debug = *Debug;
|
||
|
||
$ENV{HARNESS_ACTIVE} = 1;
|
||
$ENV{HARNESS_VERSION} = $VERSION;
|
||
|
||
END {
|
||
|
||
# For VMS.
|
||
delete $ENV{HARNESS_ACTIVE};
|
||
delete $ENV{HARNESS_VERSION};
|
||
}
|
||
|
||
our @EXPORT = qw(&runtests);
|
||
our @EXPORT_OK = qw(&execute_tests $verbose $switches);
|
||
|
||
our $Verbose = $ENV{HARNESS_VERBOSE} || 0;
|
||
our $Debug = $ENV{HARNESS_DEBUG} || 0;
|
||
our $Switches = '-w';
|
||
our $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
|
||
$Columns--; # Some shells have trouble with a full line of text.
|
||
our $Timer = $ENV{HARNESS_TIMER} || 0;
|
||
our $Color = $ENV{HARNESS_COLOR} || 0;
|
||
our $IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
|
||
|
||
=head1 SYNOPSIS
|
||
|
||
use Test::Harness;
|
||
|
||
runtests(@test_files);
|
||
|
||
=head1 DESCRIPTION
|
||
|
||
Although, for historical reasons, the L<Test::Harness> distribution
|
||
takes its name from this module it now exists only to provide
|
||
L<TAP::Harness> with an interface that is somewhat backwards compatible
|
||
with L<Test::Harness> 2.xx. If you're writing new code consider using
|
||
L<TAP::Harness> directly instead.
|
||
|
||
Emulation is provided for C<runtests> and C<execute_tests> but the
|
||
pluggable 'Straps' interface that previous versions of L<Test::Harness>
|
||
supported is not reproduced here. Straps is now available as a stand
|
||
alone module: L<Test::Harness::Straps>.
|
||
|
||
See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
|
||
distribution.
|
||
|
||
=head1 FUNCTIONS
|
||
|
||
The following functions are available.
|
||
|
||
=head2 runtests( @test_files )
|
||
|
||
This runs all the given I<@test_files> and divines whether they passed
|
||
or failed based on their output to STDOUT (details above). It prints
|
||
out each individual test which failed along with a summary report and
|
||
a how long it all took.
|
||
|
||
It returns true if everything was ok. Otherwise it will C<die()> with
|
||
one of the messages in the DIAGNOSTICS section.
|
||
|
||
=cut
|
||
|
||
sub _has_taint {
|
||
my $test = shift;
|
||
return TAP::Parser::SourceHandler::Perl->get_taint(
|
||
TAP::Parser::Source->shebang($test) );
|
||
}
|
||
|
||
sub _aggregate {
|
||
my ( $harness, $aggregate, @tests ) = @_;
|
||
|
||
# Don't propagate to our children
|
||
local $ENV{HARNESS_OPTIONS};
|
||
|
||
_apply_extra_INC($harness);
|
||
_aggregate_tests( $harness, $aggregate, @tests );
|
||
}
|
||
|
||
# Make sure the child sees all the extra junk in @INC
|
||
sub _apply_extra_INC {
|
||
my $harness = shift;
|
||
|
||
$harness->callback(
|
||
parser_args => sub {
|
||
my ( $args, $test ) = @_;
|
||
push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
|
||
}
|
||
);
|
||
}
|
||
|
||
sub _aggregate_tests {
|
||
my ( $harness, $aggregate, @tests ) = @_;
|
||
$aggregate->start();
|
||
$harness->aggregate_tests( $aggregate, @tests );
|
||
$aggregate->stop();
|
||
|
||
}
|
||
|
||
sub runtests {
|
||
my @tests = @_;
|
||
|
||
# shield against -l
|
||
local ( $\, $, );
|
||
|
||
my $harness = _new_harness();
|
||
my $aggregate = TAP::Parser::Aggregator->new();
|
||
|
||
local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC};
|
||
_aggregate( $harness, $aggregate, @tests );
|
||
|
||
$harness->formatter->summary($aggregate);
|
||
|
||
my $total = $aggregate->total;
|
||
my $passed = $aggregate->passed;
|
||
my $failed = $aggregate->failed;
|
||
|
||
my @parsers = $aggregate->parsers;
|
||
|
||
my $num_bad = 0;
|
||
for my $parser (@parsers) {
|
||
$num_bad++ if $parser->has_problems;
|
||
}
|
||
|
||
die(sprintf(
|
||
"Failed %d/%d test programs. %d/%d subtests failed.\n",
|
||
$num_bad, scalar @parsers, $failed, $total
|
||
)
|
||
) if $num_bad;
|
||
|
||
return $total && $total == $passed;
|
||
}
|
||
|
||
sub _canon {
|
||
my @list = sort { $a <=> $b } @_;
|
||
my @ranges = ();
|
||
my $count = scalar @list;
|
||
my $pos = 0;
|
||
|
||
while ( $pos < $count ) {
|
||
my $end = $pos + 1;
|
||
$end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
|
||
push @ranges, ( $end == $pos + 1 )
|
||
? $list[$pos]
|
||
: join( '-', $list[$pos], $list[ $end - 1 ] );
|
||
$pos = $end;
|
||
}
|
||
|
||
return join( ' ', @ranges );
|
||
}
|
||
|
||
sub _new_harness {
|
||
my $sub_args = shift || {};
|
||
|
||
my ( @lib, @switches );
|
||
my @opt = map { shellwords($_) } grep { defined } $Switches, $ENV{HARNESS_PERL_SWITCHES};
|
||
while ( my $opt = shift @opt ) {
|
||
if ( $opt =~ /^ -I (.*) $ /x ) {
|
||
push @lib, length($1) ? $1 : shift @opt;
|
||
}
|
||
else {
|
||
push @switches, $opt;
|
||
}
|
||
}
|
||
|
||
# Do things the old way on VMS...
|
||
push @lib, _filtered_inc() if IS_VMS;
|
||
|
||
# If $Verbose isn't numeric default to 1. This helps core.
|
||
my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
|
||
|
||
my $args = {
|
||
timer => $Timer,
|
||
directives => our $Directives,
|
||
lib => \@lib,
|
||
switches => \@switches,
|
||
color => $Color,
|
||
verbosity => $verbosity,
|
||
ignore_exit => $IgnoreExit,
|
||
};
|
||
|
||
$args->{stdout} = $sub_args->{out}
|
||
if exists $sub_args->{out};
|
||
|
||
my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness';
|
||
if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
|
||
for my $opt ( split /:/, $env_opt ) {
|
||
if ( $opt =~ /^j(\d*)$/ ) {
|
||
$args->{jobs} = $1 || 9;
|
||
}
|
||
elsif ( $opt eq 'c' ) {
|
||
$args->{color} = 1;
|
||
}
|
||
elsif ( $opt =~ m/^f(.*)$/ ) {
|
||
my $fmt = $1;
|
||
$fmt =~ s/-/::/g;
|
||
$args->{formatter_class} = $fmt;
|
||
}
|
||
elsif ( $opt =~ m/^a(.*)$/ ) {
|
||
my $archive = $1;
|
||
$class = "TAP::Harness::Archive";
|
||
$args->{archive} = $archive;
|
||
}
|
||
else {
|
||
die "Unknown HARNESS_OPTIONS item: $opt\n";
|
||
}
|
||
}
|
||
}
|
||
|
||
return TAP::Harness->_construct( $class, $args );
|
||
}
|
||
|
||
# Get the parts of @INC which are changed from the stock list AND
|
||
# preserve reordering of stock directories.
|
||
sub _filtered_inc {
|
||
my @inc = grep { !ref } @INC; #28567
|
||
|
||
if (IS_VMS) {
|
||
|
||
# VMS has a 255-byte limit on the length of %ENV entries, so
|
||
# toss the ones that involve perl_root, the install location
|
||
@inc = grep !/perl_root/i, @inc;
|
||
|
||
}
|
||
elsif (IS_WIN32) {
|
||
|
||
# Lose any trailing backslashes in the Win32 paths
|
||
s/[\\\/]+$// for @inc;
|
||
}
|
||
|
||
my @default_inc = _default_inc();
|
||
|
||
my @new_inc;
|
||
my %seen;
|
||
for my $dir (@inc) {
|
||
next if $seen{$dir}++;
|
||
|
||
if ( $dir eq ( $default_inc[0] || '' ) ) {
|
||
shift @default_inc;
|
||
}
|
||
else {
|
||
push @new_inc, $dir;
|
||
}
|
||
|
||
shift @default_inc while @default_inc and $seen{ $default_inc[0] };
|
||
}
|
||
|
||
return @new_inc;
|
||
}
|
||
|
||
{
|
||
|
||
# Cache this to avoid repeatedly shelling out to Perl.
|
||
my @inc;
|
||
|
||
sub _default_inc {
|
||
return @inc if @inc;
|
||
|
||
local $ENV{PERL5LIB};
|
||
local $ENV{PERLLIB};
|
||
|
||
my $perl = $ENV{HARNESS_PERL} || $^X;
|
||
|
||
# Avoid using -l for the benefit of Perl 6
|
||
chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` );
|
||
return @inc;
|
||
}
|
||
}
|
||
|
||
sub _check_sequence {
|
||
my @list = @_;
|
||
my $prev;
|
||
while ( my $next = shift @list ) {
|
||
return if defined $prev && $next <= $prev;
|
||
$prev = $next;
|
||
}
|
||
|
||
return 1;
|
||
}
|
||
|
||
sub execute_tests {
|
||
my %args = @_;
|
||
|
||
my $harness = _new_harness( \%args );
|
||
my $aggregate = TAP::Parser::Aggregator->new();
|
||
|
||
my %tot = (
|
||
bonus => 0,
|
||
max => 0,
|
||
ok => 0,
|
||
bad => 0,
|
||
good => 0,
|
||
files => 0,
|
||
tests => 0,
|
||
sub_skipped => 0,
|
||
todo => 0,
|
||
skipped => 0,
|
||
bench => undef,
|
||
);
|
||
|
||
# Install a callback so we get to see any plans the
|
||
# harness executes.
|
||
$harness->callback(
|
||
made_parser => sub {
|
||
my $parser = shift;
|
||
$parser->callback(
|
||
plan => sub {
|
||
my $plan = shift;
|
||
if ( $plan->directive eq 'SKIP' ) {
|
||
$tot{skipped}++;
|
||
}
|
||
}
|
||
);
|
||
}
|
||
);
|
||
|
||
local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC};
|
||
_aggregate( $harness, $aggregate, @{ $args{tests} } );
|
||
|
||
$tot{bench} = $aggregate->elapsed;
|
||
my @tests = $aggregate->descriptions;
|
||
|
||
# TODO: Work out the circumstances under which the files
|
||
# and tests totals can differ.
|
||
$tot{files} = $tot{tests} = scalar @tests;
|
||
|
||
my %failedtests = ();
|
||
my %todo_passed = ();
|
||
|
||
for my $test (@tests) {
|
||
my ($parser) = $aggregate->parsers($test);
|
||
|
||
my @failed = $parser->failed;
|
||
|
||
my $wstat = $parser->wait;
|
||
my $estat = $parser->exit;
|
||
my $planned = $parser->tests_planned;
|
||
my @errors = $parser->parse_errors;
|
||
my $passed = $parser->passed;
|
||
my $actual_passed = $parser->actual_passed;
|
||
|
||
my $ok_seq = _check_sequence( $parser->actual_passed );
|
||
|
||
# Duplicate exit, wait status semantics of old version
|
||
$estat ||= '' unless $wstat;
|
||
$wstat ||= '';
|
||
|
||
$tot{max} += ( $planned || 0 );
|
||
$tot{bonus} += $parser->todo_passed;
|
||
$tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
|
||
$tot{sub_skipped} += $parser->skipped;
|
||
$tot{todo} += $parser->todo;
|
||
|
||
if ( @failed || $estat || @errors ) {
|
||
$tot{bad}++;
|
||
|
||
my $huh_planned = $planned ? undef : '??';
|
||
my $huh_errors = $ok_seq ? undef : '??';
|
||
|
||
$failedtests{$test} = {
|
||
'canon' => $huh_planned
|
||
|| $huh_errors
|
||
|| _canon(@failed)
|
||
|| '??',
|
||
'estat' => $estat,
|
||
'failed' => $huh_planned
|
||
|| $huh_errors
|
||
|| scalar @failed,
|
||
'max' => $huh_planned || $planned,
|
||
'name' => $test,
|
||
'wstat' => $wstat
|
||
};
|
||
}
|
||
else {
|
||
$tot{good}++;
|
||
}
|
||
|
||
my @todo = $parser->todo_passed;
|
||
if (@todo) {
|
||
$todo_passed{$test} = {
|
||
'canon' => _canon(@todo),
|
||
'estat' => $estat,
|
||
'failed' => scalar @todo,
|
||
'max' => scalar $parser->todo,
|
||
'name' => $test,
|
||
'wstat' => $wstat
|
||
};
|
||
}
|
||
}
|
||
|
||
return ( \%tot, \%failedtests, \%todo_passed );
|
||
}
|
||
|
||
=head2 execute_tests( tests => \@test_files, out => \*FH )
|
||
|
||
Runs all the given C<@test_files> (just like C<runtests()>) but
|
||
doesn't generate the final report. During testing, progress
|
||
information will be written to the currently selected output
|
||
filehandle (usually C<STDOUT>), or to the filehandle given by the
|
||
C<out> parameter. The I<out> is optional.
|
||
|
||
Returns a list of two values, C<$total> and C<$failed>, describing the
|
||
results. C<$total> is a hash ref summary of all the tests run. Its
|
||
keys and values are this:
|
||
|
||
bonus Number of individual todo tests unexpectedly passed
|
||
max Number of individual tests ran
|
||
ok Number of individual tests passed
|
||
sub_skipped Number of individual tests skipped
|
||
todo Number of individual todo tests
|
||
|
||
files Number of test files ran
|
||
good Number of test files passed
|
||
bad Number of test files failed
|
||
tests Number of test files originally given
|
||
skipped Number of test files skipped
|
||
|
||
If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
|
||
got a successful test.
|
||
|
||
C<$failed> is a hash ref of all the test scripts that failed. Each key
|
||
is the name of a test script, each value is another hash representing
|
||
how that script failed. Its keys are these:
|
||
|
||
name Name of the test which failed
|
||
estat Script's exit value
|
||
wstat Script's wait status
|
||
max Number of individual tests
|
||
failed Number which failed
|
||
canon List of tests which failed (as string).
|
||
|
||
C<$failed> should be empty if everything passed.
|
||
|
||
=cut
|
||
|
||
1;
|
||
__END__
|
||
|
||
=head1 EXPORT
|
||
|
||
C<&runtests> is exported by C<Test::Harness> by default.
|
||
|
||
C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
|
||
exported upon request.
|
||
|
||
=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
|
||
|
||
C<Test::Harness> sets these before executing the individual tests.
|
||
|
||
=over 4
|
||
|
||
=item C<HARNESS_ACTIVE>
|
||
|
||
This is set to a true value. It allows the tests to determine if they
|
||
are being executed through the harness or by any other means.
|
||
|
||
=item C<HARNESS_VERSION>
|
||
|
||
This is the version of C<Test::Harness>.
|
||
|
||
=back
|
||
|
||
=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
|
||
|
||
=over 4
|
||
|
||
=item C<HARNESS_PERL_SWITCHES>
|
||
|
||
Setting this adds perl command line switches to each test file run.
|
||
|
||
For example, C<HARNESS_PERL_SWITCHES=-T> will turn on taint mode.
|
||
C<HARNESS_PERL_SWITCHES=-MDevel::Cover> will run C<Devel::Cover> for
|
||
each test.
|
||
|
||
C<-w> is always set. You can turn this off in the test with C<BEGIN {
|
||
$^W = 0 }>.
|
||
|
||
=item C<HARNESS_TIMER>
|
||
|
||
Setting this to true will make the harness display the number of
|
||
milliseconds each test took. You can also use F<prove>'s C<--timer>
|
||
switch.
|
||
|
||
=item C<HARNESS_VERBOSE>
|
||
|
||
If true, C<Test::Harness> will output the verbose results of running
|
||
its tests. Setting C<$Test::Harness::verbose> will override this,
|
||
or you can use the C<-v> switch in the F<prove> utility.
|
||
|
||
=item C<HARNESS_OPTIONS>
|
||
|
||
Provide additional options to the harness. Currently supported options are:
|
||
|
||
=over
|
||
|
||
=item C<< j<n> >>
|
||
|
||
Run <n> (default 9) parallel jobs.
|
||
|
||
=item C<< c >>
|
||
|
||
Try to color output. See L<TAP::Formatter::Base/"new">.
|
||
|
||
=item C<< a<file.tgz> >>
|
||
|
||
Will use L<TAP::Harness::Archive> as the harness class, and save the TAP to
|
||
C<file.tgz>
|
||
|
||
=item C<< fPackage-With-Dashes >>
|
||
|
||
Set the formatter_class of the harness being run. Since the C<HARNESS_OPTIONS>
|
||
is seperated by C<:>, we use C<-> instead.
|
||
|
||
=back
|
||
|
||
Multiple options may be separated by colons:
|
||
|
||
HARNESS_OPTIONS=j9:c make test
|
||
|
||
=item C<HARNESS_SUBCLASS>
|
||
|
||
Specifies a TAP::Harness subclass to be used in place of TAP::Harness.
|
||
|
||
=item C<HARNESS_SUMMARY_COLOR_SUCCESS>
|
||
|
||
Determines the L<Term::ANSIColor> for the summary in case it is successful.
|
||
This color defaults to C<'green'>.
|
||
|
||
=item C<HARNESS_SUMMARY_COLOR_FAIL>
|
||
|
||
Determines the L<Term::ANSIColor> for the failure in case it is successful.
|
||
This color defaults to C<'red'>.
|
||
|
||
=back
|
||
|
||
=head1 Taint Mode
|
||
|
||
Normally when a Perl program is run in taint mode the contents of the
|
||
C<PERL5LIB> environment variable do not appear in C<@INC>.
|
||
|
||
Because C<PERL5LIB> is often used during testing to add build
|
||
directories to C<@INC> C<Test::Harness> passes the names of any
|
||
directories found in C<PERL5LIB> as -I switches. The net effect of this
|
||
is that C<PERL5LIB> is honoured even in taint mode.
|
||
|
||
=head1 SEE ALSO
|
||
|
||
L<TAP::Harness>
|
||
|
||
=head1 BUGS
|
||
|
||
Please report any bugs or feature requests to
|
||
C<bug-test-harness at rt.cpan.org>, or through the web interface at
|
||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
|
||
notified, and then you'll automatically be notified of progress on your bug
|
||
as I make changes.
|
||
|
||
=head1 AUTHORS
|
||
|
||
Andy Armstrong C<< <andy@hexten.net> >>
|
||
|
||
L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
|
||
module is based) has this attribution:
|
||
|
||
Either Tim Bunce or Andreas Koenig, we don't know. What we know for
|
||
sure is, that it was inspired by Larry Wall's F<TEST> script that came
|
||
with perl distributions for ages. Numerous anonymous contributors
|
||
exist. Andreas Koenig held the torch for many years, and then
|
||
Michael G Schwern.
|
||
|
||
=head1 LICENCE AND COPYRIGHT
|
||
|
||
Copyright (c) 2007-2011, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
|
||
|
||
This module is free software; you can redistribute it and/or
|
||
modify it under the same terms as Perl itself. See L<perlartistic>.
|
||
|