diff -urN Test.old/Harness/Assert.pm Test/Harness/Assert.pm --- perl-5.10.0/lib/Test.old/Harness/Assert.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/Assert.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,64 +0,0 @@ -package Test::Harness::Assert; - -use strict; -require Exporter; -use vars qw($VERSION @EXPORT @ISA); - -$VERSION = '0.02'; - -@ISA = qw(Exporter); -@EXPORT = qw(assert); - - -=head1 NAME - -Test::Harness::Assert - simple assert - -=head1 SYNOPSIS - - ### FOR INTERNAL USE ONLY ### - - use Test::Harness::Assert; - - assert( EXPR, $name ); - -=head1 DESCRIPTION - -A simple assert routine since we don't have Carp::Assert handy. - -B - -=head1 FUNCTIONS - -=head2 C - - assert( EXPR, $name ); - -If the expression is false the program aborts. - -=cut - -sub assert ($;$) { - my($assert, $name) = @_; - - unless( $assert ) { - require Carp; - my $msg = 'Assert failed'; - $msg .= " - '$name'" if defined $name; - $msg .= '!'; - Carp::croak($msg); - } - -} - -=head1 AUTHOR - -Michael G Schwern C<< >> - -=head1 SEE ALSO - -L - -=cut - -1; diff -urN Test.old/Harness/bin/prove Test/Harness/bin/prove --- perl-5.10.0/lib/Test.old/Harness/bin/prove 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/bin/prove 1970-01-01 01:00:00.000000000 +0100 @@ -1,292 +0,0 @@ -#!/usr/bin/perl -w - -use strict; - -use Test::Harness; -use Test::Harness::Util qw( all_in blibdirs shuffle ); - -use Getopt::Long; -use Pod::Usage 1.12; -use File::Spec; - -use vars qw( $VERSION ); -$VERSION = '2.64'; - -my $shuffle = 0; -my $dry = 0; -my $blib = 0; -my $lib = 0; -my $recurse = 0; -my @includes = (); -my @switches = (); - -# Allow cuddling the paths with the -I -@ARGV = map { /^(-I)(.+)/ ? ($1,$2) : $_ } @ARGV; - -# Stick any default switches at the beginning, so they can be overridden -# by the command line switches. -unshift @ARGV, split( ' ', $ENV{PROVE_SWITCHES} ) if defined $ENV{PROVE_SWITCHES}; - -Getopt::Long::Configure( 'no_ignore_case' ); -Getopt::Long::Configure( 'bundling' ); -GetOptions( - 'b|blib' => \$blib, - 'd|debug' => \$Test::Harness::debug, - 'D|dry' => \$dry, - 'h|help|?' => sub {pod2usage({-verbose => 1}); exit}, - 'H|man' => sub {pod2usage({-verbose => 2}); exit}, - 'I=s@' => \@includes, - 'l|lib' => \$lib, - 'perl=s' => \$ENV{HARNESS_PERL}, - 'r|recurse' => \$recurse, - 's|shuffle' => \$shuffle, - 't' => sub { unshift @switches, '-t' }, # Always want -t up front - 'T' => sub { unshift @switches, '-T' }, # Always want -T up front - 'w' => sub { push @switches, '-w' }, - 'W' => sub { push @switches, '-W' }, - 'strap=s' => \$ENV{HARNESS_STRAP_CLASS}, - 'timer' => \$Test::Harness::Timer, - 'v|verbose' => \$Test::Harness::verbose, - 'V|version' => sub { print_version(); exit; }, -) or exit 1; - -$ENV{TEST_VERBOSE} = 1 if $Test::Harness::verbose; - -# Handle blib includes -if ( $blib ) { - my @blibdirs = blibdirs(); - if ( @blibdirs ) { - unshift @includes, @blibdirs; - } - else { - warn "No blib directories found.\n"; - } -} - -# Handle lib includes -if ( $lib ) { - unshift @includes, 'lib'; -} - -# Build up TH switches -push( @switches, map { /\s/ && !/^".*"$/ ? qq["-I$_"] : "-I$_" } @includes ); -$Test::Harness::Switches = join( ' ', @switches ); -print "# \$Test::Harness::Switches: $Test::Harness::Switches\n" if $Test::Harness::debug; - -@ARGV = File::Spec->curdir unless @ARGV; -my @argv_globbed; -my @tests; -if ( $] >= 5.006001 ) { - require File::Glob; - @argv_globbed = map { File::Glob::bsd_glob($_) } @ARGV; -} -else { - @argv_globbed = map { glob } @ARGV; -} - -for ( @argv_globbed ) { - push( @tests, -d $_ ? all_in( { recurse => $recurse, start => $_ } ) : $_ ) -} - -if ( @tests ) { - shuffle(@tests) if $shuffle; - if ( $dry ) { - print join( "\n", @tests, '' ); - } - else { - print "# ", scalar @tests, " tests to run\n" if $Test::Harness::debug; - runtests(@tests); - } -} - -sub print_version { - printf( "prove v%s, using Test::Harness v%s and Perl v%vd\n", - $VERSION, $Test::Harness::VERSION, $^V ); -} - -__END__ - -=head1 NAME - -prove -- A command-line tool for running tests against Test::Harness - -=head1 SYNOPSIS - -prove [options] [files/directories] - -=head1 OPTIONS - - -b, --blib Adds blib/lib to the path for your tests, a la "use blib" - -d, --debug Includes extra debugging information - -D, --dry Dry run: Show the tests to run, but don't run them - -h, --help Display this help - -H, --man Longer manpage for prove - -I Add libraries to @INC, as Perl's -I - -l, --lib Add lib to the path for your tests - --perl Sets the name of the Perl executable to use - -r, --recurse Recursively descend into directories - -s, --shuffle Run the tests in a random order - --strap Define strap class to use - -T Enable tainting checks - -t Enable tainting warnings - --timer Print elapsed time after each test file - -v, --verbose Display standard output of test scripts while running them - -V, --version Display version info - -Single-character options may be stacked. Default options may be set by -specifying the PROVE_SWITCHES environment variable. - -=head1 OVERVIEW - -F is a command-line interface to the test-running functionality -of C. With no arguments, it will run all tests in the -current directory. - -Shell metacharacters may be used with command lines options and will be exanded -via C. - -=head1 PROVE VS. "MAKE TEST" - -F has a number of advantages over C when doing development. - -=over 4 - -=item * F is designed as a development tool - -Perl users typically run the test harness through a makefile via -C. That's fine for module distributions, but it's -suboptimal for a test/code/debug development cycle. - -=item * F is granular - -F lets your run against only the files you want to check. -Running C checks every F<*.t> in F, -plus F. - -=item * F has an easy verbose mode - -F has a C<-v> option to see the raw output from the tests. -To do this with C, you must set C in -the environment. - -=item * F can run under taint mode - -F's C<-T> runs your tests under C, and C<-t> runs them -under C. - -=item * F can shuffle tests - -You can use F's C<--shuffle> option to try to excite problems -that don't show up when tests are run in the same order every time. - -=item * F doesn't rely on a make tool - -Not everyone wants to write a makefile, or use L -to do so. F has no external dependencies. - -=item * Not everything is a module - -More and more users are using Perl's testing tools outside the -context of a module distribution, and may not even use a makefile -at all. - -=back - -=head1 COMMAND LINE OPTIONS - -=head2 -b, --blib - -Adds blib/lib to the path for your tests, a la "use blib". - -=head2 -d, --debug - -Include debug information about how F is being run. This -option doesn't show the output from the test scripts. That's handled -by -v,--verbose. - -=head2 -D, --dry - -Dry run: Show the tests to run, but don't run them. - -=head2 -I - -Add libraries to @INC, as Perl's -I. - -=head2 -l, --lib - -Add C to @INC. Equivalent to C<-Ilib>. - -=head2 --perl - -Sets the C environment variable, which controls what -Perl executable will run the tests. - -=head2 -r, --recurse - -Descends into subdirectories of any directories specified, looking for tests. - -=head2 -s, --shuffle - -Sometimes tests are accidentally dependent on tests that have been -run before. This switch will shuffle the tests to be run prior to -running them, thus ensuring that hidden dependencies in the test -order are likely to be revealed. The author hopes the run the -algorithm on the preceding sentence to see if he can produce something -slightly less awkward. - -=head2 --strap - -Sets the HARNESS_STRAP_CLASS variable to set which Test::Harness::Straps -variable to use in running the tests. - -=head2 -t - -Runs test programs under perl's -t taint warning mode. - -=head2 -T - -Runs test programs under perl's -T taint mode. - -=head2 --timer - -Print elapsed time after each test file - -=head2 -v, --verbose - -Display standard output of test scripts while running them. Also sets -TEST_VERBOSE in case your tests rely on them. - -=head2 -V, --version - -Display version info. - -=head1 BUGS - -Please use the CPAN bug ticketing system at L. -You can also mail bugs, fixes and enhancements to -C<< >>. - -=head1 TODO - -=over 4 - -=item * - -Shuffled tests must be recreatable - -=back - -=head1 AUTHORS - -Andy Lester C<< >> - -=head1 COPYRIGHT - -Copyright 2004-2006 by Andy Lester C<< >>. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L. - -=cut diff -urN Test.old/Harness/Changes Test/Harness/Changes --- perl-5.10.0/lib/Test.old/Harness/Changes 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/Changes 1970-01-01 01:00:00.000000000 +0100 @@ -1,727 +0,0 @@ -Revision history for Perl extension Test::Harness - -NEXT - [FIXES] - * prove's --perl=/path/to/file wasn't taking a value. - * prove's version number was not getting incremented. From now on, - prove's $VERSION will match Test::Harness's $VERSION, and I added - a test to make sure this is the case. - - [ENHANCEMENTS] - * Added test straps overload via HARNESS_STRAP_OVERLOAD environment - variable. prove now takes a --strap=class parameter. Thanks, - Adam Kennedy. - -2.63_01 Fri Jun 30 16:59:50 CDT 2006 - [ENHANCEMENTS] - * Failed tests used to say "NOK x", and now say "NOK x/y". - Thanks to Will Coleda. - - * Added the Test::Harness::Results object, so we have a well-defined - object, and not just a hash that we pass around. Thanks to YAPC::NA - 2006 Hackathon! - -2.62 Thu Jun 8 14:11:57 CDT 2006 - [FIXES] - * Restored the behavior of dying if any subtests failed. This is a - pretty crucial bug that I should have fixed long ago. Not having this - means that CPANPLUS will install modules even if their tests fail. :-( - -2.60 Wed May 24 14:48:44 CDT 2006 - [FIXES] - * Fixed the headers in the summary failure table. - -2.58 Sat May 13 22:53:53 CDT 2006 - No changes. Released to the world with a non-beta number. - -2.57_06 Sun Apr 23 00:55:43 CDT 2006 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Anything that displays a percentage of tests passed has been - removed. Output at the end of failing runs is now different. - - [FIXES] - * Fixed the TODO-passing patch from 2.57_05. - - [ENHANCEMENTS] - * The unnecessary display of percentages of tests passing and failing - have been removed. Tests are not a percentage game. - - * Caches the results of _default_inc(), which is expensive because - of shelling out to get the pathnames. Benchmarking was showing that - 15% of Test::Harness's time was spent in this function. For test - suites with many test files, this can be significant. With this - speedup, the "make test" for the Perl core speeds up 2.5%. - Thanks to Nicholas Clark for finding this. - - [DOCUMENTATION] - * Fixed HARNESS_PERL_SWITCHES typo. Thanks, Andreas Koenig. - - * Added docs on HARNESS_TIMER and --timer. Thanks, Mike O'Regan. - -2.57_05 Wed Apr 19 00:31:10 CDT 2006 - [ENHANCEMENTS] - * Now shows details of the tests that unexpectedly pass, instead of - just giving a number. Thanks, demerphq! - - [INTERNALS] - * Fixed globbing to work under Perls before 5.6.0. Before Perl 5.6.0, - prove just uses the internal glob() function. - -2.57_04 Mon Apr 17 13:35:10 CDT 2006 - [ENHANCEMENTS] - * prove's globbing is now done with File::Glob::bsd_glob(). - Otherwise, "prove c:\program files\svk\t\*" fails because glob() - considers it to be two patterns, splitting on whitespace. Thanks to - Audrey Tang. - - [DOCUMENTATION] - * Added information about other TAP implementations in other languages. - -2.57_03 Dec 31 2005 - - [THINGS THAT MAY BREAK YOUR CODE] - * Internal functions _run_all_tests() and _show_results() no longer - exist. You shouldn't have been using them anyway since they're - prepended with underscores. - - [INTERNALS] - * Added the ability to send test output to a filehandle of - one's choosing. Two internal functions are now exposed: - execute_tests() and get_results() (formerly _run_all_tests() and - _show_results()). This should allow CPANPLUS to work properly - with Module::Build. Thanks to Ken Williams. - - [DOCUMENTATION] - * Hid the documentation for the private methods in Test::Harness::Straps. - -2.57_02 Fri Dec 30 23:51:17 CST 2005 - [THINGS THAT MAY BREAK YOUR CODE] - * prove's --ext option has been removed. I'm betting that nobody used it. - - [ENHANCEMENTS] - * prove can now take -w and -W switches, analogous to those in perl. - This means that "prove -wlb t/*.t" is exactly the same as "make test". - Thanks to Rob Kinyon. - * Started a Test::Harness::Util module for code that may be reused - by other Harness-using modules. - - [INTERNALS] - * The t/prove*.t tests now use $^X to call prove. Thanks to Yves Orton. - * Test::Harness::Straps no longer uses Win32::GetShortPathName(). - Thanks to Gisle Aas. - -2.57_01 Mon Dec 26 01:39:07 CST 2005 - [FIXES] - * Removed code and docs mentioning HARNESS_IGNORE_EXITCODE, which - is not used anywhere. - - [ENHANCEMENTS] - * If we have hi-res timings, then they're shown in integer - milliseconds, rather than fractional seconds. - - * Added the --perl switch to prove. - - [DOCUMENTATION] - * Added links to CPAN support sites. - -2.56 Wed Sep 28 16:04:00 CDT 2005 - [FIXES] - * Incorporate bleadperl patch to fix Test::Harness on VMS. - -2.54 Wed Sep 28 09:52:19 CDT 2005 - [FIXES] - * Test counts were wrong, so wouldn't install on Perls < 5.8.0. - -2.53_02 Thu Aug 25 21:37:01 CDT 2005 - [FIXES] - * File order in prove is now sorted within the directory. It's not - the sorting that's important as much as the deterministic results. - Thanks to Adam Kennedy and Casey West for pointing this out, - independently of each other, with 12 hours of the other. - - [INTERNALS] - * Fix calls to podusage() to not use the DATA typeglob. Thanks sungo. - -2.53_01 Sun Jul 10 10:45:27 CDT 2005 - [FIXES] - * If we go over 100,000 tests, it used to print out a warning for - every test over 100,000. Now, we stop after the first. Thanks to - Sebastien Aperghis-Tramoni. - -2.52 Sun Jun 26 23:05:19 CDT 2005 - No changes - -2.51_02 - [ENHANCEMENTS] - * The Test::Harness timer is now off by default. Set HARNESS_TIMER - true if you want it. Added --timer flag to prove. - -2.50_01 - [FIXES] - * Call CORE::time() to figure out if we should print when we're - printing once per second. Otherwise, we're using Time::HiRes' - version of it. Thanks, Nicholas Clark. - -2.50 Tue Jun 21 14:32:12 CDT 2005 - [FIXES] - * Added some includes in t/strap-analyze.t to make Cygwin happy. - -2.49_02 Tue Jun 21 09:54:44 CDT 2005 - [FIXES] - * Added some includes in t/test_harness.t to make Cygwin happy. - -2.49_01 Fri Jun 10 15:37:31 CDT 2005 - [ENHANCEMENTS] - * Now shows elapsed time in 1000ths of a second if Time::HiRes - is available. - - [FIXES] - * Test::Harness::Iterator didn't have a 1; at the end. Thanks to - Steve Peters for finding it. - -2.48 Fri Apr 22 22:41:46 CDT 2005 - Released after weeks of non-complaint. - -2.47_03 Wed Mar 2 16:52:55 CST 2005 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test::Harness now requires Perl 5.005_03 or above. - - [FIXES] - * Fixed incorrect "confused by tests in wrong order" error in 2.47_02. - -2.47_02 Tue Mar 1 23:15:47 CST 2005 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test directives for skip tests used to be anything that matches - /^skip/i, like the word "skipped", but now it must match - /^skip\s+/i. - - [ENHANCEMENTS] - * T::H now sets environment variable HARNESS_VERSION, in case a test - program wants to know what version of T::H it's running under. - -2.47_01 Mon Feb 21 01:14:13 CST 2005 - [FIXES] - * Fixed a problem submitted by Craig Berry: - - Several of the Test::Harness tests now fail on VMS with the - following warning: - - Can't find string terminator "]" anywhere before EOF at -e line 1. - - The problem is that when a command is piped to the shell and that - command has a newline character embedded in it, the part after - the newline is invisible to the shell. The patch below corrects - that by escaping the newline so it is not subject to variable - interpolation until it gets to the child's Perl one-liner. - - [ENHANCEMENTS] - * Test::Harness::Straps now has diagnostic gathering without changing - how tests are run. It also adds these messages by default. - Note that the new method, _is_diagnostic(), is for internal - use only. It may change soon. Thanks to chromatic. - - [DOCUMENTATION] - * Expanded Test::Harness::TAP.pod, and added examples. - - * Fixed a crucial documentation typo in Test::Harness::Straps. - -2.46 Thu Jan 20 11:50:59 CST 2005 - Released. - -2.45_02 Fri Dec 31 14:57:33 CST 2004 - [ENHANCEMENTS] - * Turns off buffering on both STDERR and STDOUT, so that the two - output handles don't get out of sync with each other. Thanks to - David Wheeler. - - * No longer requires, or supports, the HARNESS_OK_SLOW environment - variable. Test counts are only updated once per second, which - used to require having HARNESS_OK_SLOW set. - -2.45_01 Fri Dec 17 22:39:17 CST 2004 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test::Harness now requires Perl 5.004_05. - - * We no longer try to print a stack if a coredump is detected. - - [FIXES] - * Reverted Test::Harness::Iterator::next()'s use of readline, since - it fails under Perl 5.5.4. - - * We no longer try to print a stack if a coredump is detected. - This means that the external problems we've had with wait.ph - now disappear. This resolves a number of problems that various - Linux distros have, and closes a couple of RT tickets like #2729 - and #7716. - - [ENHANCEMENTS] - * Added Test::Harness->strap() method to access the internal strap. - - [DOCUMENTATION] - * Obfuscated the rt.cpan.org email address. The damage is already - done, but at least we'll have it hidden going forward. - -2.44 Tue Nov 30 18:38:17 CST 2004 - [INTERNALS] - * De-anonymized the callbacks and handlers in Test::Harness, mostly - so I can profile better. - - * Checks _is_header() only if _is_line() fails first. No point - in checking every line of the input for something that can only - occur once. - - * Inline the _detailize() function, which was getting called once - per line of input. Reduced execution time about 5-7%. - - * Removed unnecessary temporary variables in Test::Harness::Straps - and in Test::Harness::Iterator. - -2.43_02 Thu Nov 25 00:20:36 CST 2004 - [ENHANCEMENTS] - * Added more debug output if $Test::Harness::Debug is on. - - [FIXES] - * Test::Harness now removes default paths from the paths that it - sets in PERL5LIB. This fixes RT #5649. Thanks, Schwern. - - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test::Harness::Straps' constructor no longer will work as an - object method. You can't say $strap->new any more, but that's - OK because you never really wanted to anyway. - -2.43_01 - [FIXES] - * Added workaround for local $ENV{} bug on Cygwin to - t/prove-switches.t. See the following RT tickets for details. - - https://rt.cpan.org/Ticket/Display.html?id=6452 - http://rt.perl.org/rt3/Ticket/Display.html?id=30952 - - -2.42 Wed Apr 28 22:13:11 CDT 2004 - [ENHANCEMENTS] - * prove -v now sets TEST_VERBOSE in case your tests rely on them. - * prove globs the command line, since Win32's shell doesn't. - - [FIXES] - * Cross-platform test fixes on t/prove-globbing.t - - -2.40 Tue Dec 30 20:38:59 CST 2003 - [FIXES] - * Test::Harness::Straps should now properly quote on VMS. - - [ENHANCEMENTS] - * prove now takes a -l option to add lib/ to @INC. Now when you're - building a module, you don't have to do a make before you run - the prove. Thanks to David Wheeler for the idea. - - [INTERNALS] - * Internal functions corestatus() and canonfailed() prepended with - underscores, to indicate such. - - * Gratuitous text-only changes in Test::Harness::Iterator. - - * All tests now do their use_ok() in a BEGIN block. Some of the - use_ok() calls were too much of a hassle to put into a BEGIN block, - so I changed them to regular use calls. - - -2.38 Mon Nov 24 22:36:18 CST 2003 - Released. See changes below. - -2.37_03 Tue Nov 18 23:51:38 CST 2003 - [ENHANCEMENTS] - * prove -V now shows the Perl version being used. - * Now there's a HARNESS_DEBUG flag that shows diagnostics as the - harness runs the tests. This is different from HARNESS_VERBOSE, - which shows test output, but not information about the harness - itself. - * Added _command_line() to the Strap API. - - [FIXES] - * Bad interaction with Module::Build: The strap was only checking - $ENV{HARNESS_PERL_SWITCHES} for definedness, but not emptiness. - It now also strips any leading or trailing whitesapce from the - switches. - * Test::Harness and prove only quote those parms that actually need - to be quoted: Have some whitespace and aren't already quoted. - -2.36 Fri Nov 14 09:24:44 CST 2003 - [FIXES] - * t/prove-includes.t properly ignores PROVE_SWITCHES that you may - already have set. - -2.35_02 Thu Nov 13 09:57:36 CST 2003 - [ENHANCEMENTS] - * prove's --blib now works just like the blib pragma. - -2.35_01 Wed Nov 12 23:08:45 CST 2003 - [FIXES] - * Fixed taint-handling and path preservation under MacOS. Thanks to - Schwern for the patch and the tests. - - * Preserves case of -t or -T in the shebang line of the test. - - [ENHANCEMENTS] - * Added -t to prove analogous to Perl's -t. Removed the --taint - switch. - - * prove can take default options from the PROVE_SWITCHES variable. - - * Added HARNESS_PERL to allow you to specify the Perl interpreter - to run the tests as. - - * prove's --perl switch sets the HARNESS_PERL on the fly for you. - - * Quotes the switches and filename in the subprogram. This helps - with filenames with spaces that are subject to shell mangling. - - -2.34 Sat Nov 8 22:09:15 CST 2003 - [FIXES] - * Allowed prove to run on Perl versions < 5.6.0. - - [ENHANCEMENTS] - * Command-line switches to prove may now be stacked. - * Added check for proper Pod::Usage version. - * "make clean" does a better job of cleaning up after itself. - - -2.32 Fri Nov 7 09:41:21 CST 2003 - Test::Harness now includes a powerful development tool to help - programmers work with automated tests. The prove utility runs - test files against the harness, like a "make test", but with many - advantages: - - * prove is designed as a development tool - Perl users typically run the test harness through a makefile via - "make test". That's fine for module distributions, but it's - suboptimal for a test/code/debug development cycle. - - * prove is granular - prove lets your run against only the files you want to check. - Running "prove t/live/ t/master.t" checks every *.t in t/live, plus - t/master.t. - - * prove has an easy verbose mode - To get full test program output from "make test", you must set - "HARNESS_VERBOSE" in the environment. prove has a "-v" option. - - * prove can run under taint mode - prove's "-T" runs your tests under "perl -T". - - * prove can shuffle tests - You can use prove's "--shuffle" option to try to excite problems - that don't show up when tests are run in the same order every time. - - * Not everything is a module - More and more users are using Perl's testing tools outside the - context of a module distribution, and may not even use a makefile at - all. - - Prove requires Pod::Usage, which is standard after Perl 5.004. - - I'm very excited about prove, and hope that developers will begin - adopting it to their coding cycles. I welcome your comments at - andy@petdance.com. - - There are also some minor bug fixes in Test::Harness itself, listed - below in the 2.31_* notes. - - -2.31_05 Thu Nov 6 14:56:22 CST 2003 - [FIXES] - - If a MacPerl script had a shebang with -T, the -T wouldn't get - passed as a switch. - - Removed the -T on three *.t files, which didn't need them, and - which were causing problems. - - Conditionally installs bin/prove, depending on whether Pod::Usage - is available, which prove needs. - - Removed old leftover code from Makefile.PL. - -2.31_04 Mon Nov 3 23:36:06 CST 2003 - Minor tweaks here and there, almost ready to release. - -2.31_03 Mon Nov 3 08:50:36 CST 2003 - [FEATURES] - - prove is almost feature-complete. Removed the handling of - --exclude for excluding certain tests. It may go back in the - future. - - prove -d is now debug. Dry is prove -D. - -2.31_02 Fri Oct 31 23:46:03 CST 2003 - [FEATURES] - - Added many more switches to prove: -d for dry run, and -b for - blib. - - [FIXES] - - T:H:Straps now recognizes MSWin32 in $^0. - - RT#3811: Could do regex matching on garbage in _is_test(). - Fixed by Yves Orton - - RT#3827: Strips backslashes from and normalizes @INC entries - for Win32. Fixed by Yves Orton. - - [INTERNALS] - - Added $self->{_is_macos} to the T:H:Strap object. - - t/test-harness.t sorts its test results, rather than relying on - internal key order. - -2.31_01 - [FEATURES] - - Added "prove" script to run a test or set of tests through the - harness. Thanks to Curtis Poe for the foundation. - - [DOCUMENTATION] - - Fixed POD problem in Test::Harness::Assert - -2.30 Thu Aug 14 20:04:00 CDT 2003 - No functional changes in this version. It's only to make some doc - tweaks, and bump up the version number in T:H:Straps. - - [DOCUMENTATION] - - Changed Schwern to Andy as the maintainer. - - Incorporated the TODO file into Harness.pm proper. - - Cleaned up formatting in Test::Harness::Straps. - -2.29 Wed Jul 17 14:08:00 CDT 2003 - - Released as 2.29. - -2.28_91 Sun Jul 13 00:10:00 CDT 2003 - [ENHANCEMENTS] - - Added support for HARNESS_OK_SLOW. This will make a significant - speedup for slower connections. - - Folded in some changes from bleadperl that spiff up the - failure reports. - - [INTERNALS] - - Added some isa_ok() checks to the tests. - - All Test::Harness* modules are used by use_ok() - - Fixed the prototype for the canonfailed() function, not that - it matters since it's never called without parens. - -2.28_90 Sat Jul 05 20:21:00 CDT 2003 - [ENHANCEMENTS] - - Now, when you run a test harnessed, the numbers don't fly by one - at a time, one update per second. This significantly speeds - up the run time for running thousands of tests. *COUGH* - Regexp::Common *COUGH* - -2.28 Thu Apr 24 14:39:00 CDT 2003 - - No functional changes. - -2.27_05 Mon Apr 21 15:55:00 CDT 2003 - - No functional changes. - - Fixed circular depency in the test suite. Thanks, Rob Brown. - -2.27_04 Sat Apr 12 21:42:00 CDT 2003 - - Added test for $Test::Harness::Switches patch below. - -2.27_03 Thu Apr 03 10:47:00 CDT 2003 - - Fixed straps not respecting $Test::Harness::Switches. Thanks - to Miyagawa for the patch. - - Added t/pod.t to test POD validity. - -2.27_02 Mon Mar 24 13:17:00 CDT 2003 -2.27_01 Sun Mar 23 19:46:00 CDT 2003 - - Handed over to Andy Lester for further maintenance. - - Fixed when the path to perl contains spaces on Windows - * Stas Bekman noticed that tests with no output at all were - interpreted as passing - - MacPerl test tweak for busted exit codes (bleadperl 17345) - - Abigail and Nick Clark both hit the 100000 "huge test that will - suck up all your memory" limit with legit tests. Made the check - smarter to allow large, planned tests to work. - - Partial fix of stats display when a test fails only because there's - too many tests. - - Made wait.ph and WCOREDUMP anti-vommit protection more robust in - cases where wait.ph loads but WCOREDUMP() pukes when run. - - Added a LICENSE. - - Ilya noticed the per test skip reason was accumlating between tests. - -2.26 Wed Jun 19 16:58:02 EDT 2002 - - Workaround for MacPerl's lack of a working putenv. It will never - see the PERL5LIB environment variable (perl@16942). - -2.25 Sun Jun 16 03:00:33 EDT 2002 - - $Strap is now a global to allow Test::Harness::Straps - experimentation. - - Little spelling nit in a diagnostic. - - Chris Richmond noted that the runtests() docs were wrong. It will - die, not return false, when any tests fail. This is silly, but - historically necessary for 'make test'. Docs corrected. - - MacPerl test fixes from Pudge. (mutation of bleadperl@16989) - - Undef warning introduced in 2.24 on skipped tests with no reasons - fixed. - * Test::Harness now depends on File::Spec - -2.24 Wed May 29 19:02:18 EDT 2002 - * Nikola Knezevic found a bug when tests are completely skipped - but no reason is given it was considered a failure. - * Made Test::Harness::Straps->analyze_file & Test::Harness a bit - more graceful when the test doesn't exist. - -2.23 Wed May 22 12:59:47 EDT 2002 - - reason for all skip wasn't being displayed. Broken in 2.20. - - Changed the wait status tests to conform with POSIX standards. - - Quieted some SYSTEM$ABORT noise leaking out from dying test tests - on VMS. - -2.22 Fri May 17 19:01:35 EDT 2002 - - Fixed parsing of #!/usr/bin/perl-current to not see a -t. - (RT #574) - - Fixed exit codes on MPE/iX - -2.21 Mon May 6 00:43:22 EDT 2002 - - removed a bunch of dead code left over after 2.20's gutting. - - The fix for the $^X "bug" added in 2.02 has been removed. It - caused more trouble than the old bug (I'd never seen a problem - before anyway) - - 2.20 broke $verbose - -2.20 Sat May 4 22:31:20 EDT 2002 - * An almost complete conversion of the Test::Harness test parsing - to use Test::Harness::Straps. - -2.04 Tue Apr 30 00:54:49 EDT 2002 - * Changing the output format of skips - - Taking into account VMS's special exit codes in the tests. - -2.03 Thu Apr 25 01:01:34 EDT 2002 - * $^X fix made safer. - - Noise from loading wait.ph to analyze core files supressed - - MJD found a situation where a test could run Test::Harness - out of memory. Protecting against that specific case. - - Made the 1..M docs a bit clearer. - - Fixed TODO tests so Test::Harness does not display a NOK for - them. - - Test::Harness::Straps->analyze_file() docs were not clear as to - its effects - -2.02 Thu Mar 14 18:06:04 EST 2002 - * Ken Williams fixed the long standing $^X bug. - * Added HARNESS_VERBOSE - * Fixed a bug where Test::Harness::Straps was considering a test that - is ok but died as passing. - - Added the exit and wait codes of the test to the - analyze_file() results. - -2.01 Thu Dec 27 18:54:36 EST 2001 - * Added 'passing' to the results to tell you if the test passed - * Added Test::Harness::Straps example (examples/mini_harness.plx) - * Header-at-end tests were being interpreted as failing sometimes - - The 'skip_all' results from analyze* was not being set - - analyze_fh() and analyze_file() now work more efficiently, reading - line-by-line instead of slurping as before. - -2.00 Sun Dec 23 19:13:57 EST 2001 - - Fixed a warning on VMS. - - Removed a little unnecessary code from analyze_file() - - Made sure filehandles are getting closed - - analyze() now considers "not \nok" to be a failure (VMSism) - but Test::Harness still doesn't. - -2.00_05 Mon Dec 17 22:08:02 EST 2001 - * Wasn't filtering @INC properly when a test is run with -T, caused the - command line to be too long on VMS. VMS should be 100% now. - - Little bug in the skip 'various reasons' logic. - - Minor POD nit in 5.004_04 - - Little speling mistak - -2.00_04 Sun Dec 16 00:33:32 EST 2001 - * Major Test::Harness::Straps doc bug. - -2.00_03 Sat Dec 15 23:52:17 EST 2001 - * First release candidate - * 'summary' is now 'details' - * Test #1 is now element 0 on the details array. It works out better - that way. - * analyze_file() is more portable, but no longer taint clean - * analyze_file() properly preserves @INC and handles -T switches - - minor mistake in the test header line parsing - -1.26 Mon Nov 12 15:44:01 EST 2001 - * An excuse to upload a new version to CPAN to get Test::Harness - back on the index. - -2.00_00 Sat Sep 29 00:12:03 EDT 2001 - * Partial gutting of the internals - * Added Test::Harness::Straps - -1.25 Tue Aug 7 08:51:09 EDT 2001 - * Fixed a bug with tests failing if they're all skipped - reported by Stas Bekman. - - Fixed a very minor warning in 5.004_04 - - Fixed displaying filenames not from @ARGV - - Merging with bleadperl - - minor fixes to the filename in the report - - '[no reason given]' skip reason - -1.24 Tue Aug 7 08:51:09 EDT 2001 - - Added internal information about number of todo tests - -1.23 Tue Jul 31 15:06:47 EDT 2001 - - Merged in Ilya's "various reasons" patch - * Fixed "not ok 23 - some name # TODO" style tests - -1.22 Mon Jun 25 02:00:02 EDT 2001 - * Fixed bug with failing tests using header at end. - - Documented how Test::Harness deals with garbage input - - Turned on test counter mismatch warning - -1.21 Wed May 23 19:22:53 BST 2001 - * No longer considered unstable. Merging back with the perl core. - - Fixed minor nit about the report summary - - Added docs on the meaning of the failure report - - Minor POD nits fixed mirroring perl change 9176 - - TODO and SEE ALSO expanded - -1.20 Wed Mar 14 23:09:20 GMT 2001 by Michael G Schwern *UNSTABLE* - * Fixed and tested with 5.004! - - Added EXAMPLE docs - - Added TODO docs - - Now uneffected by -l, $\ or $, - -1.19 Sat Mar 10 00:43:29 GMT 2001 by Michael G Schwern *UNSTABLE* - - More internal reworking - * Removed use of experimental /(?>...)/ feature for backwards compat - * Removed use of open(my $fh, $file) for backwards compatibility - * Removed use of Tie::StdHandle in tests for backwards compat - * Added dire warning that this is unstable. - - Added some tests from the old CPAN release - -1.18 Mon Mar 5 17:35:11 GMT 2001 by Michael G Schwern - * Under new management! - * Test::Harness is now being concurrently shipped on CPAN as well - as in the core. - - Switched "our" for "use vars" and moved the minimum version back - to 5.004. This may be optimistic. - - -*** Missing version history to be extracted from Perl changes *** - - -1.07 Fri Feb 23 1996 by Andreas Koenig - - Gisle sent me a documentation patch that showed me, that the - unless(/^#/) is unnessessary. Applied the patch and deleted the block - checking for "comment" lines. -- All lines are comment lines that do - not match /^1\.\.([0-9]+)/ or /^(not\s+)?ok\b/. - - Ilyaz request to print "ok (empty test case)" whenever we say 1..0 - implemented. - - Harness now doesn't abort anymore if we received confused test output, - just warns instead. - -1.05 Wed Jan 31 1996 by Andreas Koenig - - More updates on docu and introduced the liberality that the script - output may omit the test numbers. - -1.03 Mon January 28 1996 by Andreas Koenig - - Added the statistics for subtests. Updated the documentation. - -1.02 by Andreas Koenig - - This version reports a list of the tests that failed accompanied by - some trivial statistics. The older (unnumbered) version stopped - processing after the first failed test. - - Additionally it reports the exit status if there is one. - - diff -urN Test.old/Harness/Iterator.pm Test/Harness/Iterator.pm --- perl-5.10.0/lib/Test.old/Harness/Iterator.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/Iterator.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,70 +0,0 @@ -package Test::Harness::Iterator; - -use strict; -use vars qw($VERSION); -$VERSION = 0.02; - -=head1 NAME - -Test::Harness::Iterator - Internal Test::Harness Iterator - -=head1 SYNOPSIS - - use Test::Harness::Iterator; - my $it = Test::Harness::Iterator->new(\*TEST); - my $it = Test::Harness::Iterator->new(\@array); - - my $line = $it->next; - -=head1 DESCRIPTION - -B - -This is a simple iterator wrapper for arrays and filehandles. - -=head2 new() - -Create an iterator. - -=head2 next() - -Iterate through it, of course. - -=cut - -sub new { - my($proto, $thing) = @_; - - my $self = {}; - if( ref $thing eq 'GLOB' ) { - bless $self, 'Test::Harness::Iterator::FH'; - $self->{fh} = $thing; - } - elsif( ref $thing eq 'ARRAY' ) { - bless $self, 'Test::Harness::Iterator::ARRAY'; - $self->{idx} = 0; - $self->{array} = $thing; - } - else { - warn "Can't iterate with a ", ref $thing; - } - - return $self; -} - -package Test::Harness::Iterator::FH; -sub next { - my $fh = $_[0]->{fh}; - - # readline() doesn't work so good on 5.5.4. - return scalar <$fh>; -} - - -package Test::Harness::Iterator::ARRAY; -sub next { - my $self = shift; - return $self->{array}->[$self->{idx}++]; -} - -"Steve Peters, Master Of True Value Finding, was here."; diff -urN Test.old/Harness/Point.pm Test/Harness/Point.pm --- perl-5.10.0/lib/Test.old/Harness/Point.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/Point.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,143 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -package Test::Harness::Point; - -use strict; -use vars qw($VERSION); -$VERSION = '0.01'; - -=head1 NAME - -Test::Harness::Point - object for tracking a single test point - -=head1 SYNOPSIS - -One Test::Harness::Point object represents a single test point. - -=head1 CONSTRUCTION - -=head2 new() - - my $point = new Test::Harness::Point; - -Create a test point object. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - - return $self; -} - -=head1 from_test_line( $line ) - -Constructor from a TAP test line, or empty return if the test line -is not a test line. - -=cut - -sub from_test_line { - my $class = shift; - my $line = shift or return; - - # We pulverize the line down into pieces in three parts. - my ($not, $number, $extra) = ($line =~ /^(not )?ok\b(?:\s+(\d+))?\s*(.*)/) or return; - - my $point = $class->new; - $point->set_number( $number ); - $point->set_ok( !$not ); - - if ( $extra ) { - my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 ); - $description =~ s/^- //; # Test::More puts it in there - $point->set_description( $description ); - if ( $directive ) { - $point->set_directive( $directive ); - } - } # if $extra - - return $point; -} # from_test_line() - -=head1 ACCESSORS - -Each of the following fields has a getter and setter method. - -=over 4 - -=item * ok - -=item * number - -=cut - -sub ok { my $self = shift; $self->{ok} } -sub set_ok { - my $self = shift; - my $ok = shift; - $self->{ok} = $ok ? 1 : 0; -} -sub pass { - my $self = shift; - - return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0; -} - -sub number { my $self = shift; $self->{number} } -sub set_number { my $self = shift; $self->{number} = shift } - -sub description { my $self = shift; $self->{description} } -sub set_description { - my $self = shift; - $self->{description} = shift; - $self->{name} = $self->{description}; # history -} - -sub directive { my $self = shift; $self->{directive} } -sub set_directive { - my $self = shift; - my $directive = shift; - - $directive =~ s/^\s+//; - $directive =~ s/\s+$//; - $self->{directive} = $directive; - - my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/); - $self->set_directive_type( $type ); - $reason = "" unless defined $reason; - $self->{directive_reason} = $reason; -} -sub set_directive_type { - my $self = shift; - $self->{directive_type} = lc shift; - $self->{type} = $self->{directive_type}; # History -} -sub set_directive_reason { - my $self = shift; - $self->{directive_reason} = shift; -} -sub directive_type { my $self = shift; $self->{directive_type} } -sub type { my $self = shift; $self->{directive_type} } -sub directive_reason{ my $self = shift; $self->{directive_reason} } -sub reason { my $self = shift; $self->{directive_reason} } -sub is_todo { - my $self = shift; - my $type = $self->directive_type; - return $type && ( $type eq 'todo' ); -} -sub is_skip { - my $self = shift; - my $type = $self->directive_type; - return $type && ( $type eq 'skip' ); -} - -sub diagnostics { - my $self = shift; - return @{$self->{diagnostics}} if wantarray; - return join( "\n", @{$self->{diagnostics}} ); -} -sub add_diagnostic { my $self = shift; push @{$self->{diagnostics}}, @_ } - - -1; diff -urN Test.old/Harness/Results.pm Test/Harness/Results.pm --- perl-5.10.0/lib/Test.old/Harness/Results.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/Results.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,182 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -package Test::Harness::Results; - -use strict; -use vars qw($VERSION); -$VERSION = '0.01'; - -=head1 NAME - -Test::Harness::Results - object for tracking results from a single test file - -=head1 SYNOPSIS - -One Test::Harness::Results object represents the results from one -test file getting analyzed. - -=head1 CONSTRUCTION - -=head2 new() - - my $results = new Test::Harness::Results; - -Create a test point object. Typically, however, you'll not create -one yourself, but access a Results object returned to you by -Test::Harness::Results. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - - return $self; -} - -=head1 ACCESSORS - -The following data points are defined: - - passing true if the whole test is considered a pass - (or skipped), false if its a failure - - exit the exit code of the test run, if from a file - wait the wait code of the test run, if from a file - - max total tests which should have been run - seen total tests actually seen - skip_all if the whole test was skipped, this will - contain the reason. - - ok number of tests which passed - (including todo and skips) - - todo number of todo tests seen - bonus number of todo tests which - unexpectedly passed - - skip number of tests skipped - -So a successful test should have max == seen == ok. - - -There is one final item, the details. - - details an array ref reporting the result of - each test looks like this: - - $results{details}[$test_num - 1] = - { ok => is the test considered ok? - actual_ok => did it literally say 'ok'? - name => name of the test (if any) - diagnostics => test diagnostics (if any) - type => 'skip' or 'todo' (if any) - reason => reason for the above (if any) - }; - -Element 0 of the details is test #1. I tried it with element 1 being -#1 and 0 being empty, this is less awkward. - - -Each of the following fields has a getter and setter method. - -=over 4 - -=item * wait - -=item * exit - -=cut - -sub set_wait { my $self = shift; $self->{wait} = shift } -sub wait { - my $self = shift; - return $self->{wait} || 0; -} - -sub set_skip_all { my $self = shift; $self->{skip_all} = shift } -sub skip_all { - my $self = shift; - return $self->{skip_all}; -} - -sub inc_max { my $self = shift; $self->{max} += (@_ ? shift : 1) } -sub max { - my $self = shift; - return $self->{max} || 0; -} - -sub set_passing { my $self = shift; $self->{passing} = shift } -sub passing { - my $self = shift; - return $self->{passing} || 0; -} - -sub inc_ok { my $self = shift; $self->{ok} += (@_ ? shift : 1) } -sub ok { - my $self = shift; - return $self->{ok} || 0; -} - -sub set_exit { - my $self = shift; - if ($^O eq 'VMS') { - eval { - use vmsish q(status); - $self->{exit} = shift; # must be in same scope as pragma - } - } - else { - $self->{exit} = shift; - } -} -sub exit { - my $self = shift; - return $self->{exit} || 0; -} - -sub inc_bonus { my $self = shift; $self->{bonus}++ } -sub bonus { - my $self = shift; - return $self->{bonus} || 0; -} - -sub set_skip_reason { my $self = shift; $self->{skip_reason} = shift } -sub skip_reason { - my $self = shift; - return $self->{skip_reason} || 0; -} - -sub inc_skip { my $self = shift; $self->{skip}++ } -sub skip { - my $self = shift; - return $self->{skip} || 0; -} - -sub inc_todo { my $self = shift; $self->{todo}++ } -sub todo { - my $self = shift; - return $self->{todo} || 0; -} - -sub inc_seen { my $self = shift; $self->{seen}++ } -sub seen { - my $self = shift; - return $self->{seen} || 0; -} - -sub set_details { - my $self = shift; - my $index = shift; - my $details = shift; - - my $array = ($self->{details} ||= []); - $array->[$index-1] = $details; -} - -sub details { - my $self = shift; - return $self->{details} || []; -} - -1; diff -urN Test.old/Harness/Straps.pm Test/Harness/Straps.pm --- perl-5.10.0/lib/Test.old/Harness/Straps.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/Straps.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,648 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -package Test::Harness::Straps; - -use strict; -use vars qw($VERSION); -$VERSION = '0.26_01'; - -use Config; -use Test::Harness::Assert; -use Test::Harness::Iterator; -use Test::Harness::Point; -use Test::Harness::Results; - -# Flags used as return values from our methods. Just for internal -# clarification. -my $YES = (1==1); -my $NO = !$YES; - -=head1 NAME - -Test::Harness::Straps - detailed analysis of test results - -=head1 SYNOPSIS - - use Test::Harness::Straps; - - my $strap = Test::Harness::Straps->new; - - # Various ways to interpret a test - my $results = $strap->analyze($name, \@test_output); - my $results = $strap->analyze_fh($name, $test_filehandle); - my $results = $strap->analyze_file($test_file); - - # UNIMPLEMENTED - my %total = $strap->total_results; - - # Altering the behavior of the strap UNIMPLEMENTED - my $verbose_output = $strap->dump_verbose(); - $strap->dump_verbose_fh($output_filehandle); - - -=head1 DESCRIPTION - -B in that the interface is subject to change -in incompatible ways. It is otherwise stable. - -Test::Harness is limited to printing out its results. This makes -analysis of the test results difficult for anything but a human. To -make it easier for programs to work with test results, we provide -Test::Harness::Straps. Instead of printing the results, straps -provide them as raw data. You can also configure how the tests are to -be run. - -The interface is currently incomplete. I contact the author -if you'd like a feature added or something change or just have -comments. - -=head1 CONSTRUCTION - -=head2 new() - - my $strap = Test::Harness::Straps->new; - -Initialize a new strap. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - - $self->_init; - - return $self; -} - -=for private $strap->_init - - $strap->_init; - -Initialize the internal state of a strap to make it ready for parsing. - -=cut - -sub _init { - my($self) = shift; - - $self->{_is_vms} = ( $^O eq 'VMS' ); - $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ ); - $self->{_is_macos} = ( $^O eq 'MacOS' ); -} - -=head1 ANALYSIS - -=head2 $strap->analyze( $name, \@output_lines ) - - my $results = $strap->analyze($name, \@test_output); - -Analyzes the output of a single test, assigning it the given C<$name> -for use in the total report. Returns the C<$results> of the test. -See L. - -C<@test_output> should be the raw output from the test, including -newlines. - -=cut - -sub analyze { - my($self, $name, $test_output) = @_; - - my $it = Test::Harness::Iterator->new($test_output); - return $self->_analyze_iterator($name, $it); -} - - -sub _analyze_iterator { - my($self, $name, $it) = @_; - - $self->_reset_file_state; - $self->{file} = $name; - - my $results = Test::Harness::Results->new; - - # Set them up here so callbacks can have them. - $self->{totals}{$name} = $results; - while( defined(my $line = $it->next) ) { - $self->_analyze_line($line, $results); - last if $self->{saw_bailout}; - } - - $results->set_skip_all( $self->{skip_all} ) if defined $self->{skip_all}; - - my $passed = - (($results->max == 0) && defined $results->skip_all) || - ($results->max && - $results->seen && - $results->max == $results->seen && - $results->max == $results->ok); - - $results->set_passing( $passed ? 1 : 0 ); - - return $results; -} - - -sub _analyze_line { - my $self = shift; - my $line = shift; - my $results = shift; - - $self->{line}++; - - my $linetype; - my $point = Test::Harness::Point->from_test_line( $line ); - if ( $point ) { - $linetype = 'test'; - - $results->inc_seen; - $point->set_number( $self->{'next'} ) unless $point->number; - - # sometimes the 'not ' and the 'ok' are on different lines, - # happens often on VMS if you do: - # print "not " unless $test; - # print "ok $num\n"; - if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) { - $point->set_ok( 0 ); - } - - if ( $self->{todo}{$point->number} ) { - $point->set_directive_type( 'todo' ); - } - - if ( $point->is_todo ) { - $results->inc_todo; - $results->inc_bonus if $point->ok; - } - elsif ( $point->is_skip ) { - $results->inc_skip; - } - - $results->inc_ok if $point->pass; - - if ( ($point->number > 100_000) && ($point->number > ($self->{max}||100_000)) ) { - if ( !$self->{too_many_tests}++ ) { - warn "Enormous test number seen [test ", $point->number, "]\n"; - warn "Can't detailize, too big.\n"; - } - } - else { - my $details = { - ok => $point->pass, - actual_ok => $point->ok, - name => _def_or_blank( $point->description ), - type => _def_or_blank( $point->directive_type ), - reason => _def_or_blank( $point->directive_reason ), - }; - - assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) ); - $results->set_details( $point->number, $details ); - } - } # test point - elsif ( $line =~ /^not\s+$/ ) { - $linetype = 'other'; - # Sometimes the "not " and "ok" will be on separate lines on VMS. - # We catch this and remember we saw it. - $self->{lone_not_line} = $self->{line}; - } - elsif ( $self->_is_header($line) ) { - $linetype = 'header'; - - $self->{saw_header}++; - - $results->inc_max( $self->{max} ); - } - elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) { - $linetype = 'bailout'; - $self->{saw_bailout} = 1; - } - elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) { - $linetype = 'other'; - # XXX We can throw this away, really. - my $test = $results->details->[-1]; - $test->{diagnostics} ||= ''; - $test->{diagnostics} .= $diagnostics; - } - else { - $linetype = 'other'; - } - - $self->callback->($self, $line, $linetype, $results) if $self->callback; - - $self->{'next'} = $point->number + 1 if $point; -} # _analyze_line - - -sub _is_diagnostic_line { - my ($self, $line) = @_; - return if index( $line, '# Looks like you failed' ) == 0; - $line =~ s/^#\s//; - return $line; -} - -=for private $strap->analyze_fh( $name, $test_filehandle ) - - my $results = $strap->analyze_fh($name, $test_filehandle); - -Like C, but it reads from the given filehandle. - -=cut - -sub analyze_fh { - my($self, $name, $fh) = @_; - - my $it = Test::Harness::Iterator->new($fh); - return $self->_analyze_iterator($name, $it); -} - -=head2 $strap->analyze_file( $test_file ) - - my $results = $strap->analyze_file($test_file); - -Like C, but it runs the given C<$test_file> and parses its -results. It will also use that name for the total report. - -=cut - -sub analyze_file { - my($self, $file) = @_; - - unless( -e $file ) { - $self->{error} = "$file does not exist"; - return; - } - - unless( -r $file ) { - $self->{error} = "$file is not readable"; - return; - } - - local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; - if ( $Test::Harness::Debug ) { - local $^W=0; # ignore undef warnings - print "# PERL5LIB=$ENV{PERL5LIB}\n"; - } - - # *sigh* this breaks under taint, but open -| is unportable. - my $line = $self->_command_line($file); - - unless ( open(FILE, "$line|" )) { - print "can't run $file. $!\n"; - return; - } - - my $results = $self->analyze_fh($file, \*FILE); - my $exit = close FILE; - - $results->set_wait($?); - if ( $? && $self->{_is_vms} ) { - $results->set_exit($?); - } - else { - $results->set_exit( _wait2exit($?) ); - } - $results->set_passing(0) unless $? == 0; - - $self->_restore_PERL5LIB(); - - return $results; -} - - -eval { require POSIX; &POSIX::WEXITSTATUS(0) }; -if( $@ ) { - *_wait2exit = sub { $_[0] >> 8 }; -} -else { - *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) } -} - -=for private $strap->_command_line( $file ) - -Returns the full command line that will be run to test I<$file>. - -=cut - -sub _command_line { - my $self = shift; - my $file = shift; - - my $command = $self->_command(); - my $switches = $self->_switches($file); - - $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/); - my $line = "$command $switches $file"; - - return $line; -} - - -=for private $strap->_command() - -Returns the command that runs the test. Combine this with C<_switches()> -to build a command line. - -Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}> -to use a different Perl than what you're running the harness under. -This might be to run a threaded Perl, for example. - -You can also overload this method if you've built your own strap subclass, -such as a PHP interpreter for a PHP-based strap. - -=cut - -sub _command { - my $self = shift; - - return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; - #return qq["$^X"] if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/); - return qq["$^X"] if $^X =~ /\s/ and $^X !~ /^["']/; - return $^X; -} - - -=for private $strap->_switches( $file ) - -Formats and returns the switches necessary to run the test. - -=cut - -sub _switches { - my($self, $file) = @_; - - my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} ); - my @derived_switches; - - local *TEST; - open(TEST, $file) or print "can't open $file. $!\n"; - my $shebang = ; - close(TEST) or print "can't close $file. $!\n"; - - my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ ); - push( @derived_switches, "-$1" ) if $taint; - - # When taint mode is on, PERL5LIB is ignored. So we need to put - # all that on the command line as -Is. - # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not. - if ( $taint || $self->{_is_macos} ) { - my @inc = $self->_filtered_INC; - push @derived_switches, map { "-I$_" } @inc; - } - - # Quote the argument if there's any whitespace in it, or if - # we're VMS, since VMS requires all parms quoted. Also, don't quote - # it if it's already quoted. - for ( @derived_switches ) { - $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ ); - } - return join( " ", @existing_switches, @derived_switches ); -} - -=for private $strap->_cleaned_switches( @switches_from_user ) - -Returns only defined, non-blank, trimmed switches from the parms passed. - -=cut - -sub _cleaned_switches { - my $self = shift; - - local $_; - - my @switches; - for ( @_ ) { - my $switch = $_; - next unless defined $switch; - $switch =~ s/^\s+//; - $switch =~ s/\s+$//; - push( @switches, $switch ) if $switch ne ""; - } - - return @switches; -} - -=for private $strap->_INC2PERL5LIB - - local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; - -Takes the current value of C<@INC> and turns it into something suitable -for putting onto C. - -=cut - -sub _INC2PERL5LIB { - my($self) = shift; - - $self->{_old5lib} = $ENV{PERL5LIB}; - - return join $Config{path_sep}, $self->_filtered_INC; -} - -=for private $strap->_filtered_INC() - - my @filtered_inc = $self->_filtered_INC; - -Shortens C<@INC> by removing redundant and unnecessary entries. -Necessary for OSes with limited command line lengths, like VMS. - -=cut - -sub _filtered_INC { - my($self, @inc) = @_; - @inc = @INC unless @inc; - - if( $self->{_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 ( $self->{_is_win32} ) { - # Lose any trailing backslashes in the Win32 paths - s/[\\\/+]$// foreach @inc; - } - - my %seen; - $seen{$_}++ foreach $self->_default_inc(); - @inc = grep !$seen{$_}++, @inc; - - return @inc; -} - - -{ # Without caching, _default_inc() takes a huge amount of time - my %cache; - sub _default_inc { - my $self = shift; - my $perl = $self->_command; - $cache{$perl} ||= [do { - local $ENV{PERL5LIB}; - my @inc =`$perl -le "print join qq[\\n], \@INC"`; - chomp @inc; - }]; - return @{$cache{$perl}}; - } -} - - -=for private $strap->_restore_PERL5LIB() - - $self->_restore_PERL5LIB; - -This restores the original value of the C environment variable. -Necessary on VMS, otherwise a no-op. - -=cut - -sub _restore_PERL5LIB { - my($self) = shift; - - return unless $self->{_is_vms}; - - if (defined $self->{_old5lib}) { - $ENV{PERL5LIB} = $self->{_old5lib}; - } -} - -=head1 Parsing - -Methods for identifying what sort of line you're looking at. - -=for private _is_diagnostic - - my $is_diagnostic = $strap->_is_diagnostic($line, \$comment); - -Checks if the given line is a comment. If so, it will place it into -C<$comment> (sans #). - -=cut - -sub _is_diagnostic { - my($self, $line, $comment) = @_; - - if( $line =~ /^\s*\#(.*)/ ) { - $$comment = $1; - return $YES; - } - else { - return $NO; - } -} - -=for private _is_header - - my $is_header = $strap->_is_header($line); - -Checks if the given line is a header (1..M) line. If so, it places how -many tests there will be in C<< $strap->{max} >>, a list of which tests -are todo in C<< $strap->{todo} >> and if the whole test was skipped -C<< $strap->{skip_all} >> contains the reason. - -=cut - -# Regex for parsing a header. Will be run with /x -my $Extra_Header_Re = <<'REGEX'; - ^ - (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set - (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason -REGEX - -sub _is_header { - my($self, $line) = @_; - - if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) { - $self->{max} = $max; - assert( $self->{max} >= 0, 'Max # of tests looks right' ); - - if( defined $extra ) { - my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo; - - $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo; - - if( $self->{max} == 0 ) { - $reason = '' unless defined $skip and $skip =~ /^Skip/i; - } - - $self->{skip_all} = $reason; - } - - return $YES; - } - else { - return $NO; - } -} - -=for private _is_bail_out - - my $is_bail_out = $strap->_is_bail_out($line, \$reason); - -Checks if the line is a "Bail out!". Places the reason for bailing -(if any) in $reason. - -=cut - -sub _is_bail_out { - my($self, $line, $reason) = @_; - - if( $line =~ /^Bail out!\s*(.*)/i ) { - $$reason = $1 if $1; - return $YES; - } - else { - return $NO; - } -} - -=for private _reset_file_state - - $strap->_reset_file_state; - -Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>, -etc. so it's ready to parse the next file. - -=cut - -sub _reset_file_state { - my($self) = shift; - - delete @{$self}{qw(max skip_all todo too_many_tests)}; - $self->{line} = 0; - $self->{saw_header} = 0; - $self->{saw_bailout}= 0; - $self->{lone_not_line} = 0; - $self->{bailout_reason} = ''; - $self->{'next'} = 1; -} - -=head1 EXAMPLES - -See F for an example of use. - -=head1 AUTHOR - -Michael G Schwern C<< >>, currently maintained by -Andy Lester C<< >>. - -=head1 SEE ALSO - -L - -=cut - -sub _def_or_blank { - return $_[0] if defined $_[0]; - return ""; -} - -sub set_callback { - my $self = shift; - $self->{callback} = shift; -} - -sub callback { - my $self = shift; - return $self->{callback}; -} - -1; diff -urN Test.old/Harness/t/00compile.t Test/Harness/t/00compile.t --- perl-5.10.0/lib/Test.old/Harness/t/00compile.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/00compile.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,32 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if($ENV{PERL_CORE}) { - chdir 't'; - @INC = '../lib'; - } - else { - unshift @INC, 't/lib'; - } -} - -use Test::More tests => 8; - -BEGIN { use_ok 'Test::Harness' } -BEGIN { diag( "Testing Test::Harness $Test::Harness::VERSION under Perl $] and Test::More $Test::More::VERSION" ) unless $ENV{PERL_CORE}} - -BEGIN { use_ok 'Test::Harness::Straps' } - -BEGIN { use_ok 'Test::Harness::Iterator' } - -BEGIN { use_ok 'Test::Harness::Assert' } - -BEGIN { use_ok 'Test::Harness::Point' } - -BEGIN { use_ok 'Test::Harness::Results' } - -BEGIN { use_ok 'Test::Harness::Util' } - -# If the $VERSION is set improperly, this will spew big warnings. -BEGIN { use_ok 'Test::Harness', 1.1601 } - diff -urN Test.old/Harness/t/assert.t Test/Harness/t/assert.t --- perl-5.10.0/lib/Test.old/Harness/t/assert.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/assert.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,28 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; - -use Test::More tests => 7; - -BEGIN { use_ok( 'Test::Harness::Assert' ); } - - -ok( defined &assert, 'assert() exported' ); - -ok( !eval { assert( 0 ); 1 }, 'assert( FALSE ) causes death' ); -like( $@, '/Assert failed/', ' with the right message' ); - -ok( eval { assert( 1 ); 1 }, 'assert( TRUE ) does nothing' ); - -ok( !eval { assert( 0, 'some name' ); 1 }, 'assert( FALSE, NAME )' ); -like( $@, '/some name/', ' has the name' ); diff -urN Test.old/Harness/t/base.t Test/Harness/t/base.t --- perl-5.10.0/lib/Test.old/Harness/t/base.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/base.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,15 +0,0 @@ -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - - -print "1..1\n"; - -unless (eval 'require Test::Harness') { - print "not ok 1\n"; -} else { - print "ok 1\n"; -} diff -urN Test.old/Harness/t/callback.t Test/Harness/t/callback.t --- perl-5.10.0/lib/Test.old/Harness/t/callback.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/callback.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,69 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use Test::More; -use File::Spec; - -BEGIN { - use vars qw( %samples ); - - %samples = ( - bailout => [qw( header test test test bailout )], - combined => ['header', ('test') x 10], - descriptive => ['header', ('test') x 5 ], - duplicates => ['header', ('test') x 11 ], - head_end => [qw( other test test test test - other header other other )], - head_fail => [qw( other test test test test - other header other other )], - no_nums => ['header', ('test') x 5 ], - out_of_order=> [('test') x 10, 'header', ('test') x 5], - simple => [qw( header test test test test test )], - simple_fail => [qw( header test test test test test )], - 'skip' => [qw( header test test test test test )], - skipall => [qw( header )], - skipall_nomsg => [qw( header )], - skip_nomsg => [qw( header test )], - taint => [qw( header test )], - 'todo' => [qw( header test test test test test )], - todo_inline => [qw( header test test test )], - vms_nit => [qw( header other test test )], - with_comments => [qw( other header other test other test test - test other other test other )], - ); - plan tests => 2 + scalar keys %samples; -} - -BEGIN { use_ok( 'Test::Harness::Straps' ); } - -my $Curdir = File::Spec->curdir; -my $SAMPLE_TESTS = $ENV{PERL_CORE} - ? File::Spec->catdir($Curdir, 'lib', 'sample-tests') - : File::Spec->catdir($Curdir, 't', 'sample-tests'); - -my $strap = Test::Harness::Straps->new; -isa_ok( $strap, 'Test::Harness::Straps' ); -$strap->set_callback( - sub { - my($self, $line, $type, $totals) = @_; - push @out, $type; - } -); - -for my $test ( sort keys %samples ) { - my $expect = $samples{$test}; - - local @out = (); - $strap->analyze_file(File::Spec->catfile($SAMPLE_TESTS, $test)); - - is_deeply(\@out, $expect, "$test callback"); -} diff -urN Test.old/Harness/t/failure.t Test/Harness/t/failure.t --- perl-5.10.0/lib/Test.old/Harness/t/failure.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/failure.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,53 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if ($^O eq 'VMS') { - print '1..0 # Child test output confuses parent test counter'; - exit; - } -} - -BEGIN { - if ( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; - -use Test::More tests => 6; -use File::Spec; - -BEGIN { - use_ok( 'Test::Harness' ); -} - -my $died; -sub prepare_for_death { $died = 0; } -sub signal_death { $died = 1; } - -my $Curdir = File::Spec->curdir; -my $SAMPLE_TESTS = $ENV{PERL_CORE} - ? File::Spec->catdir($Curdir, 'lib', 'sample-tests') - : File::Spec->catdir($Curdir, 't', 'sample-tests'); - -PASSING: { - local $SIG{__DIE__} = \&signal_death; - prepare_for_death(); - eval { runtests( File::Spec->catfile( $SAMPLE_TESTS, "simple" ) ) }; - ok( !$@, "simple lives" ); - is( $died, 0, "Death never happened" ); -} - -FAILING: { - local $SIG{__DIE__} = \&signal_death; - prepare_for_death(); - eval { runtests( File::Spec->catfile( $SAMPLE_TESTS, "too_many" ) ) }; - ok( $@, "$@" ); - ok( $@ =~ m[Failed 1/1], "too_many dies" ); - is( $died, 1, "Death happened" ); -} diff -urN Test.old/Harness/t/from_line.t Test/Harness/t/from_line.t --- perl-5.10.0/lib/Test.old/Harness/t/from_line.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/from_line.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,64 +0,0 @@ -#!perl -Tw - -BEGIN { - if ( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use Test::More tests => 23; - -BEGIN { - use_ok( 'Test::Harness::Point' ); -} - -BASIC_OK: { - my $line = "ok 14 - Blah blah"; - my $point = Test::Harness::Point->from_test_line( $line ); - isa_ok( $point, 'Test::Harness::Point', 'BASIC_OK' ); - is( $point->number, 14 ); - ok( $point->ok ); - is( $point->description, 'Blah blah' ); -} - -BASIC_NOT_OK: { - my $line = "not ok 267 Yada"; - my $point = Test::Harness::Point->from_test_line( $line ); - isa_ok( $point, 'Test::Harness::Point', 'BASIC_NOT_OK' ); - is( $point->number, 267 ); - ok( !$point->ok ); - is( $point->description, 'Yada' ); -} - -CRAP: { - my $point = Test::Harness::Point->from_test_line( 'ok14 - Blah' ); - ok( !defined $point, 'CRAP 1' ); - - $point = Test::Harness::Point->from_test_line( 'notok 14' ); - ok( !defined $point, 'CRAP 2' ); -} - -PARSE_TODO: { - my $point = Test::Harness::Point->from_test_line( 'not ok 14 - Calculate sqrt(-1) # TODO Still too rational' ); - isa_ok( $point, 'Test::Harness::Point', 'PARSE_TODO' ); - is( $point->description, 'Calculate sqrt(-1)' ); - is( $point->directive_type, 'todo' ); - is( $point->directive_reason, 'Still too rational' ); - ok( !$point->is_skip ); - ok( $point->is_todo ); -} - -PARSE_SKIP: { - my $point = Test::Harness::Point->from_test_line( 'ok 14 # skip Not on bucket #6' ); - isa_ok( $point, 'Test::Harness::Point', 'PARSE_SKIP' ); - is( $point->description, '' ); - is( $point->directive_type, 'skip' ); - is( $point->directive_reason, 'Not on bucket #6' ); - ok( $point->is_skip ); - ok( !$point->is_todo ); -} diff -urN Test.old/Harness/t/harness.t Test/Harness/t/harness.t --- perl-5.10.0/lib/Test.old/Harness/t/harness.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/harness.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ -#!/usr/bin/perl -Tw - -BEGIN { - if ( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; - -use Test::More tests => 2; - -BEGIN { - use_ok( 'Test::Harness' ); -} - -my $strap = Test::Harness->strap; -isa_ok( $strap, 'Test::Harness::Straps' ); diff -urN Test.old/Harness/t/inc_taint.t Test/Harness/t/inc_taint.t --- perl-5.10.0/lib/Test.old/Harness/t/inc_taint.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/inc_taint.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,26 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use Test::Harness; -use Test::More tests => 1; -use Dev::Null; - -push @INC, 'we_added_this_lib'; - -tie *NULL, 'Dev::Null' or die $!; -select NULL; -my($tot, $failed) = Test::Harness::execute_tests( - tests => [ $ENV{PERL_CORE} ? 'lib/sample-tests/inc_taint' : 't/sample-tests/inc_taint' ] -); -select STDOUT; - -ok( Test::Harness::_all_ok($tot), 'tests with taint on preserve @INC' ); diff -urN Test.old/Harness/t/nonumbers.t Test/Harness/t/nonumbers.t --- perl-5.10.0/lib/Test.old/Harness/t/nonumbers.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/nonumbers.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,14 +0,0 @@ -if( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) { - print "1..0 # Skip: t/TEST needs numbers\n"; - exit; -} - -print < 52; - -BEGIN { - use_ok( 'Test::Harness::Point' ); - use_ok( 'Test::Harness::Straps' ); -} - -my $strap = Test::Harness::Straps->new; -isa_ok( $strap, 'Test::Harness::Straps', 'new()' ); - - -my $testlines = { - 'not ok' => { - ok => 0 - }, - 'not ok # TODO' => { - ok => 0, - reason => '', - type => 'todo' - }, - 'not ok 1' => { - number => 1, - ok => 0 - }, - 'not ok 11 - this is \\# all the name # skip this is not' => { - description => 'this is \\# all the name', - number => 11, - ok => 0, - reason => 'this is not', - type => 'skip' - }, - 'not ok 23 # TODO world peace' => { - number => 23, - ok => 0, - reason => 'world peace', - type => 'todo' - }, - 'not ok 42 - universal constant' => { - description => 'universal constant', - number => 42, - ok => 0 - }, - ok => { - ok => 1 - }, - 'ok # skip' => { - ok => 1, - type => 'skip' - }, - 'ok 1' => { - number => 1, - ok => 1 - }, - 'ok 1066 - and all that' => { - description => 'and all that', - number => 1066, - ok => 1 - }, - 'ok 11 - have life # TODO get a life' => { - description => 'have life', - number => 11, - ok => 1, - reason => 'get a life', - type => 'todo' - }, - 'ok 2938' => { - number => 2938, - ok => 1 - }, - 'ok 42 - _is_header() is a header \'1..192 todo 4 2 13 192 \\# Skip skip skip because' => { - description => '_is_header() is a header \'1..192 todo 4 2 13 192 \\# Skip skip skip because', - number => 42, - ok => 1 - } -}; -my @untests = ( - ' ok', - 'not', - 'okay 23', - ); - -for my $line ( sort keys %$testlines ) { - my $point = Test::Harness::Point->from_test_line( $line ); - isa_ok( $point, 'Test::Harness::Point' ); - - my $fields = $testlines->{$line}; - for my $property ( sort keys %$fields ) { - my $value = $fields->{$property}; - is( eval "\$point->$property", $value, "$property on $line" ); - # Perls pre-5.6 can't handle $point->$property, and must be eval()d - } -} diff -urN Test.old/Harness/t/point.t Test/Harness/t/point.t --- perl-5.10.0/lib/Test.old/Harness/t/point.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/point.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,58 +0,0 @@ -#!perl -Tw - -BEGIN { - if ( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use Test::More tests => 11; - -BEGIN { - use_ok( 'Test::Harness::Point' ); -} - -my $point = Test::Harness::Point->new; -isa_ok( $point, 'Test::Harness::Point' ); -ok( !$point->ok, "Should start out not OK" ); - -$point->set_ok( 1 ); -ok( $point->ok, "should have turned to true" ); - -$point->set_ok( 0 ); -ok( !$point->ok, "should have turned false" ); - -$point->set_number( 2112 ); -is( $point->number, 2112, "Number is set" ); - -$point->set_description( "Blah blah" ); -is( $point->description, "Blah blah", "Description set" ); - -$point->set_directive( "Go now" ); -is( $point->directive, "Go now", "Directive set" ); - -$point->add_diagnostic( "# Line 1" ); -$point->add_diagnostic( "# Line two" ); -$point->add_diagnostic( "# Third line" ); -my @diags = $point->diagnostics; -is( @diags, 3, "Three lines" ); -is_deeply( - \@diags, - [ "# Line 1", "# Line two", "# Third line" ], - "Diagnostics in list context" -); - -my $diagstr = <diagnostics; -is( $string_diagnostics, $diagstr, "Diagnostics in scalar context" ); diff -urN Test.old/Harness/t/prove-globbing.t Test/Harness/t/prove-globbing.t --- perl-5.10.0/lib/Test.old/Harness/t/prove-globbing.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/prove-globbing.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,32 +0,0 @@ -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use File::Spec; -use Test::More; -plan skip_all => "Not adapted to perl core" if $ENV{PERL_CORE}; -plan skip_all => "Not installing prove" if -e "t/SKIP-PROVE"; - -plan tests => 1; - -my $tests = File::Spec->catfile( 't', 'prove*.t' ); -my $prove = File::Spec->catfile( File::Spec->curdir, "blib", "script", "prove" ); -$prove = "$^X $prove"; - -GLOBBAGE: { - my @actual = sort qx/$prove --dry $tests/; - chomp @actual; - - my @expected = ( - File::Spec->catfile( "t", "prove-globbing.t" ), - File::Spec->catfile( "t", "prove-switches.t" ), - ); - is_deeply( \@actual, \@expected, "Expands the wildcards" ); -} diff -urN Test.old/Harness/t/prove-switches.t Test/Harness/t/prove-switches.t --- perl-5.10.0/lib/Test.old/Harness/t/prove-switches.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/prove-switches.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,71 +0,0 @@ -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use File::Spec; -use Test::More; -plan skip_all => "Not adapted to perl core" if $ENV{PERL_CORE}; -plan skip_all => "Not installing prove" if -e "t/SKIP-PROVE"; - -plan tests => 8; - -my $blib = File::Spec->catfile( File::Spec->curdir, "blib" ); -my $blib_lib = File::Spec->catfile( $blib, "lib" ); -my $blib_arch = File::Spec->catfile( $blib, "arch" ); -my $prove = File::Spec->catfile( $blib, "script", "prove" ); -$prove = "$^X $prove"; - -CAPITAL_TAINT: { - local $ENV{PROVE_SWITCHES}; - - my @actual = qx/$prove -Ifirst -D -I second -Ithird -Tvdb/; - my @expected = ( "# \$Test::Harness::Switches: -T -I$blib_arch -I$blib_lib -Ifirst -Isecond -Ithird\n" ); - is_deeply( \@actual, \@expected, "Capital taint flags OK" ); -} - -LOWERCASE_TAINT: { - local $ENV{PROVE_SWITCHES}; - - my @actual = qx/$prove -dD -Ifirst -I second -t -Ithird -vb/; - my @expected = ( "# \$Test::Harness::Switches: -t -I$blib_arch -I$blib_lib -Ifirst -Isecond -Ithird\n" ); - is_deeply( \@actual, \@expected, "Lowercase taint OK" ); -} - -PROVE_SWITCHES: { - local $ENV{PROVE_SWITCHES} = "-dvb -I fark"; - - my @actual = qx/$prove -Ibork -Dd/; - my @expected = ( "# \$Test::Harness::Switches: -I$blib_arch -I$blib_lib -Ifark -Ibork\n" ); - is_deeply( \@actual, \@expected, "PROVE_SWITCHES OK" ); -} - -PROVE_SWITCHES_L: { - my @actual = qx/$prove -l -Ibongo -Dd/; - my @expected = ( "# \$Test::Harness::Switches: -Ilib -Ibongo\n" ); - is_deeply( \@actual, \@expected, "PROVE_SWITCHES OK" ); -} - -PROVE_SWITCHES_LB: { - my @actual = qx/$prove -lb -Dd/; - my @expected = ( "# \$Test::Harness::Switches: -Ilib -I$blib_arch -I$blib_lib\n" ); - is_deeply( \@actual, \@expected, "PROVE_SWITCHES OK" ); -} - -PROVE_VERSION: { - # This also checks that the prove $VERSION is in sync with Test::Harness's $VERSION - local $/ = undef; - - use_ok( 'Test::Harness' ); - - my $thv = $Test::Harness::VERSION; - my @actual = qx/$prove --version/; - is( scalar @actual, 1, 'Only 1 line returned' ); - like( $actual[0], qq{/^\Qprove v$thv, using Test::Harness v$thv and Perl v5\E/} ); -} diff -urN Test.old/Harness/t/strap-analyze.t Test/Harness/t/strap-analyze.t --- perl-5.10.0/lib/Test.old/Harness/t/strap-analyze.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/strap-analyze.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,599 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use Test::More tests => 247; -use File::Spec; - -my $Curdir = File::Spec->curdir; -my $SAMPLE_TESTS = $ENV{PERL_CORE} - ? File::Spec->catdir($Curdir, 'lib', 'sample-tests') - : File::Spec->catdir($Curdir, 't', 'sample-tests'); - - -my $IsMacPerl = $^O eq 'MacOS'; -my $IsVMS = $^O eq 'VMS'; - -# VMS uses native, not POSIX, exit codes. -my $die_exit = $IsVMS ? 44 : 1; - -# We can only predict that the wait status should be zero or not. -my $wait_non_zero = 1; - -my %samples = ( - bignum => { - bonus => 0, - details => [ - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - ok => 1 - } - ], - 'exit' => 0, - max => 2, - ok => 4, - passing => 0, - seen => 4, - skip => 0, - todo => 0, - 'wait' => 0 - }, - combined => { - bonus => 1, - details => [ - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - name => "basset hounds got long ears", - ok => 1 - }, - { - actual_ok => 0, - name => "all hell broke lose", - ok => 0 - }, - { - actual_ok => 1, - ok => 1, - type => "todo" - }, - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - ok => 1, - reason => "contract negociations", - type => "skip" - }, - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 0, - ok => 0 - }, - { - actual_ok => 0, - ok => 1, - type => "todo" - } - ], - 'exit' => 0, - max => 10, - ok => 8, - passing => 0, - seen => 10, - skip => 1, - todo => 2, - 'wait' => 0 - }, - descriptive => { - bonus => 0, - details => [ - { - actual_ok => 1, - name => "Interlock activated", - ok => 1 - }, - { - actual_ok => 1, - name => "Megathrusters are go", - ok => 1 - }, - { - actual_ok => 1, - name => "Head formed", - ok => 1 - }, - { - actual_ok => 1, - name => "Blazing sword formed", - ok => 1 - }, - { - actual_ok => 1, - name => "Robeast destroyed", - ok => 1 - } - ], - 'exit' => 0, - max => 5, - ok => 5, - passing => 1, - seen => 5, - skip => 0, - todo => 0, - 'wait' => 0 - }, - 'die' => { - bonus => 0, - details => [], - 'exit' => $die_exit, - max => 0, - ok => 0, - passing => 0, - seen => 0, - skip => 0, - todo => 0, - 'wait' => $wait_non_zero - }, - die_head_end => { - bonus => 0, - details => [ - ({ - actual_ok => 1, - ok => 1 - }) x 4, - ], - 'exit' => $die_exit, - max => 0, - ok => 4, - passing => 0, - seen => 4, - skip => 0, - todo => 0, - 'wait' => $wait_non_zero - }, - die_last_minute => { - bonus => 0, - details => [ - ({ - actual_ok => 1, - ok => 1 - }) x 4, - ], - 'exit' => $die_exit, - max => 4, - ok => 4, - passing => 0, - seen => 4, - skip => 0, - todo => 0, - 'wait' => $wait_non_zero - }, - duplicates => { - bonus => 0, - details => [ - ({ - actual_ok => 1, - ok => 1 - }) x 10, - ], - 'exit' => 0, - max => 10, - ok => 11, - passing => 0, - seen => 11, - skip => 0, - todo => 0, - 'wait' => 0 - }, - head_end => { - bonus => 0, - details => [ - ({ - actual_ok => 1, - ok => 1 - }) x 3, - { - actual_ok => 1, - diagnostics => "comment\nmore ignored stuff\nand yet more\n", - ok => 1 - } - ], - 'exit' => 0, - max => 4, - ok => 4, - passing => 1, - seen => 4, - skip => 0, - todo => 0, - 'wait' => 0 - }, - head_fail => { - bonus => 0, - details => [ - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 0, - ok => 0 - }, - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - diagnostics => "comment\nmore ignored stuff\nand yet more\n", - ok => 1 - } - ], - 'exit' => 0, - max => 4, - ok => 3, - passing => 0, - seen => 4, - skip => 0, - todo => 0, - 'wait' => 0 - }, - lone_not_bug => { - bonus => 0, - details => [ - ({ - actual_ok => 1, - ok => 1 - }) x 4, - ], - 'exit' => 0, - max => 4, - ok => 4, - passing => 1, - seen => 4, - skip => 0, - todo => 0, - 'wait' => 0 - }, - no_output => { - bonus => 0, - details => [], - 'exit' => 0, - max => 0, - ok => 0, - passing => 0, - seen => 0, - skip => 0, - todo => 0, - 'wait' => 0 - }, - shbang_misparse => { - bonus => 0, - details => [ - ({ - actual_ok => 1, - ok => 1 - }) x 2, - ], - 'exit' => 0, - max => 2, - ok => 2, - passing => 1, - seen => 2, - skip => 0, - todo => 0, - 'wait' => 0 - }, - simple => { - bonus => 0, - details => [ - ({ - actual_ok => 1, - ok => 1 - }) x 5, - ], - 'exit' => 0, - max => 5, - ok => 5, - passing => 1, - seen => 5, - skip => 0, - todo => 0, - 'wait' => 0 - }, - simple_fail => { - bonus => 0, - details => [ - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 0, - ok => 0 - }, - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 0, - ok => 0 - } - ], - 'exit' => 0, - max => 5, - ok => 3, - passing => 0, - seen => 5, - skip => 0, - todo => 0, - 'wait' => 0 - }, - skip => { - bonus => 0, - details => [ - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - ok => 1, - reason => "rain delay", - type => "skip" - }, - ({ - actual_ok => 1, - ok => 1 - }) x 3, - ], - 'exit' => 0, - max => 5, - ok => 5, - passing => 1, - seen => 5, - skip => 1, - todo => 0, - 'wait' => 0 - }, - skip_nomsg => { - bonus => 0, - details => [ - { - actual_ok => 1, - ok => 1, - reason => "", - type => "skip" - } - ], - 'exit' => 0, - max => 1, - ok => 1, - passing => 1, - seen => 1, - skip => 1, - todo => 0, - 'wait' => 0 - }, - skipall => { - bonus => 0, - details => [], - 'exit' => 0, - max => 0, - ok => 0, - passing => 1, - seen => 0, - skip => 0, - skip_all => "rope", - todo => 0, - 'wait' => 0 - }, - skipall_nomsg => { - bonus => 0, - details => [], - 'exit' => 0, - max => 0, - ok => 0, - passing => 1, - seen => 0, - skip => 0, - skip_all => "", - todo => 0, - 'wait' => 0 - }, - taint => { - bonus => 0, - details => [ - { - actual_ok => 1, - name => "-T honored", - ok => 1 - } - ], - 'exit' => 0, - max => 1, - ok => 1, - passing => 1, - seen => 1, - skip => 0, - todo => 0, - 'wait' => 0 - }, - todo => { - bonus => 1, - details => [ - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 1, - ok => 1, - type => "todo" - }, - { - actual_ok => 0, - ok => 1, - type => "todo" - }, - ({ - actual_ok => 1, - ok => 1 - }) x 2, - ], - 'exit' => 0, - max => 5, - ok => 5, - passing => 1, - seen => 5, - skip => 0, - todo => 2, - 'wait' => 0 - }, - vms_nit => { - bonus => 0, - details => [ - { - actual_ok => 0, - ok => 0 - }, - { - actual_ok => 1, - ok => 1 - } - ], - 'exit' => 0, - max => 2, - ok => 1, - passing => 0, - seen => 2, - skip => 0, - todo => 0, - 'wait' => 0 - }, - with_comments => { - bonus => 2, - details => [ - { - actual_ok => 0, - diagnostics => "Failed test 1 in t/todo.t at line 9 *TODO*\n", - ok => 1, - type => "todo" - }, - { - actual_ok => 1, - ok => 1, - reason => "at line 10 TODO?!)", - type => "todo" - }, - { - actual_ok => 1, - ok => 1 - }, - { - actual_ok => 0, - diagnostics => "Test 4 got: '0' (t/todo.t at line 12 *TODO*)\n Expected: '1' (need more tuits)\n", - ok => 1, - type => "todo" - }, - { - actual_ok => 1, - diagnostics => "woo\n", - ok => 1, - reason => "at line 13 TODO?!)", - type => "todo" - } - ], - 'exit' => 0, - max => 5, - ok => 5, - passing => 1, - seen => 5, - skip => 0, - todo => 4, - 'wait' => 0 - }, -); - -use Test::Harness::Straps; -my @_INC = map { qq{"-I$_"} } @INC; -$Test::Harness::Switches = "@_INC -Mstrict"; - -$SIG{__WARN__} = sub { - warn @_ unless $_[0] =~ /^Enormous test number/ || - $_[0] =~ /^Can't detailize/ -}; - -for my $test ( sort keys %samples ) { - print "# Working on $test\n"; - my $expect = $samples{$test}; - - for my $n ( 0..$#{$expect->{details}} ) { - for my $field ( qw( type name reason ) ) { - $expect->{details}[$n]{$field} = '' unless exists $expect->{details}[$n]{$field}; - } - } - - my $test_path = File::Spec->catfile($SAMPLE_TESTS, $test); - my $strap = Test::Harness::Straps->new; - isa_ok( $strap, 'Test::Harness::Straps' ); - my $results = $strap->analyze_file($test_path); - - is_deeply($results->details, $expect->{details}, qq{details of "$test"} ); - - delete $expect->{details}; - - SKIP: { - skip '$? unreliable in MacPerl', 2 if $IsMacPerl; - - # We can only check if it's zero or non-zero. - is( !$results->wait, !$expect->{'wait'}, 'wait status' ); - delete $expect->{'wait'}; - - # Have to check the exit status seperately so we can skip it - # in MacPerl. - is( $results->exit, $expect->{'exit'}, 'exit matches' ); - delete $expect->{'exit'}; - } - - for my $field ( sort keys %$expect ) { - is( $results->$field(), $expect->{$field}, "Field $field" ); - } -} # for %samples - -NON_EXISTENT_FILE: { - my $strap = Test::Harness::Straps->new; - isa_ok( $strap, 'Test::Harness::Straps' ); - ok( !$strap->analyze_file('I_dont_exist'), "Can't analyze a non-existant file" ); - is( $strap->{error}, "I_dont_exist does not exist", "And there should be one error" ); -} diff -urN Test.old/Harness/t/strap.t Test/Harness/t/strap.t --- perl-5.10.0/lib/Test.old/Harness/t/strap.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/strap.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,158 +0,0 @@ -#!/usr/bin/perl -Tw - -use strict; - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use Test::More tests => 89; - -BEGIN { use_ok('Test::Harness::Straps'); } - -my $strap = Test::Harness::Straps->new; -isa_ok( $strap, 'Test::Harness::Straps', 'new()' ); - -### Testing _is_diagnostic() - -my $comment; -ok( !$strap->_is_diagnostic("foo", \$comment), '_is_diagnostic(), not a comment' ); -ok( !defined $comment, ' no comment set' ); - -ok( !$strap->_is_diagnostic("f # oo", \$comment), ' not a comment with #' ); -ok( !defined $comment, ' no comment set' ); - -my %comments = ( - "# stuff and things # and stuff" => - ' stuff and things # and stuff', - " # more things " => ' more things ', - "#" => '', - ); - -for my $line ( sort keys %comments ) { - my $line_comment = $comments{$line}; - my $strap = Test::Harness::Straps->new; - isa_ok( $strap, 'Test::Harness::Straps' ); - - my $name = substr($line, 0, 20); - ok( $strap->_is_diagnostic($line, \$comment), " comment '$name'" ); - is( $comment, $line_comment, ' right comment set' ); -} - - - -### Testing _is_header() - -my @not_headers = (' 1..2', - '1..M', - '1..-1', - '2..2', - '1..a', - '', - ); - -foreach my $unheader (@not_headers) { - my $strap = Test::Harness::Straps->new; - isa_ok( $strap, 'Test::Harness::Straps' ); - - ok( !$strap->_is_header($unheader), - "_is_header(), not a header '$unheader'" ); - - ok( (!grep { exists $strap->{$_} } qw(max todo skip_all)), - " max, todo and skip_all are not set" ); -} - - -my @attribs = qw(max skip_all todo); -my %headers = ( - '1..2' => { max => 2 }, - '1..1' => { max => 1 }, - '1..0' => { max => 0, - skip_all => '', - }, - '1..0 # Skipped: no leverage found' => { max => 0, - skip_all => 'no leverage found', - }, - '1..4 # Skipped: no leverage found' => { max => 4, - skip_all => 'no leverage found', - }, - '1..0 # skip skip skip because' => { max => 0, - skip_all => 'skip skip because', - }, - '1..10 todo 2 4 10' => { max => 10, - 'todo' => { 2 => 1, - 4 => 1, - 10 => 1, - }, - }, - '1..10 todo' => { max => 10 }, - '1..192 todo 4 2 13 192 # Skip skip skip because' => - { max => 192, - 'todo' => { 4 => 1, - 2 => 1, - 13 => 1, - 192 => 1, - }, - skip_all => 'skip skip because' - } -); - -for my $header ( sort keys %headers ) { - my $expect = $headers{$header}; - my $strap = Test::Harness::Straps->new; - isa_ok( $strap, 'Test::Harness::Straps' ); - - ok( $strap->_is_header($header), "_is_header() is a header '$header'" ); - - is( $strap->{skip_all}, $expect->{skip_all}, ' skip_all set right' ) - if defined $expect->{skip_all}; - - ok( eq_set( [map $strap->{$_}, grep defined $strap->{$_}, @attribs], - [map $expect->{$_}, grep defined $expect->{$_}, @attribs] ), - ' the right attributes are there' ); -} - - - -### Test _is_bail_out() - -my %bails = ( - 'Bail out!' => undef, - 'Bail out! Wing on fire.' => 'Wing on fire.', - 'BAIL OUT!' => undef, - 'bail out! - Out of coffee' => '- Out of coffee', - ); - -for my $line ( sort keys %bails ) { - my $expect = $bails{$line}; - my $strap = Test::Harness::Straps->new; - isa_ok( $strap, 'Test::Harness::Straps' ); - - my $reason; - ok( $strap->_is_bail_out($line, \$reason), "_is_bail_out() spots '$line'"); - is( $reason, $expect, ' with the right reason' ); -} - -my @unbails = ( - ' Bail out!', - 'BAIL OUT', - 'frobnitz', - 'ok 23 - BAIL OUT!', - ); - -foreach my $line (@unbails) { - my $strap = Test::Harness::Straps->new; - isa_ok( $strap, 'Test::Harness::Straps' ); - - my $reason; - - ok( !$strap->_is_bail_out($line, \$reason), - "_is_bail_out() ignores '$line'" ); - is( $reason, undef, ' and gives no reason' ); -} diff -urN Test.old/Harness/t/test-harness.t Test/Harness/t/test-harness.t --- perl-5.10.0/lib/Test.old/Harness/t/test-harness.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/t/test-harness.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,562 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use File::Spec; - -my $Curdir = File::Spec->curdir; -my $SAMPLE_TESTS = $ENV{PERL_CORE} - ? File::Spec->catdir($Curdir, 'lib', 'sample-tests') - : File::Spec->catdir($Curdir, 't', 'sample-tests'); - - -use Test::More; -use Dev::Null; - -my $IsMacPerl = $^O eq 'MacOS'; -my $IsVMS = $^O eq 'VMS'; - -# VMS uses native, not POSIX, exit codes. -# MacPerl's exit codes are broken. -my $die_estat = $IsVMS ? 44 : - $IsMacPerl ? 0 : - 1; - -my %samples = ( - simple => { - total => { - bonus => 0, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - simple_fail => { - total => { - bonus => 0, - max => 5, - 'ok' => 3, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped => 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - canon => '2 5', - }, - all_ok => 0, - }, - descriptive => { - total => { - bonus => 0, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - no_nums => { - total => { - bonus => 0, - max => 5, - 'ok' => 4, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - canon => '3', - }, - all_ok => 0, - }, - 'todo' => { - total => { - bonus => 1, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 2, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - todo_inline => { - total => { - bonus => 1, - max => 3, - 'ok' => 3, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped => 0, - 'todo' => 2, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - 'skip' => { - total => { - bonus => 0, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 1, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - 'skip_nomsg' => { - total => { - bonus => 0, - max => 1, - 'ok' => 1, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 1, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - bailout => 0, - combined => { - total => { - bonus => 1, - max => 10, - 'ok' => 8, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 1, - 'todo' => 2, - skipped => 0 - }, - failed => { - canon => '3 9', - }, - all_ok => 0, - }, - duplicates => { - total => { - bonus => 0, - max => 10, - 'ok' => 11, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - canon => '??', - }, - all_ok => 0, - }, - head_end => { - total => { - bonus => 0, - max => 4, - 'ok' => 4, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - head_fail => { - total => { - bonus => 0, - max => 4, - 'ok' => 3, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - canon => '2', - }, - all_ok => 0, - }, - no_output => { - total => { - bonus => 0, - max => 0, - 'ok' => 0, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped => 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - }, - all_ok => 0, - }, - skipall => { - total => { - bonus => 0, - max => 0, - 'ok' => 0, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 1, - }, - failed => { }, - all_ok => 1, - }, - skipall_nomsg => { - total => { - bonus => 0, - max => 0, - 'ok' => 0, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 1, - }, - failed => { }, - all_ok => 1, - }, - with_comments => { - total => { - bonus => 2, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 4, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - taint => { - total => { - bonus => 0, - max => 1, - 'ok' => 1, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - - taint_warn => { - total => { - bonus => 0, - max => 1, - 'ok' => 1, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - - 'die' => { - total => { - bonus => 0, - max => 0, - 'ok' => 0, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - estat => $die_estat, - max => '??', - failed => '??', - canon => '??', - }, - all_ok => 0, - }, - - die_head_end => { - total => { - bonus => 0, - max => 0, - 'ok' => 4, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - estat => $die_estat, - max => '??', - failed => '??', - canon => '??', - }, - all_ok => 0, - }, - - die_last_minute => { - total => { - bonus => 0, - max => 4, - 'ok' => 4, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - estat => $die_estat, - max => 4, - failed => 0, - canon => '??', - }, - all_ok => 0, - }, - bignum => { - total => { - bonus => 0, - max => 2, - 'ok' => 4, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - canon => '??', - }, - all_ok => 0, - }, - bignum_many => { - total => { - bonus => 0, - max => 2, - 'ok' => 11, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - canon => '3-100000', - }, - all_ok => 0, - }, - 'shbang_misparse' => { - total => { - bonus => 0, - max => 2, - 'ok' => 2, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - too_many => { - total => { - bonus => 0, - max => 3, - 'ok' => 7, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped => 0, - 'todo' => 0, - skipped => 0, - }, - failed => { - canon => '4-7', - }, - all_ok => 0, - }, - switches => { - total => { - bonus => 0, - max => 1, - 'ok' => 1, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - 'todo' => 0, - skipped => 0, - }, - failed => { }, - all_ok => 1, - }, - ); - -my $tests_per_loop = 8; -plan tests => (keys(%samples) * $tests_per_loop); - -use Test::Harness; -my @_INC = map { qq{"-I$_"} } @INC; -$Test::Harness::Switches = "@_INC -Mstrict"; - -tie *NULL, 'Dev::Null' or die $!; - -for my $test ( sort keys %samples ) { -SKIP: { - skip "-t introduced in 5.8.0", $tests_per_loop - if ($test eq 'taint_warn') && ($] < 5.008); - - my $expect = $samples{$test}; - - # execute_tests() runs the tests but skips the formatting. - my $test_path = File::Spec->catfile($SAMPLE_TESTS, $test); - - print STDERR "# $test\n" if $ENV{TEST_VERBOSE}; - my $totals; - my $failed; - my $warning = ''; - eval { - local $SIG{__WARN__} = sub { $warning .= join '', @_; }; - ($totals, $failed) = Test::Harness::execute_tests(tests => [$test_path], out => \*NULL); - }; - - # $? is unreliable in MacPerl, so we'll just fudge it. - $failed->{estat} = $die_estat if $IsMacPerl and $failed; - - SKIP: { - skip "special tests for bailout", 1 unless $test eq 'bailout'; - like( $@, '/Further testing stopped: GERONI/i' ); - } - - SKIP: { - skip "don't apply to a bailout", 6 if $test eq 'bailout'; - is( $@, '', '$@ is empty' ); - is( Test::Harness::_all_ok($totals), $expect->{all_ok}, - "$test - all ok" ); - ok( defined $expect->{total}, "$test - has total" ); - is_deeply( {map { $_=>$totals->{$_} } keys %{$expect->{total}}}, - $expect->{total}, - "$test - totals" ); - is_deeply( {map { $_=>$failed->{$test_path}{$_} } - keys %{$expect->{failed}}}, - $expect->{failed}, - "$test - failed" ); - - skip "No tests were run", 1 unless $totals->{max}; - - my $output = Test::Harness::get_results($totals, $failed); - like( $output, '/All tests successful|List of Failed/', 'Got what looks like a valid summary' ); - } - - my $expected_warnings = ""; - if ( $test eq "bignum" ) { - $expected_warnings = < 3; - -BEGIN { - use_ok('Test::Harness'); -} - -my $ver = $ENV{HARNESS_VERSION} or die "HARNESS_VERSION not set"; -ok( $ver =~ /^2.\d\d(_\d\d)?$/, "Version is proper format" ); -is( $ver, $Test::Harness::VERSION ); diff -urN Test.old/Harness/TAP.pod Test/Harness/TAP.pod --- perl-5.10.0/lib/Test.old/Harness/TAP.pod 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/TAP.pod 1970-01-01 01:00:00.000000000 +0100 @@ -1,492 +0,0 @@ -=head1 NAME - -Test::Harness::TAP - Documentation for the TAP format - -=head1 SYNOPSIS - -TAP, the Test Anything Protocol, is Perl's simple text-based interface -between testing modules such as Test::More and the test harness -Test::Harness. - -=head1 TODO - -Exit code of the process. - -=head1 THE TAP FORMAT - -TAP's general format is: - - 1..N - ok 1 Description # Directive - # Diagnostic - .... - ok 47 Description - ok 48 Description - more tests.... - -For example, a test file's output might look like: - - 1..4 - ok 1 - Input file opened - not ok 2 - First line of the input valid - ok 3 - Read the rest of the file - not ok 4 - Summarized correctly # TODO Not written yet - -=head1 HARNESS BEHAVIOR - -In this document, the "harness" is any program analyzing TAP output. -Typically this will be Perl's I program, or the underlying -C subroutine. - -A harness must only read TAP output from standard output and not -from standard error. Lines written to standard output matching -C must be interpreted as test lines. All other -lines must not be considered test output. - -=head1 TESTS LINES AND THE PLAN - -=head2 The plan - -The plan tells how many tests will be run, or how many tests have -run. It's a check that the test file hasn't stopped prematurely. -It must appear once, whether at the beginning or end of the output. - -The plan is usually the first line of TAP output and it specifies how -many test points are to follow. For example, - - 1..10 - -means you plan on running 10 tests. This is a safeguard in case your test -file dies silently in the middle of its run. The plan is optional but if -there is a plan before the test points it must be the first non-diagnostic -line output by the test file. - -In certain instances a test file may not know how many test points -it will ultimately be running. In this case the plan can be the last -non-diagnostic line in the output. - -The plan cannot appear in the middle of the output, nor can it appear more -than once. - -=head2 The test line - -The core of TAP is the test line. A test file prints one test line test -point executed. There must be at least one test line in TAP output. Each -test line comprises the following elements: - -=over 4 - -=item * C or C - -This tells whether the test point passed or failed. It must be -at the beginning of the line. C indicates a failed test -point. C is a successful test point. This is the only mandatory -part of the line. - -Note that unlike the Directives below, C and C are -case-sensitive. - -=item * Test number - -TAP expects the C or C to be followed by a test point -number. If there is no number the harness must maintain -its own counter until the script supplies test numbers again. So -the following test output - - 1..6 - not ok - ok - not ok - ok - ok - -has five tests. The sixth is missing. Test::Harness will generate - - FAILED tests 1, 3, 6 - Failed 3/6 tests, 50.00% okay - -=item * Description - -Any text after the test number but before a C<#> is the description of -the test point. - - ok 42 this is the description of the test - -Descriptions should not begin with a digit so that they are not confused -with the test point number. - -The harness may do whatever it wants with the description. - -=item * Directive - -The test point may include a directive, following a hash on the -test line. There are currently two directives allowed: C and -C. These are discussed below. - -=back - -To summarize: - -=over 4 - -=item * ok/not ok (required) - -=item * Test number (recommended) - -=item * Description (recommended) - -=item * Directive (only when necessary) - -=back - -=head1 DIRECTIVES - -Directives are special notes that follow a C<#> on the test line. -Only two are currently defined: C and C. Note that -these two keywords are not case-sensitive. - -=head2 TODO tests - -If the directive starts with C<# TODO>, the test is counted as a -todo test, and the text after C is the explanation. - - not ok 13 # TODO bend space and time - -Note that if the TODO has an explanation it must be separated from -C by a space. - -These tests represent a feature to be implemented or a bug to be fixed -and act as something of an executable "things to do" list. They are -B expected to succeed. Should a todo test point begin succeeding, -the harness should report it as a bonus. This indicates that whatever -you were supposed to do has been done and you should promote this to a -normal test point. - -=head2 Skipping tests - -If the directive starts with C<# SKIP>, the test is counted as having -been skipped. If the whole test file succeeds, the count of skipped -tests is included in the generated output. The harness should report -the text after C< # SKIP\S*\s+> as a reason for skipping. - - ok 23 # skip Insufficient flogiston pressure. - -Similarly, one can include an explanation in a plan line, -emitted if the test file is skipped completely: - - 1..0 # Skipped: WWW::Mechanize not installed - -=head1 OTHER LINES - -=head2 Bail out! - -As an emergency measure a test script can decide that further tests -are useless (e.g. missing dependencies) and testing should stop -immediately. In that case the test script prints the magic words - - Bail out! - -to standard output. Any message after these words must be displayed -by the interpreter as the reason why testing must be stopped, as -in - - Bail out! MySQL is not running. - -=head2 Diagnostics - -Additional information may be put into the testing output on separate -lines. Diagnostic lines should begin with a C<#>, which the harness must -ignore, at least as far as analyzing the test results. The harness is -free, however, to display the diagnostics. Typically diagnostics are -used to provide information about the environment in which test file is -running, or to delineate a group of tests. - - ... - ok 18 - Closed database connection - # End of database section. - # This starts the network part of the test. - # Daemon started on port 2112 - ok 19 - Opened socket - ... - ok 47 - Closed socket - # End of network tests - -=head2 Anything else - -Any output line that is not a plan, a test line or a diagnostic is -incorrect. How a harness handles the incorrect line is undefined. -Test::Harness silently ignores incorrect lines, but will become more -stringent in the future. - -=head1 EXAMPLES - -All names, places, and events depicted in any example are wholly -fictitious and bear no resemblance to, connection with, or relation to any -real entity. Any such similarity is purely coincidental, unintentional, -and unintended. - -=head2 Common with explanation - -The following TAP listing declares that six tests follow as well as -provides handy feedback as to what the test is about to do. All six -tests pass. - - 1..6 - # - # Create a new Board and Tile, then place - # the Tile onto the board. - # - ok 1 - The object isa Board - ok 2 - Board size is zero - ok 3 - The object isa Tile - ok 4 - Get possible places to put the Tile - ok 5 - Placing the tile produces no error - ok 6 - Board size is 1 - -=head2 Unknown amount and failures - -This hypothetical test program ensures that a handful of servers are -online and network-accessible. Because it retrieves the hypothetical -servers from a database, it doesn't know exactly how many servers it -will need to ping. Thus, the test count is declared at the bottom after -all the test points have run. Also, two of the tests fail. - - ok 1 - retrieving servers from the database - # need to ping 6 servers - ok 2 - pinged diamond - ok 3 - pinged ruby - not ok 4 - pinged saphire - ok 5 - pinged onyx - not ok 6 - pinged quartz - ok 7 - pinged gold - 1..7 - -=head2 Giving up - -This listing reports that a pile of tests are going to be run. However, -the first test fails, reportedly because a connection to the database -could not be established. The program decided that continuing was -pointless and exited. - - 1..573 - not ok 1 - database handle - Bail out! Couldn't connect to database. - -=head2 Skipping a few - -The following listing plans on running 5 tests. However, our program -decided to not run tests 2 thru 5 at all. To properly report this, -the tests are marked as being skipped. - - 1..5 - ok 1 - approved operating system - # $^0 is solaris - ok 2 - # SKIP no /sys directory - ok 3 - # SKIP no /sys directory - ok 4 - # SKIP no /sys directory - ok 5 - # SKIP no /sys directory - -=head2 Skipping everything - -This listing shows that the entire listing is a skip. No tests were run. - - 1..0 # skip because English-to-French translator isn't installed - -=head2 Got spare tuits? - -The following example reports that four tests are run and the last two -tests failed. However, because the failing tests are marked as things -to do later, they are considered successes. Thus, a harness should report -this entire listing as a success. - - 1..4 - ok 1 - Creating test program - ok 2 - Test program runs, no error - not ok 3 - infinite loop # TODO halting problem unsolved - not ok 4 - infinite loop 2 # TODO halting problem unsolved - -=head2 Creative liberties - -This listing shows an alternate output where the test numbers aren't -provided. The test also reports the state of a ficticious board game in -diagnostic form. Finally, the test count is reported at the end. - - ok - created Board - ok - ok - ok - ok - ok - ok - ok - # +------+------+------+------+ - # | |16G | |05C | - # | |G N C | |C C G | - # | | G | | C +| - # +------+------+------+------+ - # |10C |01G | |03C | - # |R N G |G A G | |C C C | - # | R | G | | C +| - # +------+------+------+------+ - # | |01G |17C |00C | - # | |G A G |G N R |R N R | - # | | G | R | G | - # +------+------+------+------+ - ok - board has 7 tiles + starter tile - 1..9 - -=head1 Non-Perl TAP - -In Perl, we use Test::Simple and Test::More to generate TAP output. -Other languages have solutions that generate TAP, so that they can take -advantage of Test::Harness. - -The following sections are provided by their maintainers, and may not -be up-to-date. - -=head2 C/C++ - -libtap makes it easy to write test programs in C that produce -TAP-compatible output. Modeled on the Test::More API, libtap contains -all the functions you need to: - -=over 4 - -=item * Specify a test plan - -=item * Run tests - -=item * Skip tests in certain situations - -=item * Have TODO tests - -=item * Produce TAP compatible diagnostics - -=back - -More information about libtap, including download links, checksums, -anonymous access to the Subersion repository, and a bug tracking -system, can be found at: - - http://jc.ngo.org.uk/trac-bin/trac.cgi/wiki/LibTap - -(Nik Clayton, April 17, 2006) - -=head2 Python - -PyTap will, when it's done, provide a simple, assertive (Test::More-like) -interface for writing tests in Python. It will output TAP and will -include the functionality found in Test::Builder and Test::More. It will -try to make it easy to add more test code (so you can write your own -C, for example. - -Right now, it's got a fair bit of the basics needed to emulate Test::More, -and I think it's easy to add more stuff -- just like Test::Builder, -there's a singleton that you can get at easily. - -I need to better identify and finish implementing the most basic tests. -I am not a Python guru, I just use it from time to time, so my aim may -not be true. I need to write tests for it, which means either relying -on Perl for the tester tester, or writing one in Python. - -Here's a sample test, as found in my Subversion: - - from TAP.Simple import * - - plan(15) - - ok(1) - ok(1, "everything is OK!") - ok(0, "always fails") - - is_ok(10, 10, "is ten ten?") - is_ok(ok, ok, "even ok is ok!") - ok(id(ok), "ok is not the null pointer") - ok(True, "the Truth will set you ok") - ok(not False, "and nothing but the truth") - ok(False, "and we'll know if you lie to us") - - isa_ok(10, int, "10") - isa_ok('ok', str, "some string") - - ok(0, "zero is true", todo="be more like Ruby!") - ok(None, "none is true", skip="not possible in this universe") - - eq_ok("not", "equal", "two strings are not equal"); - -(Ricardo Signes, April 17, 2006) - -=head2 JavaScript - -Test.Simple looks and acts just like TAP, although in reality it's -tracking test results in an object rather than scraping them from a -print buffer. - - http://openjsan.org/doc/t/th/theory/Test/Simple/ - -(David Wheeler, April 17, 2006) - -=head2 PHP - -All the big PHP players now produce TAP - -=over - -=item * phpt - -Outputs TAP by default as of the yet-to-be-released PEAR 1.5.0 - - http://pear.php.net/PEAR - -=item * PHPUnit - -Has a TAP logger (since 2.3.4) - - http://www.phpunit.de/wiki/Main_Page - -=item * SimpleTest - -There's a third-party TAP reporting extension for SimpleTest - - http://www.digitalsandwich.com/archives/51-Updated-Simpletest+Apache-Test.html - -=item * Apache-Test - -Apache-Test's PHP writes TAP by default and includes the standalone -test-more.php - - http://search.cpan.org/dist/Apache-Test/ - -=back - -(Geoffrey Young, April 17, 2006) - -=head1 AUTHORS - -Andy Lester, based on the original Test::Harness documentation by Michael Schwern. - -=head1 ACKNOWLEDGEMENTS - -Thanks to -Pete Krawczyk, -Paul Johnson, -Ian Langworth -and Nik Clayton -for help and contributions on this document. - -The basis for the TAP format was created by Larry Wall in the -original test script for Perl 1. Tim Bunce and Andreas Koenig -developed it further with their modifications to Test::Harness. - -=head1 COPYRIGHT - -Copyright 2003-2005 by -Michael G Schwern C<< >>, -Andy Lester C<< >>. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L. - -=cut diff -urN Test.old/Harness/Util.pm Test/Harness/Util.pm --- perl-5.10.0/lib/Test.old/Harness/Util.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness/Util.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,133 +0,0 @@ -package Test::Harness::Util; - -use strict; -use vars qw($VERSION); -$VERSION = '0.01'; - -use File::Spec; -use Exporter; -use vars qw( @ISA @EXPORT @EXPORT_OK ); - -@ISA = qw( Exporter ); -@EXPORT = (); -@EXPORT_OK = qw( all_in shuffle blibdirs ); - -=head1 NAME - -Test::Harness::Util - Utility functions for Test::Harness::* - -=head1 SYNOPSIS - -Utility functions for Test::Harness::* - -=head1 PUBLIC FUNCTIONS - -The following are all available to be imported to your module. No symbols -are exported by default. - -=head2 all_in( {parm => value, parm => value} ) - -Finds all the F<*.t> in a directory. Knows to skip F<.svn> and F -directories. - -Valid parms are: - -=over - -=item start - -Starting point for the search. Defaults to ".". - -=item recurse - -Flag to say whether it should recurse. Default to true. - -=back - -=cut - -sub all_in { - my $parms = shift; - my %parms = ( - start => ".", - recurse => 1, - %$parms, - ); - - my @hits = (); - my $start = $parms{start}; - - local *DH; - if ( opendir( DH, $start ) ) { - my @files = sort readdir DH; - closedir DH; - for my $file ( @files ) { - next if $file eq File::Spec->updir || $file eq File::Spec->curdir; - next if $file eq ".svn"; - next if $file eq "CVS"; - - my $currfile = File::Spec->catfile( $start, $file ); - if ( -d $currfile ) { - push( @hits, all_in( { %parms, start => $currfile } ) ) if $parms{recurse}; - } - else { - push( @hits, $currfile ) if $currfile =~ /\.t$/; - } - } - } - else { - warn "$start: $!\n"; - } - - return @hits; -} - -=head1 shuffle( @list ) - -Returns a shuffled copy of I<@list>. - -=cut - -sub shuffle { - # Fisher-Yates shuffle - my $i = @_; - while ($i) { - my $j = rand $i--; - @_[$i, $j] = @_[$j, $i]; - } -} - - -=head2 blibdir() - -Finds all the blib directories. Stolen directly from blib.pm - -=cut - -sub blibdirs { - my $dir = File::Spec->curdir; - if ($^O eq 'VMS') { - ($dir = VMS::Filespec::unixify($dir)) =~ s-/\z--; - } - my $archdir = "arch"; - if ( $^O eq "MacOS" ) { - # Double up the MP::A so that it's not used only once. - $archdir = $MacPerl::Architecture = $MacPerl::Architecture; - } - - my $i = 5; - while ($i--) { - my $blib = File::Spec->catdir( $dir, "blib" ); - my $blib_lib = File::Spec->catdir( $blib, "lib" ); - my $blib_arch = File::Spec->catdir( $blib, $archdir ); - - if ( -d $blib && -d $blib_arch && -d $blib_lib ) { - return ($blib_arch,$blib_lib); - } - $dir = File::Spec->catdir($dir, File::Spec->updir); - } - warn "$0: Cannot find blib\n"; - return; -} - -1; diff -urN Test.old/Harness.pm Test/Harness.pm --- perl-5.10.0/lib/Test.old/Harness.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Harness.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,1169 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- - -package Test::Harness; - -require 5.00405; -use Test::Harness::Straps; -use Test::Harness::Assert; -use Exporter; -use Benchmark; -use Config; -use strict; - - -use vars qw( - $VERSION - @ISA @EXPORT @EXPORT_OK - $Verbose $Switches $Debug - $verbose $switches $debug - $Columns - $Timer - $ML $Last_ML_Print - $Strap - $has_time_hires -); - -BEGIN { - eval q{use Time::HiRes 'time'}; - $has_time_hires = !$@; -} - -=head1 NAME - -Test::Harness - Run Perl standard test scripts with statistics - -=head1 VERSION - -Version 2.64 - -=cut - -$VERSION = '2.64'; - -# 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}; -} - -my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR}; - -# Stolen from Params::Util -sub _CLASS { - (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s) ? $_[0] : undef; -} - -# Strap Overloading -if ( $ENV{HARNESS_STRAPS_CLASS} ) { - die 'Set HARNESS_STRAP_CLASS, singular, not HARNESS_STRAPS_CLASS'; -} -my $HARNESS_STRAP_CLASS = $ENV{HARNESS_STRAP_CLASS} || 'Test::Harness::Straps'; -if ( $HARNESS_STRAP_CLASS =~ /\.pm$/ ) { - # "Class" is actually a filename, that should return the - # class name as its true return value. - $HARNESS_STRAP_CLASS = require $HARNESS_STRAP_CLASS; - if ( !_CLASS($HARNESS_STRAP_CLASS) ) { - die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name"; - } -} -else { - # It is a class name within the current @INC - if ( !_CLASS($HARNESS_STRAP_CLASS) ) { - die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name"; - } - eval "require $HARNESS_STRAP_CLASS"; - die $@ if $@; -} -if ( !$HARNESS_STRAP_CLASS->isa('Test::Harness::Straps') ) { - die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' must be a Test::Harness::Straps subclass"; -} - -$Strap = $HARNESS_STRAP_CLASS->new; - -sub strap { return $Strap }; - -@ISA = ('Exporter'); -@EXPORT = qw(&runtests); -@EXPORT_OK = qw(&execute_tests $verbose $switches); - -$Verbose = $ENV{HARNESS_VERBOSE} || 0; -$Debug = $ENV{HARNESS_DEBUG} || 0; -$Switches = '-w'; -$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; -$Columns--; # Some shells have trouble with a full line of text. -$Timer = $ENV{HARNESS_TIMER} || 0; - -=head1 SYNOPSIS - - use Test::Harness; - - runtests(@test_files); - -=head1 DESCRIPTION - -B If all you want to do is write a test script, consider -using Test::Simple. Test::Harness is the module that reads the -output from Test::Simple, Test::More and other modules based on -Test::Builder. You don't need to know about Test::Harness to use -those modules. - -Test::Harness runs tests and expects output from the test in a -certain format. That format is called TAP, the Test Anything -Protocol. It is defined in L. - -C runs all the testscripts named -as arguments and checks standard output for the expected strings -in TAP format. - -The F utility is a thin wrapper around Test::Harness. - -=head2 Taint mode - -Test::Harness will honor the C<-T> or C<-t> in the #! line on your -test files. So if you begin a test with: - - #!perl -T - -the test will be run with taint mode on. - -=head2 Configuration variables. - -These variables can be used to configure the behavior of -Test::Harness. They are exported on request. - -=over 4 - -=item C<$Test::Harness::Verbose> - -The package variable C<$Test::Harness::Verbose> is exportable and can be -used to let C display the standard output of the script -without altering the behavior otherwise. The F utility's C<-v> -flag will set this. - -=item C<$Test::Harness::switches> - -The package variable C<$Test::Harness::switches> is exportable and can be -used to set perl command line options used for running the test -script(s). The default value is C<-w>. It overrides C. - -=item C<$Test::Harness::Timer> - -If set to true, and C is available, print elapsed seconds -after each test file. - -=back - - -=head2 Failure - -When tests fail, analyze the summary report: - - t/base..............ok - t/nonumbers.........ok - t/ok................ok - t/test-harness......ok - t/waterloo..........dubious - Test returned status 3 (wstat 768, 0x300) - DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19 - Failed 10/20 tests, 50.00% okay - Failed Test Stat Wstat Total Fail List of Failed - --------------------------------------------------------------- - t/waterloo.t 3 768 20 10 1 3 5 7 9 11 13 15 17 19 - Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay. - -Everything passed but F. It failed 10 of 20 tests and -exited with non-zero status indicating something dubious happened. - -The columns in the summary report mean: - -=over 4 - -=item B - -The test file which failed. - -=item B - -If the test exited with non-zero, this is its exit status. - -=item B - -The wait status of the test. - -=item B - -Total number of tests expected to run. - -=item B - -Number which failed, either from "not ok" or because they never ran. - -=item B - -A list of the tests which failed. Successive failures may be -abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and -20 failed). - -=back - - -=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 with -one of the messages in the DIAGNOSTICS section. - -=cut - -sub runtests { - my(@tests) = @_; - - local ($\, $,); - - my ($tot, $failedtests,$todo_passed) = execute_tests(tests => \@tests); - print get_results($tot, $failedtests,$todo_passed); - - my $ok = _all_ok($tot); - - assert(($ok xor keys %$failedtests), - q{ok status jives with $failedtests}); - - if (! $ok) { - die("Failed $tot->{bad}/$tot->{tests} test programs. " . - "@{[$tot->{max} - $tot->{ok}]}/$tot->{max} subtests failed.\n"); - } - - return $ok; -} - -# my $ok = _all_ok(\%tot); -# Tells you if this test run is overall successful or not. - -sub _all_ok { - my($tot) = shift; - - return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0; -} - -# Returns all the files in a directory. This is shorthand for backwards -# compatibility on systems where C doesn't work right. - -sub _globdir { - local *DIRH; - - opendir DIRH, shift; - my @f = readdir DIRH; - closedir DIRH; - - return @f; -} - -=head2 execute_tests( tests => \@test_files, out => \*FH ) - -Runs all the given C<@test_files> (just like C) but -doesn't generate the final report. During testing, progress -information will be written to the currently selected output -filehandle (usually C), or to the filehandle given by the -C parameter. The I 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 - -sub execute_tests { - my %args = @_; - my @tests = @{$args{tests}}; - my $out = $args{out} || select(); - - # We allow filehandles that are symbolic refs - no strict 'refs'; - _autoflush($out); - _autoflush(\*STDERR); - - my %failedtests; - my %todo_passed; - - # Test-wide totals. - my(%tot) = ( - bonus => 0, - max => 0, - ok => 0, - files => 0, - bad => 0, - good => 0, - tests => scalar @tests, - sub_skipped => 0, - todo => 0, - skipped => 0, - bench => 0, - ); - - my @dir_files; - @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir; - my $run_start_time = new Benchmark; - - my $width = _leader_width(@tests); - foreach my $tfile (@tests) { - $Last_ML_Print = 0; # so each test prints at least once - my($leader, $ml) = _mk_leader($tfile, $width); - local $ML = $ml; - - print $out $leader; - - $tot{files}++; - - $Strap->{_seen_header} = 0; - if ( $Test::Harness::Debug ) { - print $out "# Running: ", $Strap->_command_line($tfile), "\n"; - } - my $test_start_time = $Timer ? time : 0; - my $results = $Strap->analyze_file($tfile) or - do { warn $Strap->{error}, "\n"; next }; - my $elapsed; - if ( $Timer ) { - $elapsed = time - $test_start_time; - if ( $has_time_hires ) { - $elapsed = sprintf( " %8d ms", $elapsed*1000 ); - } - else { - $elapsed = sprintf( " %8s s", $elapsed ? $elapsed : "<1" ); - } - } - else { - $elapsed = ""; - } - - # state of the current test. - my @failed = grep { !$results->details->[$_-1]{ok} } - 1..@{$results->details}; - my @todo_pass = grep { $results->details->[$_-1]{actual_ok} && - $results->details->[$_-1]{type} eq 'todo' } - 1..@{$results->details}; - - my %test = ( - ok => $results->ok, - 'next' => $Strap->{'next'}, - max => $results->max, - failed => \@failed, - todo_pass => \@todo_pass, - todo => $results->todo, - bonus => $results->bonus, - skipped => $results->skip, - skip_reason => $results->skip_reason, - skip_all => $Strap->{skip_all}, - ml => $ml, - ); - - $tot{bonus} += $results->bonus; - $tot{max} += $results->max; - $tot{ok} += $results->ok; - $tot{todo} += $results->todo; - $tot{sub_skipped} += $results->skip; - - my $estatus = $results->exit; - my $wstatus = $results->wait; - - if ( $results->passing ) { - # XXX Combine these first two - if ($test{max} and $test{skipped} + $test{bonus}) { - my @msg; - push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}") - if $test{skipped}; - if ($test{bonus}) { - my ($txt, $canon) = _canondetail($test{todo},0,'TODO passed', - @{$test{todo_pass}}); - $todo_passed{$tfile} = { - canon => $canon, - max => $test{todo}, - failed => $test{bonus}, - name => $tfile, - estat => '', - wstat => '', - }; - - push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded\n$txt"); - } - print $out "$test{ml}ok$elapsed\n ".join(', ', @msg)."\n"; - } - elsif ( $test{max} ) { - print $out "$test{ml}ok$elapsed\n"; - } - elsif ( defined $test{skip_all} and length $test{skip_all} ) { - print $out "skipped\n all skipped: $test{skip_all}\n"; - $tot{skipped}++; - } - else { - print $out "skipped\n all skipped: no reason given\n"; - $tot{skipped}++; - } - $tot{good}++; - } - else { - # List unrun tests as failures. - if ($test{'next'} <= $test{max}) { - push @{$test{failed}}, $test{'next'}..$test{max}; - } - # List overruns as failures. - else { - my $details = $results->details; - foreach my $overrun ($test{max}+1..@$details) { - next unless ref $details->[$overrun-1]; - push @{$test{failed}}, $overrun - } - } - - if ($wstatus) { - $failedtests{$tfile} = _dubious_return(\%test, \%tot, - $estatus, $wstatus); - $failedtests{$tfile}{name} = $tfile; - } - elsif ( $results->seen ) { - if (@{$test{failed}} and $test{max}) { - my ($txt, $canon) = _canondetail($test{max},$test{skipped},'Failed', - @{$test{failed}}); - print $out "$test{ml}$txt"; - $failedtests{$tfile} = { canon => $canon, - max => $test{max}, - failed => scalar @{$test{failed}}, - name => $tfile, - estat => '', - wstat => '', - }; - } - else { - print $out "Don't know which tests failed: got $test{ok} ok, ". - "expected $test{max}\n"; - $failedtests{$tfile} = { canon => '??', - max => $test{max}, - failed => '??', - name => $tfile, - estat => '', - wstat => '', - }; - } - $tot{bad}++; - } - else { - print $out "FAILED before any test output arrived\n"; - $tot{bad}++; - $failedtests{$tfile} = { canon => '??', - max => '??', - failed => '??', - name => $tfile, - estat => '', - wstat => '', - }; - } - } - - if (defined $Files_In_Dir) { - my @new_dir_files = _globdir $Files_In_Dir; - if (@new_dir_files != @dir_files) { - my %f; - @f{@new_dir_files} = (1) x @new_dir_files; - delete @f{@dir_files}; - my @f = sort keys %f; - print $out "LEAKED FILES: @f\n"; - @dir_files = @new_dir_files; - } - } - } # foreach test - $tot{bench} = timediff(new Benchmark, $run_start_time); - - $Strap->_restore_PERL5LIB; - - return(\%tot, \%failedtests, \%todo_passed); -} - -# Turns on autoflush for the handle passed -sub _autoflush { - my $flushy_fh = shift; - my $old_fh = select $flushy_fh; - $| = 1; - select $old_fh; -} - -=for private _mk_leader - - my($leader, $ml) = _mk_leader($test_file, $width); - -Generates the 't/foo........' leader for the given C<$test_file> as well -as a similar version which will overwrite the current line (by use of -\r and such). C<$ml> may be empty if Test::Harness doesn't think you're -on TTY. - -The C<$width> is the width of the "yada/blah.." string. - -=cut - -sub _mk_leader { - my($te, $width) = @_; - chomp($te); - $te =~ s/\.\w+$/./; - - if ($^O eq 'VMS') { - $te =~ s/^.*\.t\./\[.t./s; - } - my $leader = "$te" . '.' x ($width - length($te)); - my $ml = ""; - - if ( -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose ) { - $ml = "\r" . (' ' x 77) . "\r$leader" - } - - return($leader, $ml); -} - -=for private _leader_width - - my($width) = _leader_width(@test_files); - -Calculates how wide the leader should be based on the length of the -longest test name. - -=cut - -sub _leader_width { - my $maxlen = 0; - my $maxsuflen = 0; - foreach (@_) { - my $suf = /\.(\w+)$/ ? $1 : ''; - my $len = length; - my $suflen = length $suf; - $maxlen = $len if $len > $maxlen; - $maxsuflen = $suflen if $suflen > $maxsuflen; - } - # + 3 : we want three dots between the test name and the "ok" - return $maxlen + 3 - $maxsuflen; -} - -sub get_results { - my $tot = shift; - my $failedtests = shift; - my $todo_passed = shift; - - my $out = ''; - - my $bonusmsg = _bonusmsg($tot); - - if (_all_ok($tot)) { - $out .= "All tests successful$bonusmsg.\n"; - if ($tot->{bonus}) { - my($fmt_top, $fmt) = _create_fmts("Passed TODO",$todo_passed); - # Now write to formats - $out .= swrite( $fmt_top ); - for my $script (sort keys %{$todo_passed||{}}) { - my $Curtest = $todo_passed->{$script}; - $out .= swrite( $fmt, @{ $Curtest }{qw(name estat wstat max failed canon)} ); - } - } - } - elsif (!$tot->{tests}){ - die "FAILED--no tests were run for some reason.\n"; - } - elsif (!$tot->{max}) { - my $blurb = $tot->{tests}==1 ? "script" : "scripts"; - die "FAILED--$tot->{tests} test $blurb could be run, ". - "alas--no output ever seen\n"; - } - else { - my $subresults = sprintf( " %d/%d subtests failed.", - $tot->{max} - $tot->{ok}, $tot->{max} ); - - my($fmt_top, $fmt1, $fmt2) = _create_fmts("Failed Test",$failedtests); - - # Now write to formats - $out .= swrite( $fmt_top ); - for my $script (sort keys %$failedtests) { - my $Curtest = $failedtests->{$script}; - $out .= swrite( $fmt1, @{ $Curtest }{qw(name estat wstat max failed canon)} ); - $out .= swrite( $fmt2, $Curtest->{canon} ); - } - if ($tot->{bad}) { - $bonusmsg =~ s/^,\s*//; - $out .= "$bonusmsg.\n" if $bonusmsg; - $out .= "Failed $tot->{bad}/$tot->{tests} test scripts.$subresults\n"; - } - } - - $out .= sprintf("Files=%d, Tests=%d, %s\n", - $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop')); - return $out; -} - -sub swrite { - my $format = shift; - $^A = ''; - formline($format,@_); - my $out = $^A; - $^A = ''; - return $out; -} - - -my %Handlers = ( - header => \&header_handler, - test => \&test_handler, - bailout => \&bailout_handler, -); - -$Strap->set_callback(\&strap_callback); -sub strap_callback { - my($self, $line, $type, $totals) = @_; - print $line if $Verbose; - - my $meth = $Handlers{$type}; - $meth->($self, $line, $type, $totals) if $meth; -}; - - -sub header_handler { - my($self, $line, $type, $totals) = @_; - - warn "Test header seen more than once!\n" if $self->{_seen_header}; - - $self->{_seen_header}++; - - warn "1..M can only appear at the beginning or end of tests\n" - if $totals->seen && ($totals->max < $totals->seen); -}; - -sub test_handler { - my($self, $line, $type, $totals) = @_; - - my $curr = $totals->seen; - my $next = $self->{'next'}; - my $max = $totals->max; - my $detail = $totals->details->[-1]; - - if( $detail->{ok} ) { - _print_ml_less("ok $curr/$max"); - - if( $detail->{type} eq 'skip' ) { - $totals->set_skip_reason( $detail->{reason} ) - unless defined $totals->skip_reason; - $totals->set_skip_reason( 'various reasons' ) - if $totals->skip_reason ne $detail->{reason}; - } - } - else { - _print_ml("NOK $curr/$max"); - } - - if( $curr > $next ) { - print "Test output counter mismatch [test $curr]\n"; - } - elsif( $curr < $next ) { - print "Confused test output: test $curr answered after ". - "test ", $next - 1, "\n"; - } - -}; - -sub bailout_handler { - my($self, $line, $type, $totals) = @_; - - die "FAILED--Further testing stopped" . - ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n"); -}; - - -sub _print_ml { - print join '', $ML, @_ if $ML; -} - - -# Print updates only once per second. -sub _print_ml_less { - my $now = CORE::time; - if ( $Last_ML_Print != $now ) { - _print_ml(@_); - $Last_ML_Print = $now; - } -} - -sub _bonusmsg { - my($tot) = @_; - - my $bonusmsg = ''; - $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : ''). - " UNEXPECTEDLY SUCCEEDED)") - if $tot->{bonus}; - - if ($tot->{skipped}) { - $bonusmsg .= ", $tot->{skipped} test" - . ($tot->{skipped} != 1 ? 's' : ''); - if ($tot->{sub_skipped}) { - $bonusmsg .= " and $tot->{sub_skipped} subtest" - . ($tot->{sub_skipped} != 1 ? 's' : ''); - } - $bonusmsg .= ' skipped'; - } - elsif ($tot->{sub_skipped}) { - $bonusmsg .= ", $tot->{sub_skipped} subtest" - . ($tot->{sub_skipped} != 1 ? 's' : '') - . " skipped"; - } - return $bonusmsg; -} - -# Test program go boom. -sub _dubious_return { - my($test, $tot, $estatus, $wstatus) = @_; - - my $failed = '??'; - my $canon = '??'; - - printf "$test->{ml}dubious\n\tTest returned status $estatus ". - "(wstat %d, 0x%x)\n", - $wstatus,$wstatus; - print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; - - $tot->{bad}++; - - if ($test->{max}) { - if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) { - print "\tafter all the subtests completed successfully\n"; - $failed = 0; # But we do not set $canon! - } - else { - push @{$test->{failed}}, $test->{'next'}..$test->{max}; - $failed = @{$test->{failed}}; - (my $txt, $canon) = _canondetail($test->{max},$test->{skipped},'Failed',@{$test->{failed}}); - print "DIED. ",$txt; - } - } - - return { canon => $canon, max => $test->{max} || '??', - failed => $failed, - estat => $estatus, wstat => $wstatus, - }; -} - - -sub _create_fmts { - my $failed_str = shift; - my $failedtests = shift; - - my ($type) = split /\s/,$failed_str; - my $short = substr($type,0,4); - my $total = $short eq 'Pass' ? 'TODOs' : 'Total'; - my $middle_str = " Stat Wstat $total $short "; - my $list_str = "List of $type"; - - # Figure out our longest name string for formatting purposes. - my $max_namelen = length($failed_str); - foreach my $script (keys %$failedtests) { - my $namelen = length $failedtests->{$script}->{name}; - $max_namelen = $namelen if $namelen > $max_namelen; - } - - my $list_len = $Columns - length($middle_str) - $max_namelen; - if ($list_len < length($list_str)) { - $list_len = length($list_str); - $max_namelen = $Columns - length($middle_str) - $list_len; - if ($max_namelen < length($failed_str)) { - $max_namelen = length($failed_str); - $Columns = $max_namelen + length($middle_str) + $list_len; - } - } - - my $fmt_top = sprintf("%-${max_namelen}s", $failed_str) - . $middle_str - . $list_str . "\n" - . "-" x $Columns - . "\n"; - - my $fmt1 = "@" . "<" x ($max_namelen - 1) - . " @>> @>>>> @>>>> @>>> " - . "^" . "<" x ($list_len - 1) . "\n"; - my $fmt2 = "~~" . " " x ($Columns - $list_len - 2) . "^" - . "<" x ($list_len - 1) . "\n"; - - return($fmt_top, $fmt1, $fmt2); -} - -sub _canondetail { - my $max = shift; - my $skipped = shift; - my $type = shift; - my @detail = @_; - my %seen; - @detail = sort {$a <=> $b} grep !$seen{$_}++, @detail; - my $detail = @detail; - my @result = (); - my @canon = (); - my $min; - my $last = $min = shift @detail; - my $canon; - my $uc_type = uc($type); - if (@detail) { - for (@detail, $detail[-1]) { # don't forget the last one - if ($_ > $last+1 || $_ == $last) { - push @canon, ($min == $last) ? $last : "$min-$last"; - $min = $_; - } - $last = $_; - } - local $" = ", "; - push @result, "$uc_type tests @canon\n"; - $canon = join ' ', @canon; - } - else { - push @result, "$uc_type test $last\n"; - $canon = $last; - } - - return (join("", @result), $canon) - if $type=~/todo/i; - push @result, "\t$type $detail/$max tests, "; - if ($max) { - push @result, sprintf("%.2f",100*(1-$detail/$max)), "% okay"; - } - else { - push @result, "?% okay"; - } - my $ender = 's' x ($skipped > 1); - if ($skipped) { - my $good = $max - $detail - $skipped; - my $skipmsg = " (less $skipped skipped test$ender: $good okay, "; - if ($max) { - my $goodper = sprintf("%.2f",100*($good/$max)); - $skipmsg .= "$goodper%)"; - } - else { - $skipmsg .= "?%)"; - } - push @result, $skipmsg; - } - push @result, "\n"; - my $txt = join "", @result; - return ($txt, $canon); -} - -1; -__END__ - - -=head1 EXPORT - -C<&runtests> is exported by Test::Harness by default. - -C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are -exported upon request. - -=head1 DIAGNOSTICS - -=over 4 - -=item C - -If all tests are successful some statistics about the performance are -printed. - -=item C - -For any single script that has failing subtests statistics like the -above are printed. - -=item C - -Scripts that return a non-zero exit status, both C<$? EE 8> -and C<$?> are printed in a message similar to the above. - -=item C - -=item C - -If not all tests were successful, the script dies with one of the -above messages. - -=item C - -If a single subtest decides that further testing will not make sense, -the script dies with this message. - -=back - -=head1 ENVIRONMENT VARIABLES THAT TEST::HARNESS SETS - -Test::Harness sets these before executing the individual tests. - -=over 4 - -=item C - -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 - -This is the version of Test::Harness. - -=back - -=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS - -=over 4 - -=item C - -This value will be used for the width of the terminal. If it is not -set then it will default to C. If this is not set, it will -default to 80. Note that users of Bourne-sh based shells will need to -C for this module to use that variable. - -=item C - -When true it will make harness attempt to compile the test using -C before running it. - -B This currently only works when sitting in the perl source -directory! - -=item C - -If true, Test::Harness will print debugging information about itself as -it runs the tests. This is different from C, which prints -the output from the test being run. Setting C<$Test::Harness::Debug> will -override this, or you can use the C<-d> switch in the F utility. - -=item C - -When set to the name of a directory, harness will check after each -test whether new files appeared in that directory, and report them as - - LEAKED FILES: scr.tmp 0 my.db - -If relative, directory name is with respect to the current directory at -the moment runtests() was called. Putting absolute path into -C may give more predictable results. - -=item C - -When set to a true value, forces it to behave as though STDOUT were -not a console. You may need to set this if you don't want harness to -output more frequent progress messages using carriage returns. Some -consoles may not handle carriage returns properly (which results in a -somewhat messy output). - -=item C - -Usually your tests will be run by C<$^X>, the currently-executing Perl. -However, you may want to have it run by a different executable, such as -a threading perl, or a different version. - -If you're using the F utility, you can use the C<--perl> switch. - -=item C - -Its value will be prepended to the switches used to invoke perl on -each test. For example, setting C to C<-W> will -run all tests with all warnings enabled. - -=item C - -Setting this to true will make the harness display the number of -milliseconds each test took. You can also use F's C<--timer> -switch. - -=item C - -If true, 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 utility. - -If true, 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 utility. - -=item C - -Defines the Test::Harness::Straps subclass to use. The value may either -be a filename or a class name. - -If HARNESS_STRAP_CLASS is a class name, the class must be in C<@INC> -like any other class. - -If HARNESS_STRAP_CLASS is a filename, the .pm file must return the name -of the class, instead of the canonical "1". - -=back - -=head1 EXAMPLE - -Here's how Test::Harness tests itself - - $ cd ~/src/devel/Test-Harness - $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose); - $verbose=0; runtests @ARGV;' t/*.t - Using /home/schwern/src/devel/Test-Harness/blib - t/base..............ok - t/nonumbers.........ok - t/ok................ok - t/test-harness......ok - All tests successful. - Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU) - -=head1 SEE ALSO - -The included F utility for running test scripts from the command line, -L and L for writing test scripts, L for -the underlying timing routines, and L for test coverage -analysis. - -=head1 TODO - -Provide a way of running tests quietly (ie. no printing) for automated -validation of tests. This will probably take the form of a version -of runtests() which rather than printing its output returns raw data -on the state of the tests. (Partially done in Test::Harness::Straps) - -Document the format. - -Fix HARNESS_COMPILE_TEST without breaking its core usage. - -Figure a way to report test names in the failure summary. - -Rework the test summary so long test names are not truncated as badly. -(Partially done with new skip test styles) - -Add option for coverage analysis. - -Trap STDERR. - -Implement Straps total_results() - -Remember exit code - -Completely redo the print summary code. - -Straps->analyze_file() not taint clean, don't know if it can be - -Fix that damned VMS nit. - -Add a test for verbose. - -Change internal list of test results to a hash. - -Fix stats display when there's an overrun. - -Fix so perls with spaces in the filename work. - -Keeping whittling away at _run_all_tests() - -Clean up how the summary is printed. Get rid of those damned formats. - -=head1 BUGS - -Please report any bugs or feature requests to -C, or through the web interface at -L. -I will be notified, and then you'll automatically be notified of progress on -your bug as I make changes. - -=head1 SUPPORT - -You can find documentation for this module with the F command. - - perldoc Test::Harness - -You can get docs for F with - - prove --man - -You can also look for information at: - -=over 4 - -=item * AnnoCPAN: Annotated CPAN documentation - -L - -=item * CPAN Ratings - -L - -=item * RT: CPAN's request tracker - -L - -=item * Search CPAN - -L - -=back - -=head1 SOURCE CODE - -The source code repository for Test::Harness is at -L. - -=head1 AUTHORS - -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 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. - -Current maintainer is Andy Lester C<< >>. - -=head1 COPYRIGHT - -Copyright 2002-2006 -by Michael G Schwern C<< >>, -Andy Lester C<< >>. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L. - -=cut