Initial Commit
This commit is contained in:
Riley Schneider
618
database/perl/lib/Test/Harness.pm
Normal file
618
database/perl/lib/Test/Harness.pm
Normal file
@@ -0,0 +1,618 @@
|
||||
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>.
|
||||
|
||||
Reference in New Issue
Block a user