rpms/perl
3
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
332607edfb
perl/perl-update-Test-Harness.patch
Štěpán Kasal 26b7a08961 - remove compatibility obsolete sitelib directories 
- use a better BuildRoot
- drop a redundant mkdir in %%install
- call patchlevel.h only once; rm patchlevel.bak
- update modules Sys::Syslog, Module::Load::Conditional, Module::CoreList,
    Test::Harness, Test::Simple, CGI.pm (dropping the upstreamed patch),
    File::Path (that includes our perl-5.10.0-CVE-2008-2827.patch),
    constant, Pod::Simple, Archive::Tar, Archive::Extract, File::Fetch,
    File::Temp, IPC::Cmd, Time::HiRes, Module::Build, ExtUtils::CBuilder
- standardize the patches for updating embedded modules
- work around a bug in Module::Build tests bu setting TMPDIR to a directory
    inside the source tree
2009-03-11 21:12:37 +00:00

33017 lines
946 KiB
Diff
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

Test-Harness-3.16
- disabled perl5lib.t; it runs the installed /usr/bin/perl
- fixed the preamble of harness-bailout.t
diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST
--- perl-5.10.0.orig/MANIFEST 2009-02-20 18:22:32.000000000 +0100
+++ perl-5.10.0/MANIFEST 2009-03-10 17:20:31.000000000 +0100
@@ -1094,6 +1094,56 @@
ext/Sys/Syslog/win32/PerlLog.mc Sys::Syslog extension Win32 related file
ext/Sys/Syslog/win32/PerlLog_RES.uu Sys::Syslog extension Win32 related file
ext/Sys/Syslog/win32/Win32.pm Sys::Syslog extension Win32 related file
+ext/Test/Harness/t/000-load.t test for Test::Harness
+ext/Test/Harness/t/aggregator.t test for Test::Harness
+ext/Test/Harness/t/bailout.t test for Test::Harness
+ext/Test/Harness/t/base.t test for Test::Harness
+ext/Test/Harness/t/callbacks.t test for Test::Harness
+ext/Test/Harness/t/console.t test for Test::Harness
+ext/Test/Harness/t/compat/env.t test for Test::Harness
+ext/Test/Harness/t/compat/failure.t test for Test::Harness
+ext/Test/Harness/t/compat/inc-propagation.t test for Test::Harness
+ext/Test/Harness/t/compat/inc_taint.t test for Test::Harness
+ext/Test/Harness/t/compat/nonumbers.t test for Test::Harness
+ext/Test/Harness/t/compat/regression.t test for Test::Harness
+ext/Test/Harness/t/compat/test-harness-compat.t test for Test::Harness
+ext/Test/Harness/t/compat/version.t test for Test::Harness
+ext/Test/Harness/t/errors.t test for Test::Harness
+ext/Test/Harness/t/file.t test for Test::Harness
+ext/Test/Harness/t/glob-to-regexp.t test for Test::Harness
+ext/Test/Harness/t/grammar.t test for Test::Harness
+ext/Test/Harness/t/harness-bailout.t test for Test::Harness
+ext/Test/Harness/t/harness-subclass.t test for Test::Harness
+ext/Test/Harness/t/harness.t test for Test::Harness
+ext/Test/Harness/t/iterators.t test for Test::Harness
+ext/Test/Harness/t/multiplexer.t test for Test::Harness
+ext/Test/Harness/t/nofork-mux.t test for Test::Harness
+ext/Test/Harness/t/nofork.t test for Test::Harness
+ext/Test/Harness/t/object.t test for Test::Harness
+ext/Test/Harness/t/parse.t test for Test::Harness
+ext/Test/Harness/t/parser-config.t test for Test::Harness
+ext/Test/Harness/t/parser-subclass.t test for Test::Harness
+ext/Test/Harness/t/premature-bailout.t test for Test::Harness
+ext/Test/Harness/t/process.t test for Test::Harness
+ext/Test/Harness/t/prove.t test for Test::Harness
+ext/Test/Harness/t/proveenv.t test for Test::Harness
+ext/Test/Harness/t/proverc.t test for Test::Harness
+ext/Test/Harness/t/proverun.t test for Test::Harness
+ext/Test/Harness/t/regression.t test for Test::Harness
+ext/Test/Harness/t/results.t test for Test::Harness
+ext/Test/Harness/t/scheduler.t test for Test::Harness
+ext/Test/Harness/t/source.t test for Test::Harness
+ext/Test/Harness/t/spool.t test for Test::Harness
+ext/Test/Harness/t/state.t test for Test::Harness
+ext/Test/Harness/t/state_results.t test for Test::Harness
+ext/Test/Harness/t/streams.t test for Test::Harness
+ext/Test/Harness/t/taint.t test for Test::Harness
+ext/Test/Harness/t/testargs.t test for Test::Harness
+ext/Test/Harness/t/unicode.t test for Test::Harness
+ext/Test/Harness/t/utils.t test for Test::Harness
+ext/Test/Harness/t/yamlish-output.t test for Test::Harness
+ext/Test/Harness/t/yamlish-writer.t test for Test::Harness
+ext/Test/Harness/t/yamlish.t test for Test::Harness
ext/Text/Soundex/Changes Changelog for Text::Soundex
ext/Text/Soundex/Makefile.PL Text::Soundex extension makefile writer
ext/Text/Soundex/README README for Text::Soundex
@@ -2593,34 +2643,9 @@
lib/Test/Builder.pm For writing new test libraries
lib/Test/Builder/Tester/Color.pm Turn on color in Test::Builder::Tester
lib/Test/Builder/Tester.pm For testing Test::Builder based classes
-lib/Test/Harness/Assert.pm Test::Harness::Assert (internal use only)
lib/Test/Harness/bin/prove The prove harness utility
lib/Test/Harness/Changes Test::Harness
-lib/Test/Harness/Iterator.pm Test::Harness::Iterator (internal use only)
lib/Test/Harness.pm A test harness
-lib/Test/Harness/Point.pm Test::Harness::Point (internal use only)
-lib/Test/Harness/Results.pm object for tracking results from a single test file
-lib/Test/Harness/Straps.pm Test::Harness::Straps
-lib/Test/Harness/t/00compile.t Test::Harness test
-lib/Test/Harness/TAP.pod Documentation for the Test Anything Protocol
-lib/Test/Harness/t/assert.t Test::Harness::Assert test
-lib/Test/Harness/t/base.t Test::Harness test
-lib/Test/Harness/t/callback.t Test::Harness test
-lib/Test/Harness/t/failure.t Test::Harness test
-lib/Test/Harness/t/from_line.t Test::Harness test
-lib/Test/Harness/t/harness.t Test::Harness test
-lib/Test/Harness/t/inc_taint.t Test::Harness test
-lib/Test/Harness/t/nonumbers.t Test::Harness test
-lib/Test/Harness/t/ok.t Test::Harness test
-lib/Test/Harness/t/point-parse.t Test::Harness test
-lib/Test/Harness/t/point.t Test::Harness test
-lib/Test/Harness/t/prove-globbing.t Test::Harness::Straps test
-lib/Test/Harness/t/prove-switches.t Test::Harness::Straps test
-lib/Test/Harness/t/strap-analyze.t Test::Harness::Straps test
-lib/Test/Harness/t/strap.t Test::Harness::Straps test
-lib/Test/Harness/t/test-harness.t Test::Harness test
-lib/Test/Harness/t/version.t Test::Harness test
-lib/Test/Harness/Util.pm Various utility functions for Test::Harness
lib/Test/More.pm More utilities for writing tests
lib/Test.pm A simple framework for writing test scripts
lib/Test/Simple/Changes Test::Simple changes
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/000-load.t perl-5.10.0/ext/Test/Harness/t/000-load.t
--- perl-5.10.0.orig/ext/Test/Harness/t/000-load.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/000-load.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,61 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 78;
+
+BEGIN {
+
+ # TAP::Parser must come first
+ my @classes = qw(
+ TAP::Parser
+ App::Prove
+ App::Prove::State
+ App::Prove::State::Result
+ App::Prove::State::Result::Test
+ TAP::Base
+ TAP::Formatter::Color
+ TAP::Formatter::Console::ParallelSession
+ TAP::Formatter::Console::Session
+ TAP::Formatter::Console
+ TAP::Harness
+ TAP::Parser::Aggregator
+ TAP::Parser::Grammar
+ TAP::Parser::Iterator
+ TAP::Parser::Iterator::Array
+ TAP::Parser::Iterator::Process
+ TAP::Parser::Iterator::Stream
+ TAP::Parser::IteratorFactory
+ TAP::Parser::Multiplexer
+ TAP::Parser::Result
+ TAP::Parser::ResultFactory
+ TAP::Parser::Result::Bailout
+ TAP::Parser::Result::Comment
+ TAP::Parser::Result::Plan
+ TAP::Parser::Result::Pragma
+ TAP::Parser::Result::Test
+ TAP::Parser::Result::Unknown
+ TAP::Parser::Result::Version
+ TAP::Parser::Result::YAML
+ TAP::Parser::Result
+ TAP::Parser::Scheduler
+ TAP::Parser::Scheduler::Job
+ TAP::Parser::Scheduler::Spinner
+ TAP::Parser::Source::Perl
+ TAP::Parser::Source
+ TAP::Parser::YAMLish::Reader
+ TAP::Parser::YAMLish::Writer
+ TAP::Parser::Utils
+ Test::Harness
+ );
+
+ foreach my $class (@classes) {
+ use_ok $class or BAIL_OUT("Could not load $class");
+ is $class->VERSION, TAP::Parser->VERSION,
+ "... and $class should have the correct version";
+ }
+
+ diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X")
+ unless $ENV{PERL_CORE};
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/aggregator.t perl-5.10.0/ext/Test/Harness/t/aggregator.t
--- perl-5.10.0.orig/ext/Test/Harness/t/aggregator.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/aggregator.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,305 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 81;
+
+use TAP::Parser;
+use TAP::Parser::IteratorFactory;
+use TAP::Parser::Aggregator;
+
+my $tap = <<'END_TAP';
+1..5
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+END_TAP
+
+my $factory = TAP::Parser::IteratorFactory->new;
+my $stream = $factory->make_iterator( [ split /\n/ => $tap ] );
+isa_ok $stream, 'TAP::Parser::Iterator';
+
+my $parser1 = TAP::Parser->new( { stream => $stream } );
+isa_ok $parser1, 'TAP::Parser';
+
+$parser1->run;
+
+$tap = <<'END_TAP';
+1..7
+ok 1 - gentlemen, start your engines
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+my $parser2 = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser2, 'TAP::Parser';
+$parser2->run;
+
+can_ok 'TAP::Parser::Aggregator', 'new';
+my $agg = TAP::Parser::Aggregator->new;
+isa_ok $agg, 'TAP::Parser::Aggregator';
+
+can_ok $agg, 'add';
+ok $agg->add( 'tap1', $parser1 ), '... and calling it should succeed';
+ok $agg->add( 'tap2', $parser2 ), '... even if we add more than one parser';
+eval { $agg->add( 'tap1', $parser1 ) };
+like $@, qr/^You already have a parser for \Q(tap1)/,
+ '... but trying to reuse a description should be fatal';
+
+can_ok $agg, 'parsers';
+is scalar $agg->parsers, 2,
+ '... and it should report how many parsers it has';
+is_deeply [ $agg->parsers ], [ $parser1, $parser2 ],
+ '... or which parsers it has';
+is_deeply $agg->parsers('tap2'), $parser2, '... or reporting a single parser';
+is_deeply [ $agg->parsers(qw(tap2 tap1)) ], [ $parser2, $parser1 ],
+ '... or a group';
+
+# test aggregate results
+
+can_ok $agg, 'passed';
+is $agg->passed, 10,
+ '... and we should have the correct number of passed tests';
+is_deeply [ $agg->passed ], [qw(tap1 tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'failed';
+is $agg->failed, 2,
+ '... and we should have the correct number of failed tests';
+is_deeply [ $agg->failed ], [qw(tap1 tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'todo';
+is $agg->todo, 4, '... and we should have the correct number of todo tests';
+is_deeply [ $agg->todo ], [qw(tap1 tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'skipped';
+is $agg->skipped, 1,
+ '... and we should have the correct number of skipped tests';
+is_deeply [ $agg->skipped ], [qw(tap1)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'parse_errors';
+is $agg->parse_errors, 0, '... and the correct number of parse errors';
+is_deeply [ $agg->parse_errors ], [],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'todo_passed';
+is $agg->todo_passed, 1,
+ '... and the correct number of unexpectedly succeeded tests';
+is_deeply [ $agg->todo_passed ], [qw(tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'total';
+is $agg->total, $agg->passed + $agg->failed,
+ '... and we should have the correct number of total tests';
+
+can_ok $agg, 'planned';
+is $agg->planned, $agg->passed + $agg->failed,
+ '... and we should have the correct number of planned tests';
+
+can_ok $agg, 'has_problems';
+ok $agg->has_problems, '... and it should report true if there are problems';
+
+can_ok $agg, 'has_errors';
+ok $agg->has_errors, '... and it should report true if there are errors';
+
+can_ok $agg, 'get_status';
+is $agg->get_status, 'FAIL', '... and it should tell us the tests failed';
+
+can_ok $agg, 'all_passed';
+ok !$agg->all_passed, '... and it should tell us not all tests passed';
+
+# coverage testing
+
+# _get_parsers
+# bad descriptions
+# currently the $agg object has descriptions tap1 and tap2
+# call _get_parsers with another description.
+# $agg will call its _croak method
+my @die;
+
+eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $agg->_get_parsers('no_such_parser_for');
+};
+
+is @die, 1,
+ 'coverage tests for missing parsers... and we caught just one death message';
+like pop(@die),
+ qr/^A parser for \(no_such_parser_for\) could not be found at /,
+ '... and it was the expected death message';
+
+# _get_parsers in scalar context
+
+my $gp = $agg->_get_parsers(qw(tap1 tap2))
+ ; # should return ref to array containing parsers for tap1 and tap2
+
+is @$gp, 2,
+ 'coverage tests for _get_parser in scalar context... and we got the right number of parsers';
+isa_ok( $_, 'TAP::Parser' ) foreach (@$gp);
+
+# _get_parsers
+# todo_failed - this is a deprecated method, so it (and these tests)
+# can be removed eventually. However, it is showing up in the coverage
+# as never tested.
+my @warn;
+
+eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $agg->todo_failed();
+};
+
+# check the warning, making sure to capture the fullstops correctly (not
+# as "any char" matches)
+is @warn, 1,
+ 'coverage tests for deprecated todo_failed... and just one warning caught';
+like pop(@warn),
+ qr/^"todo_failed" is deprecated[.] Please use "todo_passed"[.] See the docs[.] at/,
+ '... and it was the expected warning';
+
+# has_problems
+# this has a large number of conditions 'OR'd together, so the tests get
+# a little complicated here
+
+# currently, we have covered the cases of failed() being true and none
+# of the summary methods failing
+
+# we need to set up test cases for
+# 1. !failed && todo_passed
+# 2. !failed && !todo_passed && parse_errors
+# 3. !failed && !todo_passed && !parse_errors && exit
+# 4. !failed && !todo_passed && !parse_errors && !exit && wait
+
+# note there is nothing wrong per se with the has_problems logic, these
+# are simply coverage tests
+
+# 1. !failed && todo_passed
+
+$agg = TAP::Parser::Aggregator->new();
+isa_ok $agg, 'TAP::Parser::Aggregator';
+
+$tap = <<'END_TAP';
+1..1
+ok 1 - you shall not pass! # TODO should have failed
+END_TAP
+
+my $parser3 = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser3, 'TAP::Parser';
+$parser3->run;
+
+$agg->add( 'tap3', $parser3 );
+
+is $agg->passed, 1,
+ 'coverage tests for !failed && todo_passed... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 1,
+ '... and the correct number of unexpectedly succeeded tests';
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
+is $agg->get_status, 'PASS', '... and the status should be passing';
+ok !$agg->has_errors, '.... but it should not report any errors';
+ok $agg->all_passed, '... bonus tests should be passing tests, too';
+
+# 2. !failed && !todo_passed && parse_errors
+
+$agg = TAP::Parser::Aggregator->new();
+
+$tap = <<'END_TAP';
+1..-1
+END_TAP
+
+my $parser4 = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser4, 'TAP::Parser';
+$parser4->run;
+
+$agg->add( 'tap4', $parser4 );
+
+is $agg->passed, 0,
+ 'coverage tests for !failed && !todo_passed && parse_errors... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 0,
+ '... and the correct number of unexpectedly succeeded tests';
+is $agg->parse_errors, 1, '... and the correct number of parse errors';
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
+
+# 3. !failed && !todo_passed && !parse_errors && exit
+# now this is a little harder to emulate cleanly through creating tap
+# fragments and parsing, as exit and wait collect OS-status codes.
+# so we'll get a little funky with $agg and push exit and wait descriptions
+# in it - not very friendly to internal rep changes.
+
+$agg = TAP::Parser::Aggregator->new();
+
+$tap = <<'END_TAP';
+1..1
+ok 1 - you shall not pass!
+END_TAP
+
+my $parser5 = TAP::Parser->new( { tap => $tap } );
+$parser5->run;
+
+$agg->add( 'tap', $parser5 );
+
+push @{ $agg->{descriptions_for_exit} }, 'one possible reason';
+$agg->{exit}++;
+
+is $agg->passed, 1,
+ 'coverage tests for !failed && !todo_passed && !parse_errors... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 0,
+ '... and the correct number of unexpectedly succeeded tests';
+is $agg->parse_errors, 0, '... and the correct number of parse errors';
+
+my @exits = $agg->exit;
+
+is @exits, 1, '... and the correct number of exits';
+is pop(@exits), 'one possible reason',
+ '... and we collected the right exit reason';
+
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
+
+# 4. !failed && !todo_passed && !parse_errors && !exit && wait
+
+$agg = TAP::Parser::Aggregator->new();
+
+$agg->add( 'tap', $parser5 );
+
+push @{ $agg->{descriptions_for_wait} }, 'another possible reason';
+$agg->{wait}++;
+
+is $agg->passed, 1,
+ 'coverage tests for !failed && !todo_passed && !parse_errors && !exit... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 0,
+ '... and the correct number of unexpectedly succeeded tests';
+is $agg->parse_errors, 0, '... and the correct number of parse errors';
+is $agg->exit, 0, '... and the correct number of exits';
+
+my @waits = $agg->wait;
+
+is @waits, 1, '... and the correct number of waits';
+is pop(@waits), 'another possible reason',
+ '... and we collected the right wait reason';
+
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/bailout.t perl-5.10.0/ext/Test/Harness/t/bailout.t
--- perl-5.10.0.orig/ext/Test/Harness/t/bailout.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/bailout.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,114 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 33;
+
+use TAP::Parser;
+
+my $tap = <<'END_TAP';
+1..4
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+Bail out! We ran out of foobar.
+END_TAP
+my $parser = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser, 'TAP::Parser',
+ '... we should be able to parse bailed out tests';
+
+my @results;
+while ( my $result = $parser->next ) {
+ push @results => $result;
+}
+
+can_ok $parser, 'passed';
+is $parser->passed, 3,
+ '... and we shold have the correct number of passed tests';
+is_deeply [ $parser->passed ], [ 1, 2, 3 ],
+ '... and get a list of the passed tests';
+
+can_ok $parser, 'failed';
+is $parser->failed, 1, '... and the correct number of failed tests';
+is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests';
+
+can_ok $parser, 'actual_passed';
+is $parser->actual_passed, 2,
+ '... and we shold have the correct number of actually passed tests';
+is_deeply [ $parser->actual_passed ], [ 1, 3 ],
+ '... and get a list of the actually passed tests';
+
+can_ok $parser, 'actual_failed';
+is $parser->actual_failed, 2,
+ '... and the correct number of actually failed tests';
+is_deeply [ $parser->actual_failed ], [ 2, 4 ],
+ '... or get a list of the actually failed tests';
+
+can_ok $parser, 'todo';
+is $parser->todo, 1,
+ '... and we should have the correct number of TODO tests';
+is_deeply [ $parser->todo ], [2], '... and get a list of the TODO tests';
+
+ok !$parser->skipped,
+ '... and we should have the correct number of skipped tests';
+
+# check the plan
+
+can_ok $parser, 'plan';
+is $parser->plan, '1..4', '... and we should have the correct plan';
+is $parser->tests_planned, 4, '... and the correct number of tests';
+
+# results() is sane?
+
+ok @results, 'The parser should return results';
+is scalar @results, 8, '... and there should be one for each line';
+
+# check the test plan
+
+my $result = shift @results;
+ok $result->is_plan, 'We should have a plan';
+
+# a normal, passing test
+
+my $test = shift @results;
+ok $test->is_test, '... and a test';
+
+# junk lines should be preserved
+
+my $unknown = shift @results;
+ok $unknown->is_unknown, '... and an unknown line';
+
+# a failing test, which also happens to have a directive
+
+my $failed = shift @results;
+ok $failed->is_test, '... and another test';
+
+# comments
+
+my $comment = shift @results;
+ok $comment->is_comment, '... and a comment';
+
+# another normal, passing test
+
+$test = shift @results;
+ok $test->is_test, '... and another test';
+
+# a failing test
+
+$failed = shift @results;
+ok $failed->is_test, '... and yet another test';
+
+# ok 5 # skip we have no description
+# skipped test
+my $bailout = shift @results;
+ok $bailout->is_bailout, 'And finally we should have a bailout';
+is $bailout->as_string, 'We ran out of foobar.',
+ '... and as_string() should return the explanation';
+is $bailout->raw, 'Bail out! We ran out of foobar.',
+ '... and raw() should return the explanation';
+is $bailout->explanation, 'We ran out of foobar.',
+ '... and it should have the correct explanation';
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/base.t perl-5.10.0/ext/Test/Harness/t/base.t
--- perl-5.10.0.orig/ext/Test/Harness/t/base.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/base.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,173 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 38;
+
+use TAP::Base;
+
+{
+
+ # No callbacks allowed
+ can_ok 'TAP::Base', 'new';
+ my $base = TAP::Base->new();
+ isa_ok $base, 'TAP::Base', 'object of correct type';
+ foreach my $method (qw(callback _croak _callback_for _initialize)) {
+ can_ok $base, $method;
+ }
+
+ eval {
+ $base->callback(
+ some_event => sub {
+
+ # do nothing
+ }
+ );
+ };
+ like( $@, qr/No callbacks/, 'no callbacks allowed croaks OK' );
+ my $cb = $base->_callback_for('some_event');
+ ok( !$cb, 'no callback installed' );
+}
+
+{
+
+ # No callbacks allowed, constructor should croak
+ eval {
+ my $base = TAP::Base->new(
+ { callbacks => {
+ some_event => sub {
+
+ # do nothing
+ }
+ }
+ }
+ );
+ };
+ like(
+ $@, qr/No callbacks/,
+ 'no callbacks in constructor croaks OK'
+ );
+}
+
+package CallbackOK;
+
+use TAP::Base;
+use vars qw(@ISA);
+@ISA = 'TAP::Base';
+
+sub _initialize {
+ my $self = shift;
+ my $args = shift;
+ $self->SUPER::_initialize( $args, [qw( nice_event other_event )] );
+ return $self;
+}
+
+package main;
+{
+ my $base = CallbackOK->new();
+ isa_ok $base, 'TAP::Base';
+
+ eval {
+ $base->callback(
+ some_event => sub {
+
+ # do nothing
+ }
+ );
+ };
+ like( $@, qr/Callback some_event/, 'illegal callback croaks OK' );
+
+ my ( $nice, $other ) = ( 0, 0 );
+
+ eval {
+ $base->callback( other_event => sub { $other-- } );
+ $base->callback( nice_event => sub { $nice++; return shift() . 'OK' }
+ );
+ };
+
+ ok( !$@, 'callbacks installed OK' );
+
+ my $nice_cbs = $base->_callback_for('nice_event');
+ is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$nice_cbs, 1, 'right number of callbacks' );
+ my $nice_cb = $nice_cbs->[0];
+ ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
+ my $got = $nice_cb->('Is ');
+ is( $got, 'Is OK', 'args passed to callback' );
+ cmp_ok( $nice, '==', 1, 'callback calls the right sub' );
+
+ my $other_cbs = $base->_callback_for('other_event');
+ is( ref $other_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$other_cbs, 1, 'right number of callbacks' );
+ my $other_cb = $other_cbs->[0];
+ ok( ref $other_cb eq 'CODE', 'callback for other_event returned' );
+ $other_cb->();
+ cmp_ok( $other, '==', -1, 'callback calls the right sub' );
+
+ my @got = $base->_make_callback( 'nice_event', 'I am ' );
+ is( scalar @got, 1, 'right number of results' );
+ is( $got[0], 'I am OK', 'callback via _make_callback works' );
+}
+
+{
+ my ( $nice, $other ) = ( 0, 0 );
+
+ my $base = CallbackOK->new(
+ { callbacks => {
+ nice_event => sub { $nice++ }
+ }
+ }
+ );
+
+ isa_ok $base, 'TAP::Base', 'object creation with callback succeeds';
+
+ eval {
+ $base->callback(
+ some_event => sub {
+
+ # do nothing
+ }
+ );
+ };
+ like( $@, qr/Callback some_event/, 'illegal callback croaks OK' );
+
+ eval {
+ $base->callback( other_event => sub { $other-- } );
+ };
+
+ ok( !$@, 'callback installed OK' );
+
+ my $nice_cbs = $base->_callback_for('nice_event');
+ is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$nice_cbs, 1, 'right number of callbacks' );
+ my $nice_cb = $nice_cbs->[0];
+ ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
+ $nice_cb->();
+ cmp_ok( $nice, '==', 1, 'callback calls the right sub' );
+
+ my $other_cbs = $base->_callback_for('other_event');
+ is( ref $other_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$other_cbs, 1, 'right number of callbacks' );
+ my $other_cb = $other_cbs->[0];
+ ok( ref $other_cb eq 'CODE', 'callback for other_event returned' );
+ $other_cb->();
+ cmp_ok( $other, '==', -1, 'callback calls the right sub' );
+
+ # my @got = $base->_make_callback( 'nice_event', 'I am ' );
+ # is ( scalar @got, 1, 'right number of results' );
+ # is( $got[0], 'I am OK', 'callback via _make_callback works' );
+
+ my $status = undef;
+
+ # Stack another callback
+ $base->callback( other_event => sub { $status = 'OK'; return 'Aye' } );
+
+ my $new_cbs = $base->_callback_for('other_event');
+ is( ref $new_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$new_cbs, 2, 'right number of callbacks' );
+ my $new_cb = $new_cbs->[1];
+ ok( ref $new_cb eq 'CODE', 'callback for new_event returned' );
+ my @got = $new_cb->();
+ is( $status, 'OK', 'new callback called OK' );
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/callbacks.t perl-5.10.0/ext/Test/Harness/t/callbacks.t
--- perl-5.10.0.orig/ext/Test/Harness/t/callbacks.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/callbacks.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,115 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 10;
+
+use TAP::Parser;
+use TAP::Parser::IteratorFactory;
+
+my $tap = <<'END_TAP';
+1..5
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+END_TAP
+
+my @tests;
+my $plan_output;
+my $todo = 0;
+my $skip = 0;
+my %callbacks = (
+ test => sub {
+ my $test = shift;
+ push @tests => $test;
+ $todo++ if $test->has_todo;
+ $skip++ if $test->has_skip;
+ },
+ plan => sub {
+ my $plan = shift;
+ $plan_output = $plan->as_string;
+ }
+);
+
+my $factory = TAP::Parser::IteratorFactory->new;
+my $stream = $factory->make_iterator( [ split /\n/ => $tap ] );
+my $parser = TAP::Parser->new(
+ { stream => $stream,
+ callbacks => \%callbacks,
+ }
+);
+
+can_ok $parser, 'run';
+$parser->run;
+is $plan_output, '1..5', 'Plan callbacks should succeed';
+is scalar @tests, $parser->tests_run, '... as should the test callbacks';
+
+@tests = ();
+$plan_output = '';
+$todo = 0;
+$skip = 0;
+my $else = 0;
+my $all = 0;
+my $end = 0;
+%callbacks = (
+ test => sub {
+ my $test = shift;
+ push @tests => $test;
+ $todo++ if $test->has_todo;
+ $skip++ if $test->has_skip;
+ },
+ plan => sub {
+ my $plan = shift;
+ $plan_output = $plan->as_string;
+ },
+ EOF => sub {
+ $end = 1 if $all == 8;
+ },
+ ELSE => sub {
+ $else++;
+ },
+ ALL => sub {
+ $all++;
+ },
+);
+
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
+$parser = TAP::Parser->new(
+ { stream => $stream,
+ callbacks => \%callbacks,
+ }
+);
+
+can_ok $parser, 'run';
+$parser->run;
+is $plan_output, '1..5', 'Plan callbacks should succeed';
+is scalar @tests, $parser->tests_run, '... as should the test callbacks';
+is $else, 2, '... and the correct number of "ELSE" lines should be seen';
+is $all, 8, '... and the correct total number of lines should be seen';
+is $end, 1, 'EOF callback correctly called';
+
+# Check callback name policing
+
+%callbacks = (
+ sometest => sub { },
+ plan => sub { },
+ random => sub { },
+ ALL => sub { },
+ ELSES => sub { },
+);
+
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
+eval {
+ $parser = TAP::Parser->new(
+ { stream => $stream,
+ callbacks => \%callbacks,
+ }
+ );
+};
+
+like $@, qr/Callback/, 'Bad callback keys faulted';
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/env.t perl-5.10.0/ext/Test/Harness/t/compat/env.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/env.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/env.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,39 @@
+#!/usr/bin/perl -w
+
+# Test that env vars are honoured.
+
+use strict;
+use lib 't/lib';
+
+use Test::More (
+ $^O eq 'VMS'
+ ? ( skip_all => 'VMS' )
+ : ( tests => 1 )
+);
+
+use Test::Harness;
+
+# HARNESS_PERL_SWITCHES
+
+my $test_template = <<'END';
+#!/usr/bin/perl
+
+use Test::More tests => 1;
+
+is $ENV{HARNESS_PERL_SWITCHES}, '-w';
+END
+
+open TEST, ">env_check_t.tmp";
+print TEST $test_template;
+close TEST;
+
+END { unlink 'env_check_t.tmp'; }
+
+{
+ local $ENV{HARNESS_PERL_SWITCHES} = '-w';
+ my ( $tot, $failed )
+ = Test::Harness::execute_tests( tests => ['env_check_t.tmp'] );
+ is $tot->{bad}, 0;
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/failure.t perl-5.10.0/ext/Test/Harness/t/compat/failure.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/failure.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/failure.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,66 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 5;
+
+use File::Spec;
+use Test::Harness;
+
+{
+
+ #todo_skip 'Harness compatibility incomplete', 5;
+ #local $TODO = 'Harness compatibility incomplete';
+ my $died;
+
+ sub prepare_for_death {
+ $died = 0;
+ return sub { $died = 1 }
+ }
+
+ my $sample_tests;
+ if ( $ENV{PERL_CORE} ) {
+ my $updir = File::Spec->updir;
+ $sample_tests = File::Spec->catdir(
+ $updir, 'ext', 'Test', 'Harness', 't',
+ 'sample-tests'
+ );
+ }
+ else {
+ my $curdir = File::Spec->curdir;
+ $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' );
+ }
+
+ {
+ local $SIG{__DIE__} = prepare_for_death();
+ eval { _runtests( File::Spec->catfile( $sample_tests, "simple" ) ); };
+ ok( !$@, "simple lives" );
+ is( $died, 0, "Death never happened" );
+ }
+
+ {
+ local $SIG{__DIE__} = prepare_for_death();
+ eval {
+ _runtests( File::Spec->catfile( $sample_tests, "too_many" ) );
+ };
+ ok( $@, "error OK" );
+ ok( $@ =~ m[Failed 1/1], "too_many dies" );
+ is( $died, 1, "Death happened" );
+ }
+}
+
+sub _runtests {
+ my (@tests) = @_;
+
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+ local $ENV{HARNESS_VERBOSE} = 0;
+ local $ENV{HARNESS_DEBUG} = 0;
+ local $ENV{HARNESS_TIMER} = 0;
+
+ local $Test::Harness::Verbose = -9;
+
+ runtests(@tests);
+}
+
+# vim:ts=4:sw=4:et:sta
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/inc-propagation.t perl-5.10.0/ext/Test/Harness/t/compat/inc-propagation.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/inc-propagation.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/inc-propagation.t 2009-03-10 17:38:43.000000000 +0100
@@ -0,0 +1,57 @@
+#!/usr/bin/perl -w
+
+# Test that @INC is propogated from the harness process to the test
+# process.
+
+use strict;
+use lib 't/lib';
+use Config;
+
+local
+ $ENV{PERL5OPT}; # avoid any user-provided PERL5OPT from contaminating @INC
+
+sub has_crazy_patch {
+ my $sentinel = 'blirpzoffle';
+ local $ENV{PERL5LIB} = $sentinel;
+ my $command = join ' ',
+ map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' );
+ my $path = `$command`;
+ my @got = ( $path =~ /($sentinel)/g );
+ return @got > 1;
+}
+
+use Test::More (
+ $^O eq 'VMS' ? ( skip_all => 'VMS' )
+ : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' )
+ : ( tests => 2 )
+);
+
+use Test::Harness;
+
+# Change @INC so we ensure it's preserved.
+use lib 'wibble';
+
+my $test_template = <<'END';
+#!/usr/bin/perl %s
+
+use Test::More tests => 2;
+
+is $INC[0], "wibble", 'basic order of @INC preserved' or diag "\@INC: @INC";
+like $ENV{PERL5LIB}, qr{wibble};
+
+END
+
+open TEST, ">inc_check.t.tmp";
+printf TEST $test_template, '';
+close TEST;
+
+open TEST, ">inc_check_taint.t.tmp";
+printf TEST $test_template, '-T';
+close TEST;
+END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; }
+
+for my $test ( 'inc_check_taint.t.tmp', 'inc_check.t.tmp' ) {
+ my ( $tot, $failed ) = Test::Harness::execute_tests( tests => [$test] );
+ is $tot->{bad}, 0;
+}
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/inc_taint.t perl-5.10.0/ext/Test/Harness/t/compat/inc_taint.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/inc_taint.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/inc_taint.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,45 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More tests => 1;
+
+use Dev::Null;
+
+use Test::Harness;
+
+sub _all_ok {
+ my ($tot) = shift;
+ return $tot->{bad} == 0
+ && ( $tot->{max} || $tot->{skipped} ) ? 1 : 0;
+}
+
+{
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+ local $Test::Harness::Verbose = -9;
+
+ push @INC, 'examples';
+
+ tie *NULL, 'Dev::Null' or die $!;
+ select NULL;
+ my ( $tot, $failed ) = Test::Harness::execute_tests(
+ tests => [
+ $ENV{PERL_CORE}
+ ? '../ext/Test/Harness/t/sample-tests/inc_taint'
+ : 't/sample-tests/inc_taint'
+ ]
+ );
+ select STDOUT;
+
+ ok( _all_ok($tot), 'tests with taint on preserve @INC' );
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/nonumbers.t perl-5.10.0/ext/Test/Harness/t/compat/nonumbers.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/nonumbers.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/nonumbers.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,14 @@
+if ( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) {
+ print "1..0 # Skip: t/TEST needs numbers\n";
+ exit;
+}
+
+print <<END;
+1..6
+ok
+ok
+ok
+ok
+ok
+ok
+END
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/regression.t perl-5.10.0/ext/Test/Harness/t/compat/regression.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/regression.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/regression.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,19 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 1;
+use Test::Harness;
+
+# 28567
+my ( @before, @after );
+{
+ local @INC;
+ unshift @INC, 'wibble';
+ @before = Test::Harness::_filtered_inc();
+ unshift @INC, sub {die};
+ @after = Test::Harness::_filtered_inc();
+}
+
+is_deeply \@after, \@before, 'subref removed from @INC';
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/test-harness-compat.t perl-5.10.0/ext/Test/Harness/t/compat/test-harness-compat.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/test-harness-compat.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/test-harness-compat.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,858 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+
+# use lib 't/lib';
+
+use Test::More;
+use File::Spec;
+use Test::Harness qw(execute_tests);
+
+# unset this global when self-testing ('testcover' and etc issue)
+local $ENV{HARNESS_PERL_SWITCHES};
+
+my $TEST_DIR
+ = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/sample-tests' : 't/sample-tests';
+
+{
+
+ # if the harness wants to save the resulting TAP we shouldn't
+ # do it for our internal calls
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+
+ my $PER_LOOP = 4;
+
+ my $results = {
+ 'descriptive' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ join(
+ ',', qw(
+ descriptive die die_head_end die_last_minute duplicates
+ head_end head_fail inc_taint junk_before_plan lone_not_bug
+ no_nums no_output schwern sequence_misparse shbang_misparse
+ simple simple_fail skip skip_nomsg skipall skipall_nomsg
+ stdout_stderr taint todo_inline
+ todo_misparse too_many vms_nit
+ )
+ ) => {
+ 'failed' => {
+ "$TEST_DIR/die" => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => "$TEST_DIR/die",
+ 'wstat' => '256'
+ },
+ "$TEST_DIR/die_head_end" => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => "$TEST_DIR/die_head_end",
+ 'wstat' => '256'
+ },
+ "$TEST_DIR/die_last_minute" => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => 0,
+ 'max' => 4,
+ 'name' => "$TEST_DIR/die_last_minute",
+ 'wstat' => '256'
+ },
+ "$TEST_DIR/duplicates" => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => 10,
+ 'name' => "$TEST_DIR/duplicates",
+ 'wstat' => ''
+ },
+ "$TEST_DIR/head_fail" => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 4,
+ 'name' => "$TEST_DIR/head_fail",
+ 'wstat' => ''
+ },
+ "$TEST_DIR/inc_taint" => {
+ 'canon' => 1,
+ 'estat' => 1,
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => "$TEST_DIR/inc_taint",
+ 'wstat' => '256'
+ },
+ "$TEST_DIR/no_nums" => {
+ 'canon' => 3,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 5,
+ 'name' => "$TEST_DIR/no_nums",
+ 'wstat' => ''
+ },
+ "$TEST_DIR/no_output" => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => "$TEST_DIR/no_output",
+ 'wstat' => ''
+ },
+ "$TEST_DIR/simple_fail" => {
+ 'canon' => '2 5',
+ 'estat' => '',
+ 'failed' => 2,
+ 'max' => 5,
+ 'name' => "$TEST_DIR/simple_fail",
+ 'wstat' => ''
+ },
+ "$TEST_DIR/todo_misparse" => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => "$TEST_DIR/todo_misparse",
+ 'wstat' => ''
+ },
+ "$TEST_DIR/too_many" => {
+ 'canon' => '4-7',
+ 'estat' => 4,
+ 'failed' => 4,
+ 'max' => 3,
+ 'name' => "$TEST_DIR/too_many",
+ 'wstat' => '1024'
+ },
+ "$TEST_DIR/vms_nit" => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => "$TEST_DIR/vms_nit",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {
+ "$TEST_DIR/todo_inline" => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => "$TEST_DIR/todo_inline",
+ 'wstat' => ''
+ }
+ },
+ 'totals' => {
+ 'bad' => 12,
+ 'bonus' => 1,
+ 'files' => 27,
+ 'good' => 15,
+ 'max' => 76,
+ 'ok' => 78,
+ 'skipped' => 2,
+ 'sub_skipped' => 2,
+ 'tests' => 27,
+ 'todo' => 2
+ }
+ },
+ 'die' => {
+ 'failed' => {
+ "$TEST_DIR/die" => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => "$TEST_DIR/die",
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'die_head_end' => {
+ 'failed' => {
+ "$TEST_DIR/die_head_end" => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => "$TEST_DIR/die_head_end",
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 0,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'die_last_minute' => {
+ 'failed' => {
+ "$TEST_DIR/die_last_minute" => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => 0,
+ 'max' => 4,
+ 'name' => "$TEST_DIR/die_last_minute",
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'duplicates' => {
+ 'failed' => {
+ "$TEST_DIR/duplicates" => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => 10,
+ 'name' => "$TEST_DIR/duplicates",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 10,
+ 'ok' => 11,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'head_end' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'head_fail' => {
+ 'failed' => {
+ "$TEST_DIR/head_fail" => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 4,
+ 'name' => "$TEST_DIR/head_fail",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 4,
+ 'ok' => 3,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'inc_taint' => {
+ 'failed' => {
+ "$TEST_DIR/inc_taint" => {
+ 'canon' => 1,
+ 'estat' => 1,
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => "$TEST_DIR/inc_taint",
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 1,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'junk_before_plan' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'lone_not_bug' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'no_nums' => {
+ 'failed' => {
+ "$TEST_DIR/no_nums" => {
+ 'canon' => 3,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 5,
+ 'name' => "$TEST_DIR/no_nums",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 5,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'no_output' => {
+ 'failed' => {
+ "$TEST_DIR/no_output" => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => "$TEST_DIR/no_output",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'schwern' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'sequence_misparse' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'shbang_misparse' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 2,
+ 'ok' => 2,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'simple' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'simple_fail' => {
+ 'failed' => {
+ "$TEST_DIR/simple_fail" => {
+ 'canon' => '2 5',
+ 'estat' => '',
+ 'failed' => 2,
+ 'max' => 5,
+ 'name' => "$TEST_DIR/simple_fail",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 5,
+ 'ok' => 3,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skip' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 1,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skip_nomsg' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 1,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skipall' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 1,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skipall_nomsg' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 1,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'stdout_stderr' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'switches' => {
+ 'skip_if' => sub {
+ ( $ENV{PERL5OPT} || '' ) =~ m{(?:^|\s)-[dM]};
+ },
+ 'failed' => {
+ "$TEST_DIR/switches" => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => "$TEST_DIR/switches",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 1,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'taint' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'taint_warn' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ },
+ 'require' => 5.008001,
+ },
+ 'todo_inline' => {
+ 'failed' => {},
+ 'todo' => {
+ "$TEST_DIR/todo_inline" => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => "$TEST_DIR/todo_inline",
+ 'wstat' => ''
+ }
+ },
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 1,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 3,
+ 'ok' => 3,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 2
+ }
+ },
+ 'todo_misparse' => {
+ 'failed' => {
+ "$TEST_DIR/todo_misparse" => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => "$TEST_DIR/todo_misparse",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 1,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'too_many' => {
+ 'failed' => {
+ "$TEST_DIR/too_many" => {
+ 'canon' => '4-7',
+ 'estat' => 4,
+ 'failed' => 4,
+ 'max' => 3,
+ 'name' => "$TEST_DIR/too_many",
+ 'wstat' => '1024'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 3,
+ 'ok' => 7,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'vms_nit' => {
+ 'failed' => {
+ "$TEST_DIR/vms_nit" => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => "$TEST_DIR/vms_nit",
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 2,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ }
+ };
+
+ my $num_tests = ( keys %$results ) * $PER_LOOP;
+
+ plan tests => $num_tests;
+
+ sub local_name {
+ my $name = shift;
+ return File::Spec->catfile( split /\//, $name );
+ }
+
+ sub local_result {
+ my $hash = shift;
+ my $new = {};
+
+ while ( my ( $file, $want ) = each %$hash ) {
+ if ( exists $want->{name} ) {
+ $want->{name} = local_name( $want->{name} );
+ }
+ $new->{ local_name($file) } = $want;
+ }
+ return $new;
+ }
+
+ sub vague_status {
+ my $hash = shift;
+ return $hash unless $^O eq 'VMS';
+
+ while ( my ( $file, $want ) = each %$hash ) {
+ for (qw( estat wstat )) {
+ if ( exists $want->{$_} ) {
+ $want->{$_} = $want->{$_} ? 1 : 0;
+ }
+ }
+ }
+ return $hash;
+ }
+
+ {
+ local $^W = 0;
+
+ # Silence harness output
+ *TAP::Formatter::Console::_output = sub {
+
+ # do nothing
+ };
+ }
+
+ for my $test_key ( sort keys %$results ) {
+ my $result = $results->{$test_key};
+ SKIP: {
+ if ( $result->{require} && $] < $result->{require} ) {
+ skip "Test requires Perl $result->{require}, we have $]", 4;
+ }
+
+ if ( my $skip_if = $result->{skip_if} ) {
+ skip
+ "Test '$test_key' can't run properly in this environment", 4
+ if $skip_if->();
+ }
+
+ my @test_names = split( /,/, $test_key );
+ my @test_files
+ = map { File::Spec->catfile( $TEST_DIR, $_ ) } @test_names;
+
+ # For now we supress STDERR because it crufts up /our/ test
+ # results. Should probably capture and analyse it.
+ local ( *OLDERR, *OLDOUT );
+ open OLDERR, '>&STDERR' or die $!;
+ open OLDOUT, '>&STDOUT' or die $!;
+ my $devnull = File::Spec->devnull;
+ open STDERR, ">$devnull" or die $!;
+ open STDOUT, ">$devnull" or die $!;
+
+ my ( $tot, $fail, $todo, $harness, $aggregate )
+ = execute_tests( tests => \@test_files );
+
+ open STDERR, '>&OLDERR' or die $!;
+ open STDOUT, '>&OLDOUT' or die $!;
+
+ my $bench = delete $tot->{bench};
+ isa_ok $bench, 'Benchmark';
+
+ # Localise filenames in failed, todo
+ my $lfailed = vague_status( local_result( $result->{failed} ) );
+ my $ltodo = vague_status( local_result( $result->{todo} ) );
+
+ # use Data::Dumper;
+ # diag Dumper( [ $lfailed, $ltodo ] );
+
+ is_deeply $tot, $result->{totals}, "totals match for $test_key";
+ is_deeply vague_status($fail), $lfailed,
+ "failure summary matches for $test_key";
+ is_deeply vague_status($todo), $ltodo,
+ "todo summary matches for $test_key";
+ }
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/compat/version.t perl-5.10.0/ext/Test/Harness/t/compat/version.t
--- perl-5.10.0.orig/ext/Test/Harness/t/compat/version.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/compat/version.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,11 @@
+#!/usr/bin/perl -Tw
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 2;
+use Test::Harness;
+
+my $ver = $ENV{HARNESS_VERSION} or die "HARNESS_VERSION not set";
+ok( $ver =~ /^[23].\d\d(_\d\d)?$/, "Version is proper format" );
+is( $ver, $Test::Harness::VERSION );
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/console.t perl-5.10.0/ext/Test/Harness/t/console.t
--- perl-5.10.0.orig/ext/Test/Harness/t/console.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/console.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,47 @@
+use strict;
+use lib 't/lib';
+use Test::More;
+use TAP::Formatter::Console;
+
+my @schedule;
+
+BEGIN {
+ @schedule = (
+ { method => '_range',
+ in => sub {qw/2 7 1 3 10 9/},
+ out => sub {qw/1-3 7 9-10/},
+ name => '... and it should return numbers as ranges'
+ },
+ { method => '_balanced_range',
+ in => sub { 7, qw/2 7 1 3 10 9/ },
+ out => sub { '1-3, 7', '9-10' },
+ name => '... and it should return numbers as ranges'
+ },
+ );
+
+ plan tests => @schedule * 3;
+}
+
+for my $test (@schedule) {
+ my $name = $test->{name};
+ my $cons = TAP::Formatter::Console->new;
+ isa_ok $cons, 'TAP::Formatter::Console';
+ my $method = $test->{method};
+ can_ok $cons, $method;
+ is_deeply [ $cons->$method( $test->{in}->() ) ], [ $test->{out}->() ],
+ $name;
+}
+
+#### Color tests ####
+
+package Colorizer;
+
+sub new { bless {}, shift }
+sub can_color {1}
+
+sub set_color {
+ my ( $self, $output, $color ) = @_;
+ $output->("[[$color]]");
+}
+
+package main;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/data/catme.1 perl-5.10.0/ext/Test/Harness/t/data/catme.1
--- perl-5.10.0.orig/ext/Test/Harness/t/data/catme.1 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/data/catme.1 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,2 @@
+1..1
+ok 1
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/data/proverc perl-5.10.0/ext/Test/Harness/t/data/proverc
--- perl-5.10.0.orig/ext/Test/Harness/t/data/proverc 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/data/proverc 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,7 @@
+--should be --split correctly # No comment!
+Can "quote things" 'using single or' "double quotes"
+
+# More stuff
+--this
+is
+'OK?'
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/data/sample.yml perl-5.10.0/ext/Test/Harness/t/data/sample.yml
--- perl-5.10.0.orig/ext/Test/Harness/t/data/sample.yml 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/data/sample.yml 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,29 @@
+---
+invoice: 34843
+date : 2001-01-23
+bill-to:
+ given : Chris
+ family : Dumars
+ address:
+ lines: |
+ 458 Walkman Dr.
+ Suite #292
+ city : Royal Oak
+ state : MI
+ postal : 48046
+product:
+ - sku : BL394D
+ quantity : 4
+ description : Basketball
+ price : 450.00
+ - sku : BL4438H
+ quantity : 1
+ description : Super Hoop
+ price : 2392.00
+tax : 251.42
+total: 4443.52
+comments: >
+ Late afternoon is best.
+ Backup contact is Nancy
+ Billsmer @ 338-4338
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/errors.t perl-5.10.0/ext/Test/Harness/t/errors.t
--- perl-5.10.0.orig/ext/Test/Harness/t/errors.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/errors.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,183 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 23;
+
+use TAP::Parser;
+
+my $plan_line = 'TAP::Parser::Result::Plan';
+my $test_line = 'TAP::Parser::Result::Test';
+
+sub _parser {
+ my $parser = TAP::Parser->new( { tap => shift } );
+ $parser->run;
+ return $parser;
+}
+
+# validate that plan!
+
+my $parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 3 - read the rest of the file
+1..3
+# comments are allowed after an ending plan
+END_TAP
+
+can_ok $parser, 'parse_errors';
+ok !$parser->parse_errors,
+ '... comments should be allowed after a terminating plan';
+
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 3 - read the rest of the file
+1..3
+# yeah, yeah, I know.
+ok
+END_TAP
+
+can_ok $parser, 'parse_errors';
+is scalar $parser->parse_errors, 2, '... and we should have two parse errors';
+
+is [ $parser->parse_errors ]->[0],
+ 'Plan (1..3) must be at the beginning or end of the TAP output',
+ '... telling us that our plan was misplaced';
+is [ $parser->parse_errors ]->[1],
+ 'Bad plan. You planned 3 tests but ran 4.',
+ '... and telling us we ran the wrong number of tests.';
+
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 3 - read the rest of the file
+#1..3
+# yo quiero tests!
+1..3
+END_TAP
+ok !$parser->parse_errors, '... but test plan-like data can be in a comment';
+
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 3 - read the rest of the file 1..5
+# yo quiero tests!
+1..3
+END_TAP
+ok !$parser->parse_errors, '... or a description';
+
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo 1..4
+ok 3 - read the rest of the file
+# yo quiero tests!
+1..3
+END_TAP
+ok !$parser->parse_errors, '... or a directive';
+
+# test numbers included?
+
+$parser = _parser(<<'END_TAP');
+1..3
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok read the rest of the file
+# this is ...
+END_TAP
+eval { $parser->run };
+ok !$@, 'We can mix and match the presence of test numbers';
+
+$parser = _parser(<<'END_TAP');
+1..3
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 2 read the rest of the file
+END_TAP
+
+is + ( $parser->parse_errors )[0],
+ 'Tests out of sequence. Found (2) but expected (3)',
+ '... and if the numbers are there, they cannot be out of sequence';
+
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 2 read the rest of the file
+END_TAP
+
+is $parser->parse_errors, 2,
+ 'Having two errors in the TAP should result in two errors (duh)';
+my $expected = [
+ 'Tests out of sequence. Found (2) but expected (3)',
+ 'No plan found in TAP output'
+];
+is_deeply [ $parser->parse_errors ], $expected,
+ '... and they should be the correct errors';
+
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 3 read the rest of the file
+END_TAP
+
+is $parser->parse_errors, 1, 'Having no plan should cause an error';
+is + ( $parser->parse_errors )[0], 'No plan found in TAP output',
+ '... with a correct error message';
+
+$parser = _parser(<<'END_TAP');
+1..3
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 3 read the rest of the file
+1..3
+END_TAP
+
+is $parser->parse_errors, 1,
+ 'Having more than one plan should cause an error';
+is + ( $parser->parse_errors )[0], 'More than one plan found in TAP output',
+ '... with a correct error message';
+
+can_ok $parser, 'is_good_plan';
+$parser = _parser(<<'END_TAP');
+1..2
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok 3 read the rest of the file
+END_TAP
+
+is $parser->parse_errors, 1,
+ 'Having the wrong number of planned tests is a parse error';
+is + ( $parser->parse_errors )[0],
+ 'Bad plan. You planned 2 tests but ran 3.',
+ '... with a correct error message';
+
+# XXX internals: plan will not set to true if defined
+$parser->is_good_plan(undef);
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+1..1
+END_TAP
+
+ok $parser->is_good_plan,
+ '... and it should return true if the plan is correct';
+
+# TAP::Parser coverage tests
+{
+
+ # good_plan coverage
+
+ my @warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $parser->good_plan;
+ };
+
+ is @warn, 1, 'coverage testing of good_plan';
+
+ like pop @warn,
+ qr/good_plan[(][)] is deprecated. Please use "is_good_plan[(][)]"/,
+ '...and it fell-back like we expected';
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/file.t perl-5.10.0/ext/Test/Harness/t/file.t
--- perl-5.10.0.orig/ext/Test/Harness/t/file.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/file.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,402 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More;
+
+use TAP::Harness;
+
+my $HARNESS = 'TAP::Harness';
+
+my $source_tests
+ = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/source_tests' : 't/source_tests';
+my $sample_tests
+ = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/sample-tests' : 't/sample-tests';
+
+plan tests => 41;
+
+# note that this test will always pass when run through 'prove'
+ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set';
+ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';
+
+{
+ my @output;
+ local $^W;
+ require TAP::Formatter::Base;
+ local *TAP::Formatter::Base::_output = sub {
+ my $self = shift;
+ push @output => grep { $_ ne '' }
+ map {
+ local $_ = $_;
+ chomp;
+ trim($_)
+ } map { split /\n/ } @_;
+ };
+ my $harness = TAP::Harness->new( { verbosity => 1 } );
+ my $harness_whisper = TAP::Harness->new( { verbosity => -1 } );
+ my $harness_mute = TAP::Harness->new( { verbosity => -2 } );
+ my $harness_directives = TAP::Harness->new( { directives => 1 } );
+ my $harness_failures = TAP::Harness->new( { failures => 1 } );
+
+ can_ok $harness, 'runtests';
+
+ # normal tests in verbose mode
+
+ ok my $aggregate = _runtests( $harness, "$source_tests/harness" ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ my @expected = (
+ "$source_tests/harness ..",
+ '1..1',
+ 'ok 1 - this is a test',
+ 'ok',
+ 'All tests successful.',
+ );
+ my $status = pop @output;
+ my $expected_status = qr{^Result: PASS$};
+ my $summary = pop @output;
+ my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # use an alias for test name
+
+ @output = ();
+ ok $aggregate
+ = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ @expected = (
+ 'My Nice Test ..',
+ '1..1',
+ 'ok 1 - this is a test',
+ 'ok',
+ 'All tests successful.',
+ );
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # run same test twice
+
+ @output = ();
+ ok $aggregate = _runtests(
+ $harness, [ "$source_tests/harness", 'My Nice Test' ],
+ [ "$source_tests/harness", 'My Nice Test Again' ]
+ ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ @expected = (
+ 'My Nice Test ........',
+ '1..1',
+ 'ok 1 - this is a test',
+ 'ok',
+ 'My Nice Test Again ..',
+ '1..1',
+ 'ok 1 - this is a test',
+ 'ok',
+ 'All tests successful.',
+ );
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests in quiet mode
+
+ @output = ();
+ _runtests( $harness_whisper, "$source_tests/harness" );
+
+ chomp(@output);
+ @expected = (
+ "$source_tests/harness .. ok",
+ 'All tests successful.',
+ );
+
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests in really_quiet mode
+
+ @output = ();
+ _runtests( $harness_mute, "$source_tests/harness" );
+
+ chomp(@output);
+ @expected = (
+ 'All tests successful.',
+ );
+
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests with failures
+
+ @output = ();
+ _runtests( $harness, "$source_tests/harness_failure" );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ my @summary = @output[ 5 .. $#output ];
+ @output = @output[ 0 .. 4 ];
+
+ @expected = (
+ "$source_tests/harness_failure ..",
+ '1..2',
+ 'ok 1 - this is a test',
+ 'not ok 2 - this is another test',
+ 'Failed 1/2 subtests',
+ );
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ my @expected_summary = (
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ );
+
+ is_deeply \@summary, \@expected_summary,
+ '... and the failure summary should also be correct';
+
+ # quiet tests with failures
+
+ @output = ();
+ _runtests( $harness_whisper, "$source_tests/harness_failure" );
+
+ $status = pop @output;
+ $summary = pop @output;
+ @expected = (
+ "$source_tests/harness_failure ..",
+ 'Failed 1/2 subtests',
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ );
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ # really quiet tests with failures
+
+ @output = ();
+ _runtests( $harness_mute, "$source_tests/harness_failure" );
+
+ $status = pop @output;
+ $summary = pop @output;
+ @expected = (
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ );
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ # only show directives
+
+ @output = ();
+ _runtests(
+ $harness_directives,
+ "$source_tests/harness_directives"
+ );
+
+ chomp(@output);
+
+ @expected = (
+ "$source_tests/harness_directives ..",
+ 'not ok 2 - we have a something # TODO some output',
+ "ok 3 houston, we don't have liftoff # SKIP no funding",
+ 'ok',
+ 'All tests successful.',
+
+ # ~TODO {{{ this should be an option
+ #'Test Summary Report',
+ #'-------------------',
+ #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)",
+ #'Tests skipped:',
+ #'3',
+ # }}}
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+
+ # normal tests with bad tap
+
+ @output = ();
+ _runtests( $harness, "$source_tests/harness_badtap" );
+ chomp(@output);
+
+ @output = map { trim($_) } @output;
+ $status = pop @output;
+ @summary = @output[ 6 .. ( $#output - 1 ) ];
+ @output = @output[ 0 .. 5 ];
+ @expected = (
+ "$source_tests/harness_badtap ..",
+ '1..2',
+ 'ok 1 - this is a test',
+ 'not ok 2 - this is another test',
+ '1..2',
+ 'Failed 1/2 subtests',
+ );
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ @expected_summary = (
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ 'Parse errors: More than one plan found in TAP output',
+ );
+ is_deeply \@summary, \@expected_summary,
+ '... and the badtap summary should also be correct';
+
+ # coverage testing for _should_show_failures
+ # only show failures
+
+ @output = ();
+ _runtests( $harness_failures, "$source_tests/harness_failure" );
+
+ chomp(@output);
+
+ @expected = (
+ "$source_tests/harness_failure ..",
+ 'not ok 2 - this is another test',
+ 'Failed 1/2 subtests',
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
+ is_deeply \@output, \@expected, '... and the output should be correct';
+
+ # check the status output for no tests
+
+ @output = ();
+ _runtests( $harness_failures, "$sample_tests/no_output" );
+
+ chomp(@output);
+
+ @expected = (
+ "$sample_tests/no_output ..",
+ 'No subtests run',
+ 'Test Summary Report',
+ '-------------------',
+ "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)",
+ 'Parse errors: No plan found in TAP output',
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
+ is_deeply \@output, \@expected, '... and the output should be correct';
+
+ #XXXX
+}
+
+sub trim {
+ $_[0] =~ s/^\s+|\s+$//g;
+ return $_[0];
+}
+
+sub _runtests {
+ my ( $harness, @tests ) = @_;
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+ my $aggregate = $harness->runtests(@tests);
+ return $aggregate;
+}
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/glob-to-regexp.t perl-5.10.0/ext/Test/Harness/t/glob-to-regexp.t
--- perl-5.10.0.orig/ext/Test/Harness/t/glob-to-regexp.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/glob-to-regexp.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,44 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More;
+
+require TAP::Parser::Scheduler;
+
+my @tests;
+while (<DATA>) {
+ my ( $glob, $pattern, $name ) = /^(\S+)\t+(\S+)(?:\t+(.*))?$/;
+ die "'$_'" unless $pattern;
+ push @tests, [ $glob, $pattern, $name ];
+}
+
+plan tests => scalar @tests;
+
+foreach (@tests) {
+ my ( $glob, $pattern, $name ) = @$_;
+ is( TAP::Parser::Scheduler->_glob_to_regexp($glob), $pattern,
+ defined $name ? "$glob -- $name" : $glob
+ );
+}
+__DATA__
+Pie Pie
+*.t [^/]*\.t
+**.t .*?\.t
+A?B A[^/]B
+*/*.t [^/]*\/[^/]*\.t
+A,B A\,B , outside {} not special
+{A,B} (?:A|B)
+A{B}C A(?:B)C
+A{B,C}D A(?:B|C)D
+A{B,C,D}E{F,G,H}I,J A(?:B|C|D)E(?:F|G|H)I\,J
+{Perl,Rules} (?:Perl|Rules)
+A}B A\}B Bare } corner case
+A{B,C}D}E A(?:B|C)D\}E
+},A{B,C}D},E \}\,A(?:B|C)D\}\,E
+{A{1,2},D{3,4}} (?:A(?:1|2)|D(?:3|4))
+{A,{B,C},D} (?:A|(?:B|C)|D)
+A{B,C\}D,E\,F}G A(?:B|C\}D|E\,F)G
+A\\B A\\B
+A(B)C A\(B\)C
+1{A(B)C,D|E}2 1(?:A\(B\)C|D\|E)2
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/grammar.t perl-5.10.0/ext/Test/Harness/t/grammar.t
--- perl-5.10.0.orig/ext/Test/Harness/t/grammar.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/grammar.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,461 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::More tests => 94;
+
+use EmptyParser;
+use TAP::Parser::Grammar;
+use TAP::Parser::Iterator::Array;
+
+my $GRAMMAR = 'TAP::Parser::Grammar';
+
+# Array based stream that we can push items in to
+package SS;
+
+sub new {
+ my $class = shift;
+ return bless [], $class;
+}
+
+sub next {
+ my $self = shift;
+ return shift @$self;
+}
+
+sub put {
+ my $self = shift;
+ unshift @$self, @_;
+}
+
+sub handle_unicode { }
+
+package main;
+
+my $stream = SS->new;
+my $parser = EmptyParser->new;
+can_ok $GRAMMAR, 'new';
+my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } );
+isa_ok $grammar, $GRAMMAR, '... and the object it returns';
+
+# Note: all methods are actually class methods. See the docs for the reason
+# why. We'll still use the instance because that should be forward
+# compatible.
+
+my @V12 = sort qw(bailout comment plan simple_test test version);
+my @V13 = sort ( @V12, 'pragma', 'yaml' );
+
+can_ok $grammar, 'token_types';
+ok my @types = sort( $grammar->token_types ),
+ '... and calling it should succeed (v12)';
+is_deeply \@types, \@V12, '... and return the correct token types (v12)';
+
+$grammar->set_version(13);
+ok @types = sort( $grammar->token_types ),
+ '... and calling it should succeed (v13)';
+is_deeply \@types, \@V13, '... and return the correct token types (v13)';
+
+can_ok $grammar, 'syntax_for';
+can_ok $grammar, 'handler_for';
+
+my ( %syntax_for, %handler_for );
+foreach my $type (@types) {
+ ok $syntax_for{$type} = $grammar->syntax_for($type),
+ '... and calling syntax_for() with a type name should succeed';
+ cmp_ok ref $syntax_for{$type}, 'eq', 'Regexp',
+ '... and it should return a regex';
+
+ ok $handler_for{$type} = $grammar->handler_for($type),
+ '... and calling handler_for() with a type name should succeed';
+ cmp_ok ref $handler_for{$type}, 'eq', 'CODE',
+ '... and it should return a code reference';
+}
+
+# Test the plan. Gotta have a plan.
+my $plan = '1..1';
+like $plan, $syntax_for{'plan'}, 'A basic plan should match its syntax';
+
+my $method = $handler_for{'plan'};
+$plan =~ $syntax_for{'plan'};
+ok my $plan_token = $grammar->$method($plan),
+ '... and the handler should return a token';
+
+my $expected = {
+ 'explanation' => '',
+ 'directive' => '',
+ 'type' => 'plan',
+ 'tests_planned' => 1,
+ 'raw' => '1..1',
+ 'todo_list' => [],
+};
+is_deeply $plan_token, $expected,
+ '... and it should contain the correct data';
+
+can_ok $grammar, 'tokenize';
+$stream->put($plan);
+ok my $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# a plan with a skip directive
+
+$plan = '1..0 # SKIP why not?';
+like $plan, $syntax_for{'plan'}, 'a basic plan should match its syntax';
+
+$plan =~ $syntax_for{'plan'};
+ok $plan_token = $grammar->$method($plan),
+ '... and the handler should return a token';
+
+$expected = {
+ 'explanation' => 'why not?',
+ 'directive' => 'SKIP',
+ 'type' => 'plan',
+ 'tests_planned' => 0,
+ 'raw' => '1..0 # SKIP why not?',
+ 'todo_list' => [],
+};
+is_deeply $plan_token, $expected,
+ '... and it should contain the correct data';
+
+$stream->put($plan);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# implied skip
+
+$plan = '1..0';
+like $plan, $syntax_for{'plan'},
+ 'A plan with an implied "skip all" should match its syntax';
+
+$plan =~ $syntax_for{'plan'};
+ok $plan_token = $grammar->$method($plan),
+ '... and the handler should return a token';
+
+$expected = {
+ 'explanation' => '',
+ 'directive' => 'SKIP',
+ 'type' => 'plan',
+ 'tests_planned' => 0,
+ 'raw' => '1..0',
+ 'todo_list' => [],
+};
+is_deeply $plan_token, $expected,
+ '... and it should contain the correct data';
+
+$stream->put($plan);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# bad plan
+
+$plan = '1..0 # TODO 3,4,5'; # old syntax. No longer supported
+unlike $plan, $syntax_for{'plan'},
+ 'Bad plans should not match the plan syntax';
+
+# Bail out!
+
+my $bailout = 'Bail out!';
+like $bailout, $syntax_for{'bailout'},
+ 'Bail out! should match a bailout syntax';
+
+$stream->put($bailout);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+$expected = {
+ 'bailout' => '',
+ 'type' => 'bailout',
+ 'raw' => 'Bail out!'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+$bailout = 'Bail out! some explanation';
+like $bailout, $syntax_for{'bailout'},
+ 'Bail out! should match a bailout syntax';
+
+$stream->put($bailout);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+$expected = {
+ 'bailout' => 'some explanation',
+ 'type' => 'bailout',
+ 'raw' => 'Bail out! some explanation'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# test comment
+
+my $comment = '# this is a comment';
+like $comment, $syntax_for{'comment'},
+ 'Comments should match the comment syntax';
+
+$stream->put($comment);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+$expected = {
+ 'comment' => 'this is a comment',
+ 'type' => 'comment',
+ 'raw' => '# this is a comment'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# test tests :/
+
+my $test = 'ok 1 this is a test';
+like $test, $syntax_for{'test'}, 'Tests should match the test syntax';
+
+$stream->put($test);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'ok' => 'ok',
+ 'explanation' => '',
+ 'type' => 'test',
+ 'directive' => '',
+ 'description' => 'this is a test',
+ 'test_num' => '1',
+ 'raw' => 'ok 1 this is a test'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# TODO tests
+
+$test = 'not ok 2 this is a test # TODO whee!';
+like $test, $syntax_for{'test'}, 'Tests should match the test syntax';
+
+$stream->put($test);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'ok' => 'not ok',
+ 'explanation' => 'whee!',
+ 'type' => 'test',
+ 'directive' => 'TODO',
+ 'description' => 'this is a test',
+ 'test_num' => '2',
+ 'raw' => 'not ok 2 this is a test # TODO whee!'
+};
+is_deeply $token, $expected, '... and the TODO should be parsed';
+
+# false TODO tests
+
+# escaping that hash mark ('#') means this should *not* be a TODO test
+$test = 'ok 22 this is a test \# TODO whee!';
+like $test, $syntax_for{'test'}, 'Tests should match the test syntax';
+
+$stream->put($test);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'ok' => 'ok',
+ 'explanation' => '',
+ 'type' => 'test',
+ 'directive' => '',
+ 'description' => 'this is a test \# TODO whee!',
+ 'test_num' => '22',
+ 'raw' => 'ok 22 this is a test \# TODO whee!'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# pragmas
+
+my $pragma = 'pragma +strict';
+like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax';
+
+$stream->put($pragma);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'type' => 'pragma',
+ 'raw' => $pragma,
+ 'pragmas' => ['+strict'],
+};
+
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+$pragma = 'pragma +strict,-foo';
+like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax';
+
+$stream->put($pragma);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'type' => 'pragma',
+ 'raw' => $pragma,
+ 'pragmas' => [ '+strict', '-foo' ],
+};
+
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+$pragma = 'pragma +strict , -foo ';
+like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax';
+
+$stream->put($pragma);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'type' => 'pragma',
+ 'raw' => $pragma,
+ 'pragmas' => [ '+strict', '-foo' ],
+};
+
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# coverage tests
+
+# set_version
+
+{
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $grammar->set_version('no_such_version');
+ };
+
+ unless ( is @die, 1, 'set_version with bad version' ) {
+ diag " >>> $_ <<<\n" for @die;
+ }
+
+ like pop @die, qr/^Unsupported syntax version: no_such_version at /,
+ '... and got expected message';
+}
+
+# tokenize
+{
+ my $stream = SS->new;
+ my $parser = EmptyParser->new;
+ my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } );
+
+ my $plan = '';
+
+ $stream->put($plan);
+
+ my $result = $grammar->tokenize();
+
+ isa_ok $result, 'TAP::Parser::Result::Unknown';
+}
+
+# _make_plan_token
+
+{
+ my $parser = EmptyParser->new;
+ my $grammar = $GRAMMAR->new( { parser => $parser } );
+
+ my $plan
+ = '1..1 # SKIP with explanation'; # trigger warning in _make_plan_token
+
+ my $method = $handler_for{'plan'};
+
+ $plan =~ $syntax_for{'plan'}; # perform regex to populate $1, $2
+
+ my @warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $grammar->$method($plan);
+ };
+
+ is @warn, 1, 'catch warning on inconsistent plan';
+
+ like pop @warn,
+ qr/^Specified SKIP directive in plan but more than 0 tests [(]1\.\.1 # SKIP with explanation[)]/,
+ '... and its what we expect';
+}
+
+# _make_yaml_token
+
+{
+ my $stream = SS->new;
+ my $parser = EmptyParser->new;
+ my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } );
+
+ $grammar->set_version(13);
+
+ # now this is badly formed YAML that is missing the
+ # leader padding - this is done for coverage testing
+ # the $reader code sub in _make_yaml_token, that is
+ # passed as the yaml consumer to T::P::YAMLish::Reader.
+
+ # because it isnt valid yaml, the yaml document is
+ # not done, and the _peek in the YAMLish::Reader
+ # code doesnt find the terminating '...' pattern.
+ # but we dont care as this is coverage testing, so
+ # if thats what we have to do to exercise that code,
+ # so be it.
+ my $yaml = [ ' ... ', '- 2', ' --- ', ];
+
+ sub iter {
+ my $ar = shift;
+ return sub {
+ return shift @$ar;
+ };
+ }
+
+ my $iter = iter($yaml);
+
+ while ( my $line = $iter->() ) {
+ $stream->put($line);
+ }
+
+ # pad == ' ', marker == '--- '
+ # length $pad == 3
+ # strip == pad
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+ $grammar->tokenize;
+ };
+
+ is @die, 1, 'checking badly formed yaml for coverage testing';
+
+ like pop @die, qr/^Missing '[.][.][.]' at end of YAMLish/,
+ '...and it died like we expect';
+}
+
+{
+
+ # coverage testing for TAP::Parser::Iterator::Array
+
+ my $source = [qw( a b c )];
+
+ my $aiter = TAP::Parser::Iterator::Array->new($source);
+
+ my $first = $aiter->next_raw;
+
+ is $first, 'a', 'access raw iterator';
+
+ is $aiter->exit, undef, '... and note we didnt exhaust the source';
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/harness-bailout.t perl-5.10.0/ext/Test/Harness/t/harness-bailout.t
--- perl-5.10.0.orig/ext/Test/Harness/t/harness-bailout.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/harness-bailout.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,61 @@
+#!perl
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ chdir '../ext/Test/Harness';
+ #@INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ @INC = ( '../../../lib', 't/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use File::Spec;
+
+BEGIN {
+ *CORE::GLOBAL::exit = sub { die '!exit called!' };
+}
+
+use TAP::Harness;
+use Test::More;
+
+my @jobs = (
+ { name => 'sequential',
+ args => { verbosity => -9 },
+ },
+ { name => 'parallel',
+ args => { verbosity => -9, jobs => 2 },
+ },
+);
+
+plan tests => @jobs * 2;
+
+for my $test (@jobs) {
+ my $name = $test->{name};
+ my $args = $test->{args};
+ my $harness = TAP::Harness->new($args);
+ eval {
+ local ( *OLDERR, *OLDOUT );
+ open OLDERR, '>&STDERR' or die $!;
+ open OLDOUT, '>&STDOUT' or die $!;
+ my $devnull = File::Spec->devnull;
+ open STDERR, ">$devnull" or die $!;
+ open STDOUT, ">$devnull" or die $!;
+
+ $harness->runtests(
+ File::Spec->catfile( 't', 'sample-tests', 'bailout' ) );
+
+ open STDERR, '>&OLDERR' or die $!;
+ open STDOUT, '>&OLDOUT' or die $!;
+ };
+ my $err = $@;
+ unlike $err, qr{!exit called!}, "$name: didn't exit";
+ like $err, qr{FAILED--Further testing stopped: GERONIMMMOOOOOO!!!},
+ "$name: bailout message";
+}
+
+# vim:ts=2:sw=2:et:ft=perl
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/harness-subclass.t perl-5.10.0/ext/Test/Harness/t/harness-subclass.t
--- perl-5.10.0.orig/ext/Test/Harness/t/harness-subclass.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/harness-subclass.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,75 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use TAP::Harness;
+use Test::More tests => 13;
+
+my %class_map = (
+ aggregator_class => 'My::TAP::Parser::Aggregator',
+ formatter_class => 'My::TAP::Formatter::Console',
+ multiplexer_class => 'My::TAP::Parser::Multiplexer',
+ parser_class => 'My::TAP::Parser',
+ scheduler_class => 'My::TAP::Parser::Scheduler',
+);
+
+my %loaded = ();
+
+# Synthesize our subclasses
+for my $class ( values %class_map ) {
+ ( my $base_class = $class ) =~ s/^My:://;
+ use_ok($base_class);
+
+ no strict 'refs';
+ @{"${class}::ISA"} = ($base_class);
+ *{"${class}::new"} = sub {
+ my $pkg = shift;
+ $loaded{$pkg} = 1;
+
+ # Can't use SUPER outside a package
+ return $base_class->can('new')->( $pkg, @_ );
+ };
+}
+
+{
+ ok my $harness = TAP::Harness->new( { %class_map, verbosity => -9 } ),
+ 'created harness';
+ isa_ok $harness, 'TAP::Harness';
+
+ # Test dynamic loading
+ ok !$INC{'NOP.pm'}, 'NOP not loaded';
+ ok my $nop = $harness->_construct('NOP'), 'loaded and created';
+ isa_ok $nop, 'NOP';
+ ok $INC{'NOP.pm'}, 'NOP loaded';
+
+ my $aggregate = $harness->runtests(
+ File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir, 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'simple'
+ )
+ );
+
+ isa_ok $aggregate, 'My::TAP::Parser::Aggregator';
+
+ is_deeply \%loaded,
+ { 'My::TAP::Parser::Aggregator' => 1,
+ 'My::TAP::Formatter::Console' => 1,
+ 'My::TAP::Parser' => 1,
+ 'My::TAP::Parser::Scheduler' => 1,
+ },
+ 'loaded our classes';
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/harness.t perl-5.10.0/ext/Test/Harness/t/harness.t
--- perl-5.10.0.orig/ext/Test/Harness/t/harness.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/harness.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,904 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More;
+use IO::c55Capture;
+
+use TAP::Harness;
+
+my $HARNESS = 'TAP::Harness';
+
+my $source_tests
+ = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/source_tests' : 't/source_tests';
+my $sample_tests
+ = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/sample-tests' : 't/sample-tests';
+
+plan tests => 113;
+
+# note that this test will always pass when run through 'prove'
+ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set';
+ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';
+
+#### For color tests ####
+
+package Colorizer;
+
+sub new { bless {}, shift }
+sub can_color {1}
+
+sub set_color {
+ my ( $self, $output, $color ) = @_;
+ $output->("[[$color]]");
+}
+
+package main;
+
+sub colorize {
+ my $harness = shift;
+ $harness->formatter->_colorizer( Colorizer->new );
+}
+
+can_ok $HARNESS, 'new';
+
+eval { $HARNESS->new( { no_such_key => 1 } ) };
+like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/,
+ '... and calling it with bad keys should fail';
+
+eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) };
+is $@, '', '... and calling it with a non-existent lib is fine';
+
+eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) };
+is $@, '', '... and calling it with non-existent libs is fine';
+
+ok my $harness = $HARNESS->new,
+ 'Calling new() without arguments should succeed';
+
+foreach my $test_args ( get_arg_sets() ) {
+ my %args = %$test_args;
+ foreach my $key ( sort keys %args ) {
+ $args{$key} = $args{$key}{in};
+ }
+ ok my $harness = $HARNESS->new( {%args} ),
+ 'Calling new() with valid arguments should succeed';
+ isa_ok $harness, $HARNESS, '... and the object it returns';
+
+ while ( my ( $property, $test ) = each %$test_args ) {
+ my $value = $test->{out};
+ can_ok $harness, $property;
+ is_deeply scalar $harness->$property(), $value, $test->{test_name};
+ }
+}
+
+{
+ my @output;
+ local $^W;
+ local *TAP::Formatter::Base::_output = sub {
+ my $self = shift;
+ push @output => grep { $_ ne '' }
+ map {
+ local $_ = $_;
+ chomp;
+ trim($_)
+ } @_;
+ };
+ my $harness = TAP::Harness->new(
+ { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
+ my $harness_whisper = TAP::Harness->new(
+ { verbosity => -1, formatter_class => "TAP::Formatter::Console" } );
+ my $harness_mute = TAP::Harness->new(
+ { verbosity => -2, formatter_class => "TAP::Formatter::Console" } );
+ my $harness_directives = TAP::Harness->new(
+ { directives => 1, formatter_class => "TAP::Formatter::Console" } );
+ my $harness_failures = TAP::Harness->new(
+ { failures => 1, formatter_class => "TAP::Formatter::Console" } );
+
+ colorize($harness);
+
+ can_ok $harness, 'runtests';
+
+ # normal tests in verbose mode
+
+ ok my $aggregate = _runtests( $harness, "$source_tests/harness" ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ my @expected = (
+ "$source_tests/harness ..",
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'All tests successful.',
+ );
+ my $status = pop @output;
+ my $expected_status = qr{^Result: PASS$};
+ my $summary = pop @output;
+ my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # use an alias for test name
+
+ @output = ();
+ ok $aggregate
+ = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ @expected = (
+ 'My Nice Test ..',
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'All tests successful.',
+ );
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # run same test twice
+
+ @output = ();
+ ok $aggregate = _runtests(
+ $harness, [ "$source_tests/harness", 'My Nice Test' ],
+ [ "$source_tests/harness", 'My Nice Test Again' ]
+ ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ @expected = (
+ 'My Nice Test ........',
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'My Nice Test Again ..',
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'All tests successful.',
+ );
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests in quiet mode
+
+ @output = ();
+ _runtests( $harness_whisper, "$source_tests/harness" );
+
+ chomp(@output);
+ @expected = (
+ "$source_tests/harness ..",
+ 'ok',
+ 'All tests successful.',
+ );
+
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests in really_quiet mode
+
+ @output = ();
+ _runtests( $harness_mute, "$source_tests/harness" );
+
+ chomp(@output);
+ @expected = (
+ 'All tests successful.',
+ );
+
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests with failures
+
+ @output = ();
+ _runtests( $harness, "$source_tests/harness_failure" );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ my @summary = @output[ 10 .. $#output ];
+ @output = @output[ 0 .. 9 ];
+
+ @expected = (
+ "$source_tests/harness_failure ..",
+ '1..2',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ '[[red]]',
+ 'not ok 2 - this is another test',
+ '[[reset]]',
+ '[[red]]',
+ 'Failed 1/2 subtests',
+ );
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ my @expected_summary = (
+ '[[reset]]',
+ 'Test Summary Report',
+ '-------------------',
+ '[[red]]',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ '[[reset]]',
+ '[[red]]',
+ 'Failed test:',
+ '[[reset]]',
+ '[[red]]',
+ '2',
+ '[[reset]]',
+ );
+
+ is_deeply \@summary, \@expected_summary,
+ '... and the failure summary should also be correct';
+
+ # quiet tests with failures
+
+ @output = ();
+ _runtests( $harness_whisper, "$source_tests/harness_failure" );
+
+ $status = pop @output;
+ $summary = pop @output;
+ @expected = (
+ "$source_tests/harness_failure ..",
+ 'Failed 1/2 subtests',
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ );
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ # really quiet tests with failures
+
+ @output = ();
+ _runtests( $harness_mute, "$source_tests/harness_failure" );
+
+ $status = pop @output;
+ $summary = pop @output;
+ @expected = (
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ );
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ # only show directives
+
+ @output = ();
+ _runtests(
+ $harness_directives,
+ "$source_tests/harness_directives"
+ );
+
+ chomp(@output);
+
+ @expected = (
+ "$source_tests/harness_directives ..",
+ 'not ok 2 - we have a something # TODO some output',
+ "ok 3 houston, we don't have liftoff # SKIP no funding",
+ 'ok',
+ 'All tests successful.',
+
+ # ~TODO {{{ this should be an option
+ #'Test Summary Report',
+ #'-------------------',
+ #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)",
+ #'Tests skipped:',
+ #'3',
+ # }}}
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+
+ # normal tests with bad tap
+
+ # install callback handler
+ my $parser;
+ my $callback_count = 0;
+
+ my @callback_log = ();
+
+ for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
+ $harness->callback(
+ $evt => sub {
+ push @callback_log, $evt;
+ }
+ );
+ }
+
+ $harness->callback(
+ made_parser => sub {
+ $parser = shift;
+ $callback_count++;
+ }
+ );
+
+ @output = ();
+ _runtests( $harness, "$source_tests/harness_badtap" );
+ chomp(@output);
+
+ @output = map { trim($_) } @output;
+ $status = pop @output;
+ @summary = @output[ 12 .. ( $#output - 1 ) ];
+ @output = @output[ 0 .. 11 ];
+ @expected = (
+ "$source_tests/harness_badtap ..",
+ '1..2',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ '[[red]]',
+ 'not ok 2 - this is another test',
+ '[[reset]]',
+ '1..2',
+ '[[reset]]',
+ '[[red]]',
+ 'Failed 1/2 subtests',
+ );
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ @expected_summary = (
+ '[[reset]]',
+ 'Test Summary Report',
+ '-------------------',
+ '[[red]]',
+ "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)",
+ '[[reset]]',
+ '[[red]]',
+ 'Failed test:',
+ '[[reset]]',
+ '[[red]]',
+ '2',
+ '[[reset]]',
+ '[[red]]',
+ 'Parse errors: More than one plan found in TAP output',
+ '[[reset]]',
+ );
+ is_deeply \@summary, \@expected_summary,
+ '... and the badtap summary should also be correct';
+
+ cmp_ok( $callback_count, '==', 1, 'callback called once' );
+ is_deeply(
+ \@callback_log,
+ [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
+ 'callback log matches'
+ );
+ isa_ok $parser, 'TAP::Parser';
+
+ # coverage testing for _should_show_failures
+ # only show failures
+
+ @output = ();
+ _runtests( $harness_failures, "$source_tests/harness_failure" );
+
+ chomp(@output);
+
+ @expected = (
+ "$source_tests/harness_failure ..",
+ 'not ok 2 - this is another test',
+ 'Failed 1/2 subtests',
+ 'Test Summary Report',
+ '-------------------',
+ "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
+ 'Failed test:',
+ '2',
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
+ is_deeply \@output, \@expected, '... and the output should be correct';
+
+ # check the status output for no tests
+
+ @output = ();
+ _runtests( $harness_failures, "$sample_tests/no_output" );
+
+ chomp(@output);
+
+ @expected = (
+ "$sample_tests/no_output ..",
+ 'No subtests run',
+ 'Test Summary Report',
+ '-------------------',
+ "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)",
+ 'Parse errors: No plan found in TAP output',
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
+ is_deeply \@output, \@expected, '... and the output should be correct';
+
+ #XXXX
+}
+
+# make sure we can exec something ... anything!
+SKIP: {
+
+ my $cat = '/bin/cat';
+ unless ( -e $cat ) {
+ skip "no '$cat'", 2;
+ }
+
+ my $capture = IO::c55Capture->new_handle;
+ my $harness = TAP::Harness->new(
+ { verbosity => -2,
+ stdout => $capture,
+ exec => [$cat],
+ }
+ );
+
+ eval {
+ _runtests(
+ $harness,
+ $ENV{PERL_CORE}
+ ? '../ext/Test/Harness/t/data/catme.1'
+ : 't/data/catme.1'
+ );
+ };
+
+ my @output = tied($$capture)->dump;
+ my $status = pop @output;
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+ pop @output; # get rid of summary line
+ my $answer = pop @output;
+ is( $answer, "All tests successful.\n", 'cat meows' );
+}
+
+# make sure that we can exec with a code ref.
+{
+ my $capture = IO::c55Capture->new_handle;
+ my $harness = TAP::Harness->new(
+ { verbosity => -2,
+ stdout => $capture,
+ exec => sub {undef},
+ }
+ );
+
+ _runtests( $harness, "$source_tests/harness" );
+
+ my @output = tied($$capture)->dump;
+ my $status = pop @output;
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+ pop @output; # get rid of summary line
+ my $answer = pop @output;
+ is( $answer, "All tests successful.\n", 'cat meows' );
+}
+
+# catches "exec accumulates arguments" issue (r77)
+{
+ my $capture = IO::c55Capture->new_handle;
+ my $harness = TAP::Harness->new(
+ { verbosity => -2,
+ stdout => $capture,
+ exec => [$^X]
+ }
+ );
+
+ _runtests(
+ $harness,
+ "$source_tests/harness_complain"
+ , # will get mad if run with args
+ "$source_tests/harness",
+ );
+
+ my @output = tied($$capture)->dump;
+ my $status = pop @output;
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+ pop @output; # get rid of summary line
+ is( $output[-1], "All tests successful.\n",
+ 'No exec accumulation'
+ );
+}
+
+sub trim {
+ $_[0] =~ s/^\s+|\s+$//g;
+ return $_[0];
+}
+
+sub liblist {
+ return [ map {"-I$_"} @_ ];
+}
+
+sub get_arg_sets {
+
+ # keys are keys to new()
+ return {
+ lib => {
+ in => 'lib',
+ out => liblist('lib'),
+ test_name => '... a single lib switch should be correct'
+ },
+ verbosity => {
+ in => 1,
+ out => 1,
+ test_name => '... and we should be able to set verbosity to 1'
+ },
+
+ # verbose => {
+ # in => 1,
+ # out => 1,
+ # test_name => '... and we should be able to set verbose to true'
+ # },
+ },
+ { lib => {
+ in => [ 'lib', 't' ],
+ out => liblist( 'lib', 't' ),
+ test_name => '... multiple lib dirs should be correct'
+ },
+ verbosity => {
+ in => 0,
+ out => 0,
+ test_name => '... and we should be able to set verbosity to 0'
+ },
+
+ # verbose => {
+ # in => 0,
+ # out => 0,
+ # test_name => '... and we should be able to set verbose to false'
+ # },
+ },
+ { switches => {
+ in => [ '-T', '-w', '-T' ],
+ out => [ '-T', '-w', '-T' ],
+ test_name => '... duplicate switches should remain',
+ },
+ failures => {
+ in => 1,
+ out => 1,
+ test_name =>
+ '... and we should be able to set failures to true',
+ },
+ verbosity => {
+ in => -1,
+ out => -1,
+ test_name => '... and we should be able to set verbosity to -1'
+ },
+
+ # quiet => {
+ # in => 1,
+ # out => 1,
+ # test_name => '... and we should be able to set quiet to false'
+ # },
+ },
+
+ { verbosity => {
+ in => -2,
+ out => -2,
+ test_name => '... and we should be able to set verbosity to -2'
+ },
+
+ # really_quiet => {
+ # in => 1,
+ # out => 1,
+ # test_name =>
+ # '... and we should be able to set really_quiet to true',
+ # },
+ exec => {
+ in => $^X,
+ out => $^X,
+ test_name =>
+ '... and we should be able to set the executable',
+ },
+ },
+ { switches => {
+ in => 'T',
+ out => ['T'],
+ test_name =>
+ '... leading dashes (-) on switches are not optional',
+ },
+ },
+ { switches => {
+ in => '-T',
+ out => ['-T'],
+ test_name => '... we should be able to set switches',
+ },
+ failures => {
+ in => 1,
+ out => 1,
+ test_name => '... and we should be able to set failures to true'
+ },
+ };
+}
+
+sub _runtests {
+ my ( $harness, @tests ) = @_;
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+ my $aggregate = $harness->runtests(@tests);
+ return $aggregate;
+}
+
+{
+
+ # coverage tests for ctor
+
+ my $harness = TAP::Harness->new(
+ { timer => 0,
+ errors => 1,
+ merge => 2,
+
+ # formatter => 3,
+ }
+ );
+
+ is $harness->timer(), 0, 'timer getter';
+ is $harness->timer(10), 10, 'timer setter';
+ is $harness->errors(), 1, 'errors getter';
+ is $harness->errors(10), 10, 'errors setter';
+ is $harness->merge(), 2, 'merge getter';
+ is $harness->merge(10), 10, 'merge setter';
+
+ # jobs accessor
+ is $harness->jobs(), 1, 'jobs';
+}
+
+{
+
+# coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor
+
+ # the coverage tests are
+ # 1. ref $ref => false
+ # 2. ref => ! GLOB and ref->can(print)
+ # 3. ref $ref => GLOB
+
+ # case 1
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ my $harness = TAP::Harness->new(
+ { stdout => bless {}, '0', # how evil is THAT !!!
+ }
+ );
+ };
+
+ is @die, 1, 'bad filehandle to stdout';
+ like pop @die, qr/option 'stdout' needs a filehandle/,
+ '... and we died as expected';
+
+ # case 2
+
+ @die = ();
+
+ package Printable;
+
+ sub new { return bless {}, shift }
+
+ sub print {return}
+
+ package main;
+
+ my $harness = TAP::Harness->new(
+ { stdout => Printable->new(),
+ }
+ );
+
+ isa_ok $harness, 'TAP::Harness';
+
+ # case 3
+
+ @die = ();
+
+ $harness = TAP::Harness->new(
+ { stdout => bless {}, 'GLOB', # again with the evil
+ }
+ );
+
+ isa_ok $harness, 'TAP::Harness';
+}
+
+{
+
+ # coverage testing of lib/switches accessor
+ my $harness = TAP::Harness->new;
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $harness->switches(qw( too many arguments));
+ };
+
+ is @die, 1, 'too many arguments to accessor';
+
+ like pop @die, qr/Too many arguments to method 'switches'/,
+ '...and we died as expected';
+
+ $harness->switches('simple scalar');
+
+ my $arrref = $harness->switches;
+ is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref';
+}
+
+{
+
+ # coverage tests for the basically untested T::H::_open_spool
+
+ my @spool = (
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ ( 't', 'spool' )
+ );
+ $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
+
+# now given that we're going to be writing stuff to the file system, make sure we have
+# a cleanup hook
+
+ END {
+ use File::Path;
+
+ # remove the tree if we made it this far
+ rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
+ if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
+ }
+
+ my $harness = TAP::Harness->new( { verbosity => -2 } );
+
+ can_ok $harness, 'runtests';
+
+ # normal tests in verbose mode
+
+ my $parser
+ = $harness->runtests( File::Spec->catfile( $source_tests, 'harness' ) );
+
+ isa_ok $parser, 'TAP::Parser::Aggregator',
+ '... runtests returns the aggregate';
+
+ ok -e File::Spec->catfile(
+ $ENV{PERL_TEST_HARNESS_DUMP_TAP},
+ $source_tests, 'harness'
+ );
+}
+
+{
+
+ # test name munging
+ my @cases = (
+ { name => 'all the same',
+ input => [ 'foo.t', 'bar.t', 'fletz.t' ],
+ output => [
+ [ 'foo.t', 'foo.t' ], [ 'bar.t', 'bar.t' ],
+ [ 'fletz.t', 'fletz.t' ]
+ ],
+ },
+ { name => 'all the same, already cooked',
+ input => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ],
+ output => [
+ [ 'foo.t', 'foo.t' ], [ 'bar.t', 'brip' ],
+ [ 'fletz.t', 'fletz.t' ]
+ ],
+ },
+ { name => 'different exts',
+ input => [ 'foo.t', 'bar.u', 'fletz.v' ],
+ output => [
+ [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bar.u' ],
+ [ 'fletz.v', 'fletz.v' ]
+ ],
+ },
+ { name => 'different exts, one already cooked',
+ input => [ 'foo.t', [ 'bar.u', 'bam' ], 'fletz.v' ],
+ output => [
+ [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam' ],
+ [ 'fletz.v', 'fletz.v' ]
+ ],
+ },
+ { name => 'different exts, two already cooked',
+ input => [ 'foo.t', [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ],
+ output => [
+ [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam.q' ],
+ [ 'fletz.v', 'boo' ]
+ ],
+ },
+ );
+
+ for my $case (@cases) {
+ is_deeply [ TAP::Harness->_add_descriptions( @{ $case->{input} } ) ],
+ $case->{output}, '_add_descriptions: ' . $case->{name};
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/iterators.t perl-5.10.0/ext/Test/Harness/t/iterators.t
--- perl-5.10.0.orig/ext/Test/Harness/t/iterators.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/iterators.t 2009-03-10 17:38:43.000000000 +0100
@@ -0,0 +1,219 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 76;
+
+use File::Spec;
+use TAP::Parser;
+use TAP::Parser::IteratorFactory;
+use Config;
+
+sub array_ref_from {
+ my $string = shift;
+ my @lines = split /\n/ => $string;
+ return \@lines;
+}
+
+# we slurp __DATA__ and then reset it so we don't have to duplicate our TAP
+my $offset = tell DATA;
+my $tap = do { local $/; <DATA> };
+seek DATA, $offset, 0;
+
+my $did_setup = 0;
+my $did_teardown = 0;
+
+my $setup = sub { $did_setup++ };
+my $teardown = sub { $did_teardown++ };
+
+package NoForkProcess;
+use vars qw( @ISA );
+@ISA = qw( TAP::Parser::Iterator::Process );
+
+sub _use_open3 {return}
+
+package main;
+
+my @schedule = (
+ { name => 'Process',
+ subclass => 'TAP::Parser::Iterator::Process',
+ source => {
+ command => [
+ $^X,
+ File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'out_err_mix'
+ )
+ ],
+ merge => 1,
+ setup => $setup,
+ teardown => $teardown,
+ },
+ after => sub {
+ is $did_setup, 1, "setup called";
+ is $did_teardown, 1, "teardown called";
+ },
+ need_open3 => 15,
+ },
+ { name => 'Array',
+ subclass => 'TAP::Parser::Iterator::Array',
+ source => array_ref_from($tap),
+ },
+ { name => 'Stream',
+ subclass => 'TAP::Parser::Iterator::Stream',
+ source => \*DATA,
+ },
+ { name => 'Process (Perl -e)',
+ subclass => 'TAP::Parser::Iterator::Process',
+ source =>
+ { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] },
+ },
+ { name => 'Process (NoFork)',
+ subclass => 'TAP::Parser::Iterator::Process',
+ class => 'NoForkProcess',
+ source =>
+ { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] },
+ },
+);
+
+sub _can_open3 {
+ return $Config{d_fork};
+}
+
+my $factory = TAP::Parser::IteratorFactory->new;
+for my $test (@schedule) {
+ SKIP: {
+ my $name = $test->{name};
+ my $need_open3 = $test->{need_open3};
+ skip "No open3", $need_open3 if $need_open3 && !_can_open3();
+ my $subclass = $test->{subclass};
+ my $source = $test->{source};
+ my $class = $test->{class};
+ my $iter
+ = $class
+ ? $class->new($source)
+ : $factory->make_iterator($source);
+ ok $iter, "$name: We should be able to create a new iterator";
+ isa_ok $iter, 'TAP::Parser::Iterator',
+ '... and the object it returns';
+ isa_ok $iter, $subclass, '... and the object it returns';
+
+ can_ok $iter, 'exit';
+ ok !defined $iter->exit,
+ "$name: ... and it should be undef before we are done ($subclass)";
+
+ can_ok $iter, 'next';
+ is $iter->next, 'one', "$name: next() should return the first result";
+
+ is $iter->next, 'two',
+ "$name: next() should return the second result";
+
+ is $iter->next, '', "$name: next() should return the third result";
+
+ is $iter->next, 'three',
+ "$name: next() should return the fourth result";
+
+ ok !defined $iter->next,
+ "$name: next() should return undef after it is empty";
+
+ is $iter->exit, 0,
+ "$name: ... and exit should now return 0 ($subclass)";
+
+ is $iter->wait, 0, "$name: wait should also now return 0 ($subclass)";
+
+ if ( my $after = $test->{after} ) {
+ $after->();
+ }
+ }
+}
+
+{
+
+ # coverage tests for the ctor
+
+ my $stream = $factory->make_iterator( IO::Handle->new );
+
+ isa_ok $stream, 'TAP::Parser::Iterator::Stream';
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $factory->make_iterator( \1 ); # a ref to a scalar
+ };
+
+ is @die, 1, 'coverage of error case';
+
+ like pop @die, qr/Can't iterate with a SCALAR/,
+ '...and we died as expected';
+}
+
+{
+
+ # coverage test for VMS case
+
+ my $stream = $factory->make_iterator(
+ [ 'not ',
+ 'ok 1 - I hate VMS',
+ ]
+ );
+
+ is $stream->next, 'not ok 1 - I hate VMS',
+ 'coverage of VMS line-splitting case';
+
+ # coverage test for VMS case - nothing after 'not'
+
+ $stream = $factory->make_iterator(
+ [ 'not ',
+ ]
+ );
+
+ is $stream->next, 'not ', '...and we find "not" by itself';
+}
+
+SKIP: {
+ skip "No open3", 4 unless _can_open3();
+
+ # coverage testing for TAP::Parser::Iterator::Process ctor
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $factory->make_iterator( {} );
+ };
+
+ is @die, 1, 'coverage testing for TPI::Process';
+
+ like pop @die, qr/Must supply a command to execute/,
+ '...and we died as expected';
+
+ my $parser = $factory->make_iterator(
+ { command => [
+ $^X,
+ File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' )
+ ],
+ merge => 1,
+ }
+ );
+
+ is $parser->{err}, '', 'confirm we set err to empty string';
+ is $parser->{sel}, undef, '...and selector to undef';
+
+ # And then we read from the parser to sidestep the Mac OS / open3
+ # bug which frequently throws an error here otherwise.
+ $parser->next;
+}
+__DATA__
+one
+two
+
+three
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy.pm perl-5.10.0/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+package App::Prove::Plugin::Dummy;
+
+use strict;
+
+sub import {
+ main::test_log_import(@_);
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy2.pm perl-5.10.0/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy2.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy2.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/App/Prove/Plugin/Dummy2.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,13 @@
+package App::Prove::Plugin::Dummy2;
+
+use strict;
+
+sub import {
+ main::test_log_import(@_);
+}
+
+sub load {
+ main::test_log_plugin_load(@_);
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/Dev/Null.pm perl-5.10.0/ext/Test/Harness/t/lib/Dev/Null.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/Dev/Null.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/Dev/Null.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,18 @@
+# For shutting up Test::Harness.
+# Has to work on 5.004 which doesn't have Tie::StdHandle.
+package Dev::Null;
+
+sub WRITE { }
+sub PRINT { }
+sub PRINTF { }
+
+sub TIEHANDLE {
+ my $class = shift;
+ my $fh = do { local *HANDLE; \*HANDLE };
+ return bless $fh, $class;
+}
+sub READ { }
+sub READLINE { }
+sub GETC { }
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/EmptyParser.pm perl-5.10.0/ext/Test/Harness/t/lib/EmptyParser.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/EmptyParser.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/EmptyParser.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,30 @@
+package EmptyParser;
+
+use strict;
+use vars qw(@ISA);
+
+use TAP::Parser ();
+
+@ISA = qw(TAP::Parser);
+
+sub _initialize {
+ shift->_set_defaults;
+}
+
+# this should really be in TAP::Parser itself...
+sub _set_defaults {
+ my $self = shift;
+
+ for my $key (
+ qw( source_class perl_source_class grammar_class
+ iterator_factory_class result_factory_class )
+ )
+ {
+ my $default_method = "_default_$key";
+ $self->$key( $self->$default_method() );
+ }
+
+ return $self;
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/IO/c55Capture.pm perl-5.10.0/ext/Test/Harness/t/lib/IO/c55Capture.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/IO/c55Capture.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/IO/c55Capture.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,120 @@
+package IO::c55Capture;
+
+use IO::Handle;
+
+=head1 Name
+
+t/lib/IO::c55Capture - a wafer-thin test support package
+
+=head1 Why!?
+
+Compatibility with 5.5.3 and no external dependencies.
+
+=head1 Usage
+
+Works with a global filehandle:
+
+ # set a spool to write to
+ tie local *STDOUT, 'IO::c55Capture';
+ ...
+ # clear and retrieve buffer list
+ my @spooled = tied(*STDOUT)->dump();
+
+Or, a lexical (and autocreated) filehandle:
+
+ my $capture = IO::c55Capture->new_handle;
+ ...
+ my @output = tied($$capture)->dump;
+
+Note the '$$' dereference.
+
+=cut
+
+# XXX actually returns an IO::Handle :-/
+sub new_handle {
+ my $class = shift;
+ my $handle = IO::Handle->new;
+ tie $$handle, $class;
+ return ($handle);
+}
+
+sub TIEHANDLE {
+ return bless [], __PACKAGE__;
+}
+
+sub PRINT {
+ my $self = shift;
+
+ push @$self, @_;
+}
+
+sub PRINTF {
+ my $self = shift;
+ push @$self, sprintf(@_);
+}
+
+sub dump {
+ my $self = shift;
+ my @got = @$self;
+ @$self = ();
+ return @got;
+}
+
+package util;
+
+use IO::File;
+
+# mostly stolen from Module::Build MBTest.pm
+
+{ # backwards compatible temp filename recipe adapted from perlfaq
+ my $tmp_count = 0;
+ my $tmp_base_name = sprintf( "%d-%d", $$, time() );
+
+ sub temp_file_name {
+ sprintf( "%s-%04d", $tmp_base_name, ++$tmp_count );
+ }
+}
+########################################################################
+
+sub save_handle {
+ my ( $handle, $subr ) = @_;
+ my $outfile = temp_file_name();
+
+ local *SAVEOUT;
+ open SAVEOUT, ">&" . fileno($handle)
+ or die "Can't save output handle: $!";
+ open $handle, "> $outfile" or die "Can't create $outfile: $!";
+
+ eval { $subr->() };
+ my $err = $@;
+ open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
+
+ my $ret = slurp($outfile);
+ 1 while unlink $outfile;
+ $err and die $err;
+ return $ret;
+}
+
+sub stdout_of { save_handle( \*STDOUT, @_ ) }
+sub stderr_of { save_handle( \*STDERR, @_ ) }
+
+sub stdout_stderr_of {
+ my $subr = shift;
+ my ( $stdout, $stderr );
+ $stdout = stdout_of(
+ sub {
+ $stderr = stderr_of($subr);
+ }
+ );
+ return ( $stdout, $stderr );
+}
+
+sub slurp {
+ my $fh = IO::File->new( $_[0] ) or die "Can't open $_[0]: $!";
+ local $/;
+ return scalar <$fh>;
+}
+
+1;
+
+# vim:ts=4:sw=4:et:sta
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MyCustom.pm perl-5.10.0/ext/Test/Harness/t/lib/MyCustom.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MyCustom.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MyCustom.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,12 @@
+# avoid cut-n-paste exhaustion with this mixin
+
+package MyCustom;
+use strict;
+
+sub custom {
+ my $self = shift;
+ $main::CUSTOM{ ref($self) }++;
+ return $self;
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MyGrammar.pm perl-5.10.0/ext/Test/Harness/t/lib/MyGrammar.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MyGrammar.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MyGrammar.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,21 @@
+# subclass for testing customizing & subclassing
+
+package MyGrammar;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Grammar;
+
+@ISA = qw( TAP::Parser::Grammar MyCustom );
+
+sub _initialize {
+ my $self = shift;
+ $self->SUPER::_initialize(@_);
+ $main::INIT{ ref($self) }++;
+ $self->{initialized} = 1;
+ return $self;
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MyIterator.pm perl-5.10.0/ext/Test/Harness/t/lib/MyIterator.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MyIterator.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MyIterator.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,26 @@
+# subclass for testing customizing & subclassing
+
+package MyIterator;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Iterator;
+
+@ISA = qw( TAP::Parser::Iterator MyCustom );
+
+sub _initialize {
+ my $self = shift;
+ $self->SUPER::_initialize(@_);
+ $main::INIT{ ref($self) }++;
+ $self->{initialized} = 1;
+ $self->{content} = [ 'whats TAP all about then?', '1..1', 'ok 1' ];
+ return $self;
+}
+
+sub next {
+ return shift @{ $_[0]->{content} };
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MyIteratorFactory.pm perl-5.10.0/ext/Test/Harness/t/lib/MyIteratorFactory.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MyIteratorFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MyIteratorFactory.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,19 @@
+# subclass for testing customizing & subclassing
+
+package MyIteratorFactory;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use MyIterator;
+use TAP::Parser::IteratorFactory;
+
+@ISA = qw( TAP::Parser::IteratorFactory MyCustom );
+
+sub make_iterator {
+ my $class = shift;
+ return MyIterator->new(@_);
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MyPerlSource.pm perl-5.10.0/ext/Test/Harness/t/lib/MyPerlSource.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MyPerlSource.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MyPerlSource.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,27 @@
+# subclass for testing customizing & subclassing
+
+package MyPerlSource;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Source::Perl;
+
+@ISA = qw( TAP::Parser::Source::Perl MyCustom );
+
+sub _initialize {
+ my $self = shift;
+ $self->SUPER::_initialize(@_);
+ $main::INIT{ ref($self) }++;
+ $self->{initialized} = 1;
+ return $self;
+}
+
+sub source {
+ my $self = shift;
+ return $self->SUPER::source(@_);
+}
+
+1;
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MyResult.pm perl-5.10.0/ext/Test/Harness/t/lib/MyResult.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MyResult.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MyResult.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,21 @@
+# subclass for testing customizing & subclassing
+
+package MyResult;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Result;
+
+@ISA = qw( TAP::Parser::Result MyCustom );
+
+sub _initialize {
+ my $self = shift;
+ $self->SUPER::_initialize(@_);
+ $main::INIT{ ref($self) }++;
+ $self->{initialized} = 1;
+ return $self;
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MyResultFactory.pm perl-5.10.0/ext/Test/Harness/t/lib/MyResultFactory.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MyResultFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MyResultFactory.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,23 @@
+# subclass for testing customizing & subclassing
+
+package MyResultFactory;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use MyResult;
+use TAP::Parser::ResultFactory;
+
+@ISA = qw( TAP::Parser::ResultFactory MyCustom );
+
+sub make_result {
+ my $class = shift;
+
+ # I know, this is not really being initialized, but
+ # for consistency's sake, deal with it :)
+ $main::INIT{$class}++;
+ return MyResult->new(@_);
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/MySource.pm perl-5.10.0/ext/Test/Harness/t/lib/MySource.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/MySource.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/MySource.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,34 @@
+# subclass for testing customizing & subclassing
+
+package MySource;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Source;
+
+@ISA = qw( TAP::Parser::Source MyCustom );
+
+sub _initialize {
+ my $self = shift;
+ $self->SUPER::_initialize(@_);
+ $main::INIT{ ref($self) }++;
+ $self->{initialized} = 1;
+ return $self;
+}
+
+sub source {
+ my $self = shift;
+ return $self->SUPER::source(@_);
+}
+
+sub get_stream {
+ my $self = shift;
+ my $stream = $self->SUPER::get_stream(@_);
+
+ # re-bless it:
+ bless $stream, 'MyIterator';
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/NOP.pm perl-5.10.0/ext/Test/Harness/t/lib/NOP.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/NOP.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/NOP.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,7 @@
+package NOP;
+
+# Do nothing much
+
+sub new { bless {}, shift }
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/NoFork.pm perl-5.10.0/ext/Test/Harness/t/lib/NoFork.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/NoFork.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/NoFork.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,21 @@
+package NoFork;
+
+BEGIN {
+ *CORE::GLOBAL::fork = sub { die "you should not fork" };
+}
+use Config;
+tied(%Config)->{d_fork} = 0; # blatant lie
+
+=begin TEST
+
+Assuming not to much chdir:
+
+ PERL5OPT='-It/lib -MNoFork' perl -Ilib bin/prove -r t
+
+=end TEST
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/TAP/Parser/SubclassTest.pm perl-5.10.0/ext/Test/Harness/t/lib/TAP/Parser/SubclassTest.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/TAP/Parser/SubclassTest.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/TAP/Parser/SubclassTest.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,39 @@
+# subclass for testing subclassing
+
+package TAP::Parser::SubclassTest;
+
+use strict;
+use vars qw(@ISA);
+
+use TAP::Parser;
+
+use MyCustom;
+use MySource;
+use MyPerlSource;
+use MyGrammar;
+use MyIteratorFactory;
+use MyResultFactory;
+
+@ISA = qw( TAP::Parser MyCustom );
+
+sub _default_source_class {'MySource'}
+sub _default_perl_source_class {'MyPerlSource'}
+sub _default_grammar_class {'MyGrammar'}
+sub _default_iterator_factory_class {'MyIteratorFactory'}
+sub _default_result_factory_class {'MyResultFactory'}
+
+sub make_source { shift->SUPER::make_source(@_)->custom }
+sub make_perl_source { shift->SUPER::make_perl_source(@_)->custom }
+sub make_grammar { shift->SUPER::make_grammar(@_)->custom }
+sub make_iterator { shift->SUPER::make_iterator(@_)->custom }
+sub make_result { shift->SUPER::make_result(@_)->custom }
+
+sub _initialize {
+ my $self = shift;
+ $self->SUPER::_initialize(@_);
+ $main::INIT{ ref($self) }++;
+ $self->{initialized} = 1;
+ return $self;
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/lib/if.pm perl-5.10.0/ext/Test/Harness/t/lib/if.pm
--- perl-5.10.0.orig/ext/Test/Harness/t/lib/if.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/lib/if.pm 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,57 @@
+package if;
+
+$VERSION = '0.05';
+
+sub work {
+ my $method = shift() ? 'import' : 'unimport';
+ die
+ "Too few arguments to `use if' (some code returning an empty list in list context?)"
+ unless @_ >= 2;
+ return unless shift; # CONDITION
+
+ my $p = $_[0]; # PACKAGE
+ ( my $file = "$p.pm" ) =~ s!::!/!g;
+ require $file; # Works even if $_[0] is a keyword (like open)
+ my $m = $p->can($method);
+ goto &$m if $m;
+}
+
+sub import { shift; unshift @_, 1; goto &work }
+sub unimport { shift; unshift @_, 0; goto &work }
+
+1;
+__END__
+
+=head1 NAME
+
+if - C<use> a Perl module if a condition holds
+
+=head1 SYNOPSIS
+
+ use if CONDITION, MODULE => ARGUMENTS;
+
+=head1 DESCRIPTION
+
+The construct
+
+ use if CONDITION, MODULE => ARGUMENTS;
+
+has no effect unless C<CONDITION> is true. In this case the effect is
+the same as of
+
+ use MODULE ARGUMENTS;
+
+Above C<< => >> provides necessary quoting of C<MODULE>. If not used (e.g.,
+no ARGUMENTS to give), you'd better quote C<MODULE> yourselves.
+
+=head1 BUGS
+
+The current implementation does not allow specification of the
+required version of the module.
+
+=head1 AUTHOR
+
+Ilya Zakharevich L<mailto:perl-module-if@ilyaz.org>.
+
+=cut
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/multiplexer.t perl-5.10.0/ext/Test/Harness/t/multiplexer.t
--- perl-5.10.0.orig/ext/Test/Harness/t/multiplexer.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/multiplexer.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,188 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More qw( no_plan );
+
+use File::Spec;
+use TAP::Parser;
+use TAP::Parser::Multiplexer;
+use TAP::Parser::Iterator::Process;
+
+my $fork_desc
+ = TAP::Parser::Iterator::Process->_use_open3
+ ? 'fork'
+ : 'nofork';
+
+my @schedule = (
+ { name => 'Single non-selectable source',
+
+ # Returns a list of parser, stash pairs. The stash contains the
+ # TAP that we expect from this parser.
+ sources => sub {
+ my @tap = (
+ '1..1',
+ 'ok 1 Just fine'
+ );
+
+ return [
+ TAP::Parser->new( { tap => join( "\n", @tap ) . "\n" } ),
+ \@tap,
+ ];
+ },
+ },
+ { name => 'Two non-selectable sources',
+ sources => sub {
+ my @tap = (
+ [ '1..1',
+ 'ok 1 Just fine'
+ ],
+ [ '1..2',
+ 'not ok 1 Oh dear',
+ 'ok 2 Better'
+ ]
+ );
+
+ return map {
+ [ TAP::Parser->new( { tap => join( "\n", @$_ ) . "\n" } ),
+ $_
+ ]
+ } @tap;
+ },
+ },
+ { name => 'Single selectable source',
+ sources => sub {
+ return [
+ TAP::Parser->new(
+ { source => File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test',
+ 'Harness'
+ )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'simple'
+ ),
+ }
+ ),
+ [ '1..5',
+ 'ok 1',
+ 'ok 2',
+ 'ok 3',
+ 'ok 4',
+ 'ok 5',
+ ]
+ ];
+ },
+ },
+ { name => 'Three selectable sources',
+ sources => sub {
+ return map {
+ [ TAP::Parser->new(
+ { source => File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test',
+ 'Harness'
+ )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'simple'
+ ),
+ }
+ ),
+ [ '1..5',
+ 'ok 1',
+ 'ok 2',
+ 'ok 3',
+ 'ok 4',
+ 'ok 5',
+ ]
+ ]
+ } 1 .. 3;
+ },
+ },
+ { name => 'Three selectable sources, two non-selectable sources',
+ sources => sub {
+ my @tap = (
+ [ '1..1',
+ 'ok 1 Just fine'
+ ],
+ [ '1..2',
+ 'not ok 1 Oh dear',
+ 'ok 2 Better'
+ ]
+ );
+
+ return (
+ map {
+ [ TAP::Parser->new(
+ { tap => join( "\n", @$_ ) . "\n" }
+ ),
+ $_
+ ]
+ } @tap
+ ),
+ ( map {
+ [ TAP::Parser->new(
+ { source => File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext',
+ 'Test', 'Harness'
+ )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'simple'
+ ),
+ }
+ ),
+ [ '1..5',
+ 'ok 1',
+ 'ok 2',
+ 'ok 3',
+ 'ok 4',
+ 'ok 5',
+ ]
+ ]
+ } 1 .. 3
+ );
+ },
+ }
+);
+
+for my $test (@schedule) {
+ my $name = "$test->{name} ($fork_desc)";
+ my @sources = $test->{sources}->();
+ my $mux = TAP::Parser::Multiplexer->new;
+
+ my $count = @sources;
+ $mux->add(@$_) for @sources;
+
+ is $mux->parsers, $count, "$name: count OK";
+
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+
+ # use Data::Dumper;
+ # diag Dumper( { stash => $stash, result => $result } );
+ if ( defined $result ) {
+ my $expect = ( shift @$stash ) || ' OOPS ';
+ my $got = $result->raw;
+ is $got, $expect, "$name: '$expect' OK";
+ }
+ else {
+ ok @$stash == 0, "$name: EOF OK";
+
+ # Make sure we only get one EOF per stream
+ push @$stash, ' expect no more ';
+ }
+ }
+ is $mux->parsers, 0, "$name: All used up";
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/nofork-mux.t perl-5.10.0/ext/Test/Harness/t/nofork-mux.t
--- perl-5.10.0.orig/ext/Test/Harness/t/nofork-mux.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/nofork-mux.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,17 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use strict;
+
+use NoFork;
+require(
+ ( $ENV{PERL_CORE} ? '../ext/Test/Harness/' : '' ) . 't/multiplexer.t' );
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/nofork.t perl-5.10.0/ext/Test/Harness/t/nofork.t
--- perl-5.10.0.orig/ext/Test/Harness/t/nofork.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/nofork.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,68 @@
+#!/usr/bin/perl -w
+
+# check nofork logic on systems which *can* fork()
+# NOTE maybe a good candidate for xt/author or something.
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use strict;
+
+use Config;
+use Test::More (
+ $Config{d_fork}
+ ? 'no_plan'
+ : ( 'skip_all' => 'your system already has no fork' )
+);
+use IO::c55Capture; # for util
+
+use TAP::Harness;
+
+sub backticks {
+ my (@args) = @_;
+
+ util::stdout_of( sub { system(@args) and die "error $?" } );
+}
+
+my @libs = map "-I$_", @INC;
+my @perl = ( $^X, @libs );
+my $mod = 'TAP::Parser::Iterator::Process';
+
+{ # just check the introspective method to start...
+ my $code = qq(print $mod->_use_open3 ? 1 : 2);
+ {
+ my $ans = backticks( @perl, '-MNoFork', "-M$mod", '-e', $code );
+ is( $ans, 2, 'says not to fork' );
+ }
+ {
+ local $ENV{PERL5OPT}; # punt: prevent propogating -MNoFork
+ my $ans = backticks( @perl, "-M$mod", '-e', $code );
+ is( $ans, 1, 'says to fork' );
+ }
+}
+
+{ # and make sure we can run a test
+ my $capture = IO::c55Capture->new_handle;
+ local *STDERR;
+ my $harness = TAP::Harness->new(
+ { verbosity => -2,
+ switches => [ @libs, "-MNoFork" ],
+ stdout => $capture,
+ }
+ );
+ $harness->runtests( ( $ENV{PERL_CORE} ? '../ext/Test/Harness/' : '' )
+ . 't/sample-tests/simple' );
+ my @output = tied($$capture)->dump;
+ is pop @output, "Result: PASS\n", 'status OK';
+ pop @output; # get rid of summary line
+ is( $output[-1], "All tests successful.\n", 'ran with no fork' );
+}
+
+# vim:ts=4:sw=4:et:sta
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/object.t perl-5.10.0/ext/Test/Harness/t/object.t
--- perl-5.10.0.orig/ext/Test/Harness/t/object.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/object.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,37 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 7;
+
+use_ok('TAP::Object');
+
+can_ok( 'TAP::Object', 'new' );
+can_ok( 'TAP::Object', '_initialize' );
+can_ok( 'TAP::Object', '_croak' );
+
+{
+
+ package TAP::TestObj;
+ use vars qw(@ISA);
+ @ISA = qw(TAP::Object);
+
+ sub _initialize {
+ my $self = shift;
+ $self->{init} = 1;
+ $self->{args} = [@_];
+ return $self;
+ }
+}
+
+# I know these tests are simple, but they're documenting the base API, so
+# necessary none-the-less...
+my $obj = TAP::TestObj->new( 'foo', { bar => 'baz' } );
+ok( $obj->{init}, '_initialize' );
+is_deeply( $obj->{args}, [ 'foo', { bar => 'baz' } ], '_initialize: args' );
+
+eval { $obj->_croak('eek') };
+my $err = $@;
+like( $err, qr/^eek/, '_croak' );
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/parse.t perl-5.10.0/ext/Test/Harness/t/parse.t
--- perl-5.10.0.orig/ext/Test/Harness/t/parse.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/parse.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,1048 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use Test::More tests => 282;
+use IO::c55Capture;
+
+use File::Spec;
+
+use TAP::Parser;
+use TAP::Parser::IteratorFactory;
+
+sub _get_results {
+ my $parser = shift;
+ my @results;
+ while ( defined( my $result = $parser->next ) ) {
+ push @results => $result;
+ }
+ return @results;
+}
+
+my ( $PARSER, $PLAN, $PRAGMA, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw(
+ TAP::Parser
+ TAP::Parser::Result::Plan
+ TAP::Parser::Result::Pragma
+ TAP::Parser::Result::Test
+ TAP::Parser::Result::Comment
+ TAP::Parser::Result::Bailout
+ TAP::Parser::Result::Unknown
+ TAP::Parser::Result::YAML
+ TAP::Parser::Result::Version
+);
+
+my $factory = TAP::Parser::IteratorFactory->new;
+
+my $tap = <<'END_TAP';
+TAP version 13
+1..7
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ --- YAML!
+ ...
+ok 5 # skip we have no description
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+can_ok $PARSER, 'new';
+my $parser = $PARSER->new( { tap => $tap } );
+isa_ok $parser, $PARSER, '... and the object it returns';
+
+ok $ENV{TAP_VERSION}, 'TAP_VERSION env variable should be set';
+
+# results() is sane?
+
+my @results = _get_results($parser);
+is scalar @results, 12, '... and there should be one for each line';
+
+my $version = shift @results;
+isa_ok $version, $VERSION;
+is $version->version, '13', '... and the version should be 13';
+
+# check the test plan
+
+my $result = shift @results;
+isa_ok $result, $PLAN;
+can_ok $result, 'type';
+is $result->type, 'plan', '... and it should report the correct type';
+ok $result->is_plan, '... and it should identify itself as a plan';
+is $result->plan, '1..7', '... and identify the plan';
+ok !$result->directive, '... and this plan should not have a directive';
+ok !$result->explanation, '... or a directive explanation';
+is $result->as_string, '1..7',
+ '... and have the correct string representation';
+is $result->raw, '1..7', '... and raw() should return the original line';
+
+# a normal, passing test
+
+my $test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 1, '... and have the correct test number';
+is $test->description, '- input file opened',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 1 - input file opened',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 1 - input file opened',
+ '... and raw() should return the original line';
+
+# junk lines should be preserved
+
+my $unknown = shift @results;
+isa_ok $unknown, $UNKNOWN;
+is $unknown->type, 'unknown', '... and it should report the correct type';
+ok $unknown->is_unknown, '... and it should identify itself as unknown';
+is $unknown->as_string, '... this is junk',
+ '... and its string representation should be returned verbatim';
+is $unknown->raw, '... this is junk',
+ '... and raw() should return the original line';
+
+# a failing test, which also happens to have a directive
+
+my $failed = shift @results;
+isa_ok $failed, $TEST;
+is $failed->type, 'test', '... and it should report the correct type';
+ok $failed->is_test, '... and it should identify itself as a test';
+is $failed->ok, 'not ok', '... and it should have the correct ok()';
+ok $failed->is_ok, '... and TODO tests should always pass';
+ok !$failed->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $failed->number, 2, '... and have the correct failed number';
+is $failed->description, 'first line of the input valid',
+ '... and the correct description';
+is $failed->directive, 'TODO', '... and should have the correct directive';
+is $failed->explanation, 'some data',
+ '... and the correct directive explanation';
+ok !$failed->has_skip, '... and it is not a SKIPped failed';
+ok $failed->has_todo, '... but it is a TODO succeeded';
+is $failed->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and its string representation should be correct';
+is $failed->raw, 'not ok first line of the input valid # todo some data',
+ '... and raw() should return the original line';
+
+# comments
+
+my $comment = shift @results;
+isa_ok $comment, $COMMENT;
+is $comment->type, 'comment', '... and it should report the correct type';
+ok $comment->is_comment, '... and it should identify itself as a comment';
+is $comment->comment, 'this is a comment',
+ '... and you should be able to fetch the comment';
+is $comment->as_string, '# this is a comment',
+ '... and have the correct string representation';
+is $comment->raw, '# this is a comment',
+ '... and raw() should return the original line';
+
+# another normal, passing test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 3, '... and have the correct test number';
+is $test->description, '- read the rest of the file',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 3 - read the rest of the file',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 3 - read the rest of the file',
+ '... and raw() should return the original line';
+
+# a failing test
+
+$failed = shift @results;
+isa_ok $failed, $TEST;
+is $failed->type, 'test', '... and it should report the correct type';
+ok $failed->is_test, '... and it should identify itself as a test';
+is $failed->ok, 'not ok', '... and it should have the correct ok()';
+ok !$failed->is_ok, '... and the tests should not have passed';
+ok !$failed->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $failed->number, 4, '... and have the correct failed number';
+is $failed->description, '- this is a real failure',
+ '... and the correct description';
+ok !$failed->directive, '... and should have no directive';
+ok !$failed->explanation, '... and no directive explanation';
+ok !$failed->has_skip, '... and it is not a SKIPped failed';
+ok !$failed->has_todo, '... and not a TODO test';
+is $failed->as_string, 'not ok 4 - this is a real failure',
+ '... and its string representation should be correct';
+is $failed->raw, 'not ok 4 - this is a real failure',
+ '... and raw() should return the original line';
+
+# Some YAML
+my $yaml = shift @results;
+isa_ok $yaml, $YAML;
+is $yaml->type, 'yaml', '... and it should report the correct type';
+ok $yaml->is_yaml, '... and it should identify itself as yaml';
+is_deeply $yaml->data, 'YAML!', '... and data should be correct';
+
+# ok 5 # skip we have no description
+# skipped test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 5, '... and have the correct test number';
+ok !$test->description, '... and skipped tests have no description';
+is $test->directive, 'SKIP', '... and the correct directive';
+is $test->explanation, 'we have no description',
+ '... but we should have an explanation';
+ok $test->has_skip, '... and it is a SKIPped test';
+ok !$test->has_todo, '... but not a TODO test';
+is $test->as_string, 'ok 5 # SKIP we have no description',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 5 # skip we have no description',
+ '... and raw() should return the original line';
+
+# a failing test, which also happens to have a directive
+# ok 6 - you shall not pass! # TODO should have failed
+
+my $bonus = shift @results;
+isa_ok $bonus, $TEST;
+can_ok $bonus, 'todo_passed';
+is $bonus->type, 'test', 'TODO tests should parse correctly';
+ok $bonus->is_test, '... and it should identify itself as a test';
+is $bonus->ok, 'ok', '... and it should have the correct ok()';
+ok $bonus->is_ok, '... and TODO tests should not always pass';
+ok $bonus->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $bonus->number, 6, '... and have the correct failed number';
+is $bonus->description, '- you shall not pass!',
+ '... and the correct description';
+is $bonus->directive, 'TODO', '... and should have the correct directive';
+is $bonus->explanation, 'should have failed',
+ '... and the correct directive explanation';
+ok !$bonus->has_skip, '... and it is not a SKIPped failed';
+ok $bonus->has_todo, '... but it is a TODO succeeded';
+is $bonus->as_string, 'ok 6 - you shall not pass! # TODO should have failed',
+ '... and its string representation should be correct';
+is $bonus->raw, 'ok 6 - you shall not pass! # TODO should have failed',
+ '... and raw() should return the original line';
+ok $bonus->todo_passed,
+ '... todo_bonus() should pass for TODO tests which unexpectedly succeed';
+
+# not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+
+my $passed = shift @results;
+isa_ok $passed, $TEST;
+can_ok $passed, 'todo_passed';
+is $passed->type, 'test', 'TODO tests should parse correctly';
+ok $passed->is_test, '... and it should identify itself as a test';
+is $passed->ok, 'not ok', '... and it should have the correct ok()';
+ok $passed->is_ok, '... and TODO tests should always pass';
+ok !$passed->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $passed->number, 7, '... and have the correct passed number';
+is $passed->description, '- Gandalf wins. Game over.',
+ '... and the correct description';
+is $passed->directive, 'TODO', '... and should have the correct directive';
+is $passed->explanation, "'bout time!",
+ '... and the correct directive explanation';
+ok !$passed->has_skip, '... and it is not a SKIPped passed';
+ok $passed->has_todo, '... but it is a TODO succeeded';
+is $passed->as_string,
+ "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!",
+ '... and its string representation should be correct';
+is $passed->raw, "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!",
+ '... and raw() should return the original line';
+ok !$passed->todo_passed,
+ '... todo_passed() should not pass for TODO tests which failed';
+
+# test parse results
+
+can_ok $parser, 'passed';
+is $parser->passed, 6,
+ '... and we should have the correct number of passed tests';
+is_deeply [ $parser->passed ], [ 1, 2, 3, 5, 6, 7 ],
+ '... and get a list of the passed tests';
+
+can_ok $parser, 'failed';
+is $parser->failed, 1, '... and the correct number of failed tests';
+is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests';
+
+can_ok $parser, 'actual_passed';
+is $parser->actual_passed, 4,
+ '... and we should have the correct number of actually passed tests';
+is_deeply [ $parser->actual_passed ], [ 1, 3, 5, 6 ],
+ '... and get a list of the actually passed tests';
+
+can_ok $parser, 'actual_failed';
+is $parser->actual_failed, 3,
+ '... and the correct number of actually failed tests';
+is_deeply [ $parser->actual_failed ], [ 2, 4, 7 ],
+ '... or get a list of the actually failed tests';
+
+can_ok $parser, 'todo';
+is $parser->todo, 3,
+ '... and we should have the correct number of TODO tests';
+is_deeply [ $parser->todo ], [ 2, 6, 7 ],
+ '... and get a list of the TODO tests';
+
+can_ok $parser, 'skipped';
+is $parser->skipped, 1,
+ '... and we should have the correct number of skipped tests';
+is_deeply [ $parser->skipped ], [5],
+ '... and get a list of the skipped tests';
+
+# check the plan
+
+can_ok $parser, 'plan';
+is $parser->plan, '1..7', '... and we should have the correct plan';
+is $parser->tests_planned, 7, '... and the correct number of tests';
+
+# "Unexpectedly succeeded"
+can_ok $parser, 'todo_passed';
+is scalar $parser->todo_passed, 1,
+ '... and it should report the number of tests which unexpectedly succeeded';
+is_deeply [ $parser->todo_passed ], [6],
+ '... or *which* tests unexpectedly succeeded';
+
+#
+# Bug report from Torsten Schoenfeld
+# Makes sure parser can handle blank lines
+#
+
+$tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+
+
+ok 2 - read the rest of the file
+END_TAP
+
+my $aref = [ split /\n/ => $tap ];
+
+can_ok $PARSER, 'new';
+$parser = $PARSER->new( { stream => $factory->make_iterator($aref) } );
+isa_ok $parser, $PARSER, '... and calling it should succeed';
+
+# results() is sane?
+
+ok @results = _get_results($parser), 'The parser should return results';
+is scalar @results, 5, '... and there should be one for each line';
+
+# check the test plan
+
+$result = shift @results;
+isa_ok $result, $PLAN;
+can_ok $result, 'type';
+is $result->type, 'plan', '... and it should report the correct type';
+ok $result->is_plan, '... and it should identify itself as a plan';
+is $result->plan, '1..2', '... and identify the plan';
+is $result->as_string, '1..2',
+ '... and have the correct string representation';
+is $result->raw, '1..2', '... and raw() should return the original line';
+
+# a normal, passing test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 1, '... and have the correct test number';
+is $test->description, '- input file opened',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 1 - input file opened',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 1 - input file opened',
+ '... and raw() should return the original line';
+
+# junk lines should be preserved
+
+$unknown = shift @results;
+isa_ok $unknown, $UNKNOWN;
+is $unknown->type, 'unknown', '... and it should report the correct type';
+ok $unknown->is_unknown, '... and it should identify itself as unknown';
+is $unknown->as_string, '',
+ '... and its string representation should be returned verbatim';
+is $unknown->raw, '', '... and raw() should return the original line';
+
+# ... and the second empty line
+
+$unknown = shift @results;
+isa_ok $unknown, $UNKNOWN;
+is $unknown->type, 'unknown', '... and it should report the correct type';
+ok $unknown->is_unknown, '... and it should identify itself as unknown';
+is $unknown->as_string, '',
+ '... and its string representation should be returned verbatim';
+is $unknown->raw, '', '... and raw() should return the original line';
+
+# a passing test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 2, '... and have the correct test number';
+is $test->description, '- read the rest of the file',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 2 - read the rest of the file',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 2 - read the rest of the file',
+ '... and raw() should return the original line';
+
+is scalar $parser->passed, 2,
+ 'Empty junk lines should not affect the correct number of tests passed';
+
+{
+
+ # set a spool to write to
+ tie local *SPOOL, 'IO::c55Capture';
+
+ my $tap = <<'END_TAP';
+TAP version 13
+1..7
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ --- YAML!
+ ...
+ok 5 # skip we have no description
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+ {
+ my $parser = $PARSER->new(
+ { tap => $tap,
+ spool => \*SPOOL,
+ }
+ );
+
+ _get_results($parser);
+
+ my @spooled = tied(*SPOOL)->dump();
+
+ is @spooled, 24, 'coverage testing for spool attribute of parser';
+ is join( '', @spooled ), $tap, "spooled tap matches";
+ }
+
+ {
+ my $parser = $PARSER->new(
+ { tap => $tap,
+ spool => \*SPOOL,
+ }
+ );
+
+ $parser->callback( 'ALL', sub { } );
+
+ _get_results($parser);
+
+ my @spooled = tied(*SPOOL)->dump();
+
+ is @spooled, 24, 'coverage testing for spool attribute of parser';
+ is join( '', @spooled ), $tap, "spooled tap matches";
+ }
+}
+
+{
+
+ # _initialize coverage
+
+ my $x = bless [], 'kjsfhkjsdhf';
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $PARSER->new();
+ };
+
+ is @die, 1, 'coverage testing for _initialize';
+
+ like pop @die, qr/PANIC:\s+could not determine stream at/,
+ '...and it failed as expected';
+
+ @die = ();
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $PARSER->new(
+ { stream => 'stream',
+ tap => 'tap',
+ source => 'source', # only one of these is allowed
+ }
+ );
+ };
+
+ is @die, 1, 'coverage testing for _initialize';
+
+ like pop @die,
+ qr/You may only choose one of 'exec', 'stream', 'tap' or 'source'/,
+ '...and it failed as expected';
+}
+
+{
+
+ # coverage of todo_failed
+
+ my $tap = <<'END_TAP';
+TAP version 13
+1..7
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ --- YAML!
+ ...
+ok 5 # skip we have no description
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+ my $parser = $PARSER->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ my @warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $parser->todo_failed;
+ };
+
+ is @warn, 1, 'coverage testing of todo_failed';
+
+ like pop @warn,
+ qr/"todo_failed" is deprecated. Please use "todo_passed". See the docs[.]/,
+ '..and failed as expected'
+}
+
+{
+
+ # coverage testing for T::P::_initialize
+
+ # coverage of the source argument paths
+
+ # ref argument to source
+
+ my $parser = TAP::Parser->new( { source => [ split /$/, $tap ] } );
+
+ isa_ok $parser, 'TAP::Parser';
+
+ isa_ok $parser->_stream, 'TAP::Parser::Iterator::Array';
+
+ # uncategorisable argument to source
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $parser = TAP::Parser->new( { source => 'nosuchfile' } );
+ };
+
+ is @die, 1, 'uncategorisable source';
+
+ like pop @die, qr/Cannot determine source for nosuchfile/,
+ '... and we died as expected';
+}
+
+{
+
+ # coverage test of perl source with switches
+
+ my $parser = TAP::Parser->new(
+ { source => File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'simple'
+ ),
+ }
+ );
+
+ isa_ok $parser, 'TAP::Parser';
+
+ isa_ok $parser->_stream, 'TAP::Parser::Iterator::Process';
+
+ # Workaround for Mac OS X problem wrt closing the iterator without
+ # reading from it.
+ $parser->next;
+}
+
+{
+
+ # coverage testing for TAP::Parser::has_problems
+
+ # we're going to need to test lots of fragments of tap
+ # to cover all the different boolean tests
+
+ # currently covered are no problems and failed, so let's next test
+ # todo_passed
+
+ my $tap = <<'END_TAP';
+TAP version 13
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ ok !$parser->failed, 'parser didnt fail';
+ ok $parser->todo_passed, '... and todo_passed is true';
+
+ ok !$parser->has_problems, '... and has_problems is false';
+
+ # now parse_errors
+
+ $tap = <<'END_TAP';
+TAP version 13
+1..2
+SMACK
+END_TAP
+
+ $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ ok !$parser->failed, 'parser didnt fail';
+ ok !$parser->todo_passed, '... and todo_passed is false';
+ ok $parser->parse_errors, '... and parse_errors is true';
+
+ ok $parser->has_problems, '... and has_problems';
+
+ # Now wait and exit are hard to do in an OS platform-independent way, so
+ # we won't even bother
+
+ $tap = <<'END_TAP';
+TAP version 13
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ $parser->wait(1);
+
+ ok !$parser->failed, 'parser didnt fail';
+ ok !$parser->todo_passed, '... and todo_passed is false';
+ ok !$parser->parse_errors, '... and parse_errors is false';
+
+ ok $parser->wait, '... and wait is set';
+
+ ok $parser->has_problems, '... and has_problems';
+
+ # and use the same for exit
+
+ $parser->wait(0);
+ $parser->exit(1);
+
+ ok !$parser->failed, 'parser didnt fail';
+ ok !$parser->todo_passed, '... and todo_passed is false';
+ ok !$parser->parse_errors, '... and parse_errors is false';
+ ok !$parser->wait, '... and wait is not set';
+
+ ok $parser->exit, '... and exit is set';
+
+ ok $parser->has_problems, '... and has_problems';
+}
+
+{
+
+ # coverage testing of the version states
+
+ my $tap = <<'END_TAP';
+TAP version 12
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ my @errors = $parser->parse_errors;
+
+ is @errors, 1, 'test too low version number';
+
+ like pop @errors,
+ qr/Explicit TAP version must be at least 13. Got version 12/,
+ '... and trapped expected version error';
+
+ # now too high a version
+ $tap = <<'END_TAP';
+TAP version 14
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ @errors = $parser->parse_errors;
+
+ is @errors, 1, 'test too high version number';
+
+ like pop @errors,
+ qr/TAP specified version 14 but we don't know about versions later than 13/,
+ '... and trapped expected version error';
+}
+
+{
+
+ # coverage testing of TAP version in the wrong place
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+TAP version 12
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ my @errors = $parser->parse_errors;
+
+ is @errors, 1, 'test TAP version number in wrong place';
+
+ like pop @errors,
+ qr/If TAP version is present it must be the first line of output/,
+ '... and trapped expected version error';
+
+}
+
+{
+
+ # we're going to bash the internals a bit (but using the API as
+ # much as possible) to force grammar->tokenise() to fail
+
+ # firstly we'll create a stream that dies when its next_raw method is called
+
+ package TAP::Parser::Iterator::Dies;
+
+ use strict;
+ use vars qw(@ISA);
+
+ @ISA = qw(TAP::Parser::Iterator);
+
+ sub next_raw {
+ die 'this is the dying iterator';
+ }
+
+ # required as part of the TPI interface
+ sub exit { }
+ sub wait { }
+
+ package main;
+
+ # now build a standard parser
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ {
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ # build a dying stream
+ my $stream = TAP::Parser::Iterator::Dies->new;
+
+ # now replace the stream - we're forced to us an T::P intenal
+ # method for this
+ $parser->_stream($stream);
+
+ # build a new grammar
+ my $grammar = TAP::Parser::Grammar->new(
+ { stream => $stream,
+ parser => $parser
+ }
+ );
+
+ # replace our grammar with this new one
+ $parser->_grammar($grammar);
+
+ # now call next on the parser, and the grammar should die
+ my $result = $parser->next; # will die in iterator
+
+ is $result, undef, 'iterator dies';
+
+ my @errors = $parser->parse_errors;
+ is @errors, 2, '...and caught expected errrors';
+
+ like shift @errors, qr/this is the dying iterator/,
+ '...and it was what we expected';
+ }
+
+ # Do it all again with callbacks to exercise the other code path in
+ # the unrolled iterator
+ {
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ $parser->callback( 'ALL', sub { } );
+
+ # build a dying stream
+ my $stream = TAP::Parser::Iterator::Dies->new;
+
+ # now replace the stream - we're forced to us an T::P intenal
+ # method for this
+ $parser->_stream($stream);
+
+ # build a new grammar
+ my $grammar = TAP::Parser::Grammar->new(
+ { stream => $stream,
+ parser => $parser
+ }
+ );
+
+ # replace our grammar with this new one
+ $parser->_grammar($grammar);
+
+ # now call next on the parser, and the grammar should die
+ my $result = $parser->next; # will die in iterator
+
+ is $result, undef, 'iterator dies';
+
+ my @errors = $parser->parse_errors;
+ is @errors, 2, '...and caught expected errrors';
+
+ like shift @errors, qr/this is the dying iterator/,
+ '...and it was what we expected';
+ }
+}
+
+{
+
+ # coverage testing of TAP::Parser::_next_state
+
+ package TAP::Parser::WithBrokenState;
+ use vars qw(@ISA);
+
+ @ISA = qw( TAP::Parser );
+
+ sub _make_state_table {
+ return { INIT => { plan => { goto => 'FOO' } } };
+ }
+
+ package main;
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser::WithBrokenState->new( { tap => $tap } );
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $parser->next;
+ $parser->next;
+ };
+
+ is @die, 1, 'detect broken state machine';
+
+ like pop @die, qr/Illegal state: FOO/,
+ '...and the message is as we expect';
+}
+
+{
+
+ # coverage testing of TAP::Parser::_iter
+
+ package TAP::Parser::WithBrokenIter;
+ use vars qw(@ISA);
+
+ @ISA = qw( TAP::Parser );
+
+ sub _iter {return}
+
+ package main;
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser::WithBrokenIter->new( { tap => $tap } );
+
+ my @die;
+
+ eval {
+ local $SIG{__WARN__} = sub { };
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $parser->next;
+ };
+
+ is @die, 1, 'detect broken iter';
+
+ like pop @die, qr/Can't use/, '...and the message is as we expect';
+}
+
+SKIP: {
+
+ # http://markmail.org/message/rkxbo6ft7yorgnzb
+ skip "Crashes on older Perls", 2 if $] <= 5.008004 || $] == 5.009;
+
+ # coverage testing of TAP::Parser::_finish
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ $parser->tests_run(999);
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ _get_results $parser;
+ };
+
+ is @die, 1, 'detect broken test counts';
+
+ like pop @die,
+ qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/,
+ '...and the message is as we expect';
+}
+
+{
+
+ # Sanity check on state table
+
+ my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
+ my $state_table = $parser->_make_state_table;
+ my @states = sort keys %$state_table;
+ my @expect = sort qw(
+ bailout comment plan pragma test unknown version yaml
+ );
+
+ my %reachable = ( INIT => 1 );
+
+ for my $name (@states) {
+ my $state = $state_table->{$name};
+ my @can_handle = sort keys %$state;
+ is_deeply \@can_handle, \@expect, "token types handled in $name";
+ for my $type (@can_handle) {
+ $reachable{$_}++
+ for grep {defined}
+ map { $state->{$type}->{$_} } qw(goto continue);
+ }
+ }
+
+ is_deeply [ sort keys %reachable ], [@states], "all states reachable";
+}
+
+{
+
+ # exit, wait, ignore_exit interactions
+
+ my @truth = (
+ [ 0, 0, 0, 0 ],
+ [ 0, 0, 1, 0 ],
+ [ 1, 0, 0, 1 ],
+ [ 1, 0, 1, 0 ],
+ [ 1, 1, 0, 1 ],
+ [ 1, 1, 1, 0 ],
+ [ 0, 1, 0, 1 ],
+ [ 0, 1, 1, 0 ],
+ );
+
+ for my $t (@truth) {
+ my ( $wait, $exit, $ignore_exit, $has_problems ) = @$t;
+ my $test_parser = sub {
+ my $parser = shift;
+ $parser->wait($wait);
+ $parser->exit($exit);
+ ok $has_problems ? $parser->has_problems : !$parser->has_problems,
+ "exit=$exit, wait=$wait, ignore=$ignore_exit";
+ };
+
+ my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
+ $parser->ignore_exit($ignore_exit);
+ $test_parser->($parser);
+
+ $test_parser->(
+ TAP::Parser->new(
+ { tap => "1..1\nok 1\n", ignore_exit => $ignore_exit }
+ )
+ );
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/parser-config.t perl-5.10.0/ext/Test/Harness/t/parser-config.t
--- perl-5.10.0.orig/ext/Test/Harness/t/parser-config.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/parser-config.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,46 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use vars qw(%INIT %CUSTOM);
+
+use Test::More tests => 11;
+use File::Spec::Functions qw( catfile updir );
+use TAP::Parser;
+
+use_ok('MySource');
+use_ok('MyPerlSource');
+use_ok('MyGrammar');
+use_ok('MyIteratorFactory');
+use_ok('MyResultFactory');
+
+my @t_path = $ENV{PERL_CORE} ? ( updir(), 'ext', 'Test', 'Harness' ) : ();
+my $source = catfile( @t_path, 't', 'source_tests', 'source' );
+my %customize = (
+ source_class => 'MySource',
+ perl_source_class => 'MyPerlSource',
+ grammar_class => 'MyGrammar',
+ iterator_factory_class => 'MyIteratorFactory',
+ result_factory_class => 'MyResultFactory',
+);
+my $p = TAP::Parser->new(
+ { source => $source,
+ %customize,
+ }
+);
+ok( $p, 'new customized parser' );
+
+foreach my $key ( keys %customize ) {
+ is( $p->$key(), $customize{$key}, "customized $key" );
+}
+
+# TODO: make sure these things are propogated down through the parser...
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/parser-subclass.t perl-5.10.0/ext/Test/Harness/t/parser-subclass.t
--- perl-5.10.0.orig/ext/Test/Harness/t/parser-subclass.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/parser-subclass.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,88 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use vars qw(%INIT %CUSTOM);
+
+use Test::More tests => 24;
+use File::Spec::Functions qw( catfile updir );
+
+use_ok('TAP::Parser::SubclassTest');
+
+# TODO: foreach my $source ( ... )
+my @t_path = $ENV{PERL_CORE} ? ( updir(), 'ext', 'Test', 'Harness' ) : ();
+
+{ # perl source
+ %INIT = %CUSTOM = ();
+ my $source = catfile( @t_path, 't', 'subclass_tests', 'perl_source' );
+ my $p = TAP::Parser::SubclassTest->new( { source => $source } );
+
+ # The grammar is lazily constructed so we need to ask for it to
+ # trigger it's creation.
+ my $grammer = $p->_grammar;
+
+ ok( $p->{initialized}, 'new subclassed parser' );
+
+ is( $p->source_class => 'MySource', 'source_class' );
+ is( $p->perl_source_class => 'MyPerlSource', 'perl_source_class' );
+ is( $p->grammar_class => 'MyGrammar', 'grammar_class' );
+ is( $p->iterator_factory_class => 'MyIteratorFactory',
+ 'iterator_factory_class'
+ );
+ is( $p->result_factory_class => 'MyResultFactory',
+ 'result_factory_class'
+ );
+
+ is( $INIT{MyPerlSource}, 1, 'initialized MyPerlSource' );
+ is( $CUSTOM{MyPerlSource}, 1, '... and it was customized' );
+ is( $INIT{MyGrammar}, 1, 'initialized MyGrammar' );
+ is( $CUSTOM{MyGrammar}, 1, '... and it was customized' );
+
+ # make sure overrided make_* methods work...
+ %CUSTOM = ();
+ $p->make_source;
+ is( $CUSTOM{MySource}, 1, 'make custom source' );
+ $p->make_perl_source;
+ is( $CUSTOM{MyPerlSource}, 1, 'make custom perl source' );
+ $p->make_grammar;
+ is( $CUSTOM{MyGrammar}, 1, 'make custom grammar' );
+ $p->make_iterator;
+ is( $CUSTOM{MyIterator}, 1, 'make custom iterator' );
+ $p->make_result;
+ is( $CUSTOM{MyResult}, 1, 'make custom result' );
+
+ # make sure parser helpers use overrided classes too (the parser should
+ # be the central source of configuration/overriding functionality)
+ # The source is already tested above (parser doesn't keep a copy of the
+ # source currently). So only one to check is the Grammar:
+ %INIT = %CUSTOM = ();
+ my $r = $p->_grammar->tokenize;
+ isa_ok( $r, 'MyResult', 'i has results' );
+ is( $INIT{MyResult}, 1, 'initialized MyResult' );
+ is( $CUSTOM{MyResult}, 1, '... and it was customized' );
+ is( $INIT{MyResultFactory}, 1, '"initialized" MyResultFactory' );
+}
+
+SKIP: { # non-perl source
+ %INIT = %CUSTOM = ();
+ my $cat = '/bin/cat';
+ unless ( -e $cat ) {
+ skip "no '$cat'", 4;
+ }
+ my $file = catfile( @t_path, 't', 'data', 'catme.1' );
+ my $p = TAP::Parser::SubclassTest->new( { exec => [ $cat => $file ] } );
+
+ is( $INIT{MySource}, 1, 'initialized MySource subclass' );
+ is( $CUSTOM{MySource}, 1, '... and it was customized' );
+ is( $INIT{MyIterator}, 1, 'initialized MyIterator subclass' );
+ is( $CUSTOM{MyIterator}, 1, '... and it was customized' );
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/perl5lib.t perl-5.10.0/ext/Test/Harness/t/perl5lib.t
--- perl-5.10.0.orig/ext/Test/Harness/t/perl5lib.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/perl5lib.t 2009-03-10 17:38:43.000000000 +0100
@@ -0,0 +1,48 @@
+#!/usr/bin/perl -w
+
+# Test that PERL5LIB is propogated from the harness process to the test
+# process.
+
+use strict;
+use lib 't/lib';
+use Config;
+
+my $path_sep = $Config{path_sep};
+
+sub has_crazy_patch {
+ my $sentinel = 'blirpzoffle';
+ local $ENV{PERL5LIB} = $sentinel;
+ my $command = join ' ',
+ map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' );
+ my $path = `$command`;
+ my @got = ( $path =~ /($sentinel)/g );
+ return @got > 1;
+}
+
+use Test::More (
+ $^O eq 'VMS' ? ( skip_all => 'VMS' )
+ : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' )
+ : ( tests => 1 )
+);
+
+use Test::Harness;
+use App::Prove;
+
+# Change PERL5LIB so we ensure it's preserved.
+$ENV{PERL5LIB} = join( $path_sep, 'wibble', $ENV{PERL5LIB} );
+
+open TEST, ">perl5lib_check.t.tmp";
+print TEST <<"END";
+#!/usr/bin/perl
+use strict;
+use Test::More tests => 1;
+like \$ENV{PERL5LIB}, qr/(^|${path_sep})wibble${path_sep}/;
+END
+close TEST;
+
+END { 1 while unlink 'perl5lib_check.t.tmp'; }
+
+my $h = TAP::Harness->new( { lib => ['something'], verbosity => -3 } );
+ok( !$h->runtests('perl5lib_check.t.tmp')->has_errors );
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/premature-bailout.t perl-5.10.0/ext/Test/Harness/t/premature-bailout.t
--- perl-5.10.0.orig/ext/Test/Harness/t/premature-bailout.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/premature-bailout.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,125 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 14;
+
+use TAP::Parser;
+use TAP::Parser::IteratorFactory;
+
+sub tap_to_lines {
+ my $string = shift;
+ my @lines = ( $string =~ /.*\n/g );
+ return \@lines;
+}
+
+my $tap = <<'END_TAP';
+1..4
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+Bail out! We ran out of foobar.
+not ok 5
+END_TAP
+
+my $factory = TAP::Parser::IteratorFactory->new;
+my $parser = TAP::Parser->new(
+ { stream => $factory->make_iterator( tap_to_lines($tap) ),
+ }
+);
+
+# results() is sane?
+
+# check the test plan
+my $result = $parser->next();
+
+# TEST
+ok $result->is_plan, 'We should have a plan';
+
+# a normal, passing test
+
+my $test = $parser->next();
+
+# TEST
+ok $test->is_test, '... and a test';
+
+# junk lines should be preserved
+
+my $unknown = $parser->next();
+
+# TEST
+ok $unknown->is_unknown, '... and an unknown line';
+
+# a failing test, which also happens to have a directive
+
+my $failed = $parser->next();
+
+# TEST
+ok $failed->is_test, '... and another test';
+
+# comments
+
+my $comment = $parser->next();
+
+# TEST
+ok $comment->is_comment, '... and a comment';
+
+# another normal, passing test
+
+$test = $parser->next();
+
+# TEST
+ok $test->is_test, '... and another test';
+
+# a failing test
+
+$failed = $parser->next();
+
+# TEST
+ok $failed->is_test, '... and yet another test';
+
+# ok 5 # skip we have no description
+# skipped test
+my $bailout = $parser->next();
+
+# TEST
+ok $bailout->is_bailout, 'And finally we should have a bailout';
+
+# TEST
+is $bailout->as_string, 'We ran out of foobar.',
+ '... and as_string() should return the explanation';
+
+# TEST
+is( $bailout->raw, 'Bail out! We ran out of foobar.',
+ '... and raw() should return the explanation'
+);
+
+# TEST
+is( $bailout->explanation, 'We ran out of foobar.',
+ '... and it should have the correct explanation'
+);
+
+my $more_tap = "1..1\nok 1 - input file opened\n";
+
+my $second_parser = TAP::Parser->new(
+ { stream => $factory->make_iterator( [ split( /\n/, $more_tap ) ] ),
+ }
+);
+
+$result = $second_parser->next();
+
+# TEST
+ok $result->is_plan(), "Result is not the leftover line";
+
+$result = $second_parser->next();
+
+# TEST
+ok $result->is_test(), "Result is a test";
+
+# TEST
+ok $result->is_ok(), "The event has passed";
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/process.t perl-5.10.0/ext/Test/Harness/t/process.t
--- perl-5.10.0.orig/ext/Test/Harness/t/process.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/process.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,57 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+my $hires;
+
+BEGIN {
+ $hires = eval 'use Time::HiRes qw(sleep); 1';
+}
+
+use Test::More (
+ $^O eq 'VMS' ? ( skip_all => 'VMS' )
+ : $hires ? ( tests => 9 * 3 )
+ : ( skip_all => 'Need Time::HiRes' )
+);
+
+use File::Spec;
+use TAP::Parser::Iterator::Process;
+
+my @expect = (
+ '1..5',
+ 'ok 1 00000',
+ 'ok 2',
+ 'not ok 3',
+ 'ok 4',
+ 'ok 5 00000',
+);
+
+my $source = File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'delayed'
+);
+
+for my $chunk_size ( 1, 4, 65536 ) {
+ for my $where ( 0 .. 8 ) {
+
+ my $proc = TAP::Parser::Iterator::Process->new(
+ { _chunk_size => $chunk_size,
+ command => [ $^X, $source, ( 1 << $where ) ]
+ }
+ );
+
+ my @got = ();
+ while ( defined( my $line = $proc->next_raw ) ) {
+ push @got, $line;
+ }
+
+ is_deeply \@got, \@expect,
+ "I/O ok with delay at position $where, chunk size $chunk_size";
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/prove.t perl-5.10.0/ext/Test/Harness/t/prove.t
--- perl-5.10.0.orig/ext/Test/Harness/t/prove.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/prove.t 2009-03-10 17:38:43.000000000 +0100
@@ -0,0 +1,1505 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More;
+use File::Spec;
+
+use App::Prove;
+
+package FakeProve;
+use vars qw( @ISA );
+
+@ISA = qw( App::Prove );
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->{_log} = [];
+ return $self;
+}
+
+sub _color_default {0}
+
+sub _runtests {
+ my $self = shift;
+ push @{ $self->{_log} }, [ '_runtests', @_ ];
+}
+
+sub get_log {
+ my $self = shift;
+ my @log = @{ $self->{_log} };
+ $self->{_log} = [];
+ return @log;
+}
+
+sub _shuffle {
+ my $self = shift;
+ s/^/xxx/ for @_;
+}
+
+package main;
+
+sub mabs {
+ my $ar = shift;
+ return [ map { File::Spec->rel2abs($_) } @$ar ];
+}
+
+{
+ my @import_log = ();
+ sub test_log_import { push @import_log, [@_] }
+
+ sub get_import_log {
+ my @log = @import_log;
+ @import_log = ();
+ return @log;
+ }
+
+ my @plugin_load_log = ();
+ sub test_log_plugin_load { push @plugin_load_log, [@_] }
+
+ sub get_plugin_load_log {
+ my @log = @plugin_load_log;
+ @plugin_load_log = ();
+ return @log;
+ }
+}
+
+my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE );
+
+# see the "ACTUAL TEST" section at the bottom
+
+BEGIN { # START PLAN
+
+ # list of attributes
+ @ATTR = qw(
+ archive argv blib color directives exec extension failures
+ formatter harness includes lib merge parse quiet really_quiet
+ recurse backwards shuffle taint_fail taint_warn verbose
+ warnings_fail warnings_warn
+ );
+
+ # what we expect if the 'expect' hash does not define it
+ %DEFAULT_ASSERTION = map { $_ => undef } @ATTR;
+
+ $DEFAULT_ASSERTION{includes} = $DEFAULT_ASSERTION{argv}
+ = sub { 'ARRAY' eq ref shift };
+
+ my @dummy_tests = map { File::Spec->catdir( 't', 'sample-tests', $_ ) }
+ qw(simple simple_yaml);
+ my $dummy_test = $dummy_tests[0];
+
+ ########################################################################
+ # declarations - this drives all of the subtests.
+ # The cheatsheet follows.
+ # required: name, expect
+ # optional:
+ # args - arguments to constructor
+ # switches - command-line switches
+ # runlog - expected results of internal calls to _runtests, must
+ # match FakeProve's _log attr
+ # run_error - depends on 'runlog' (if missing, asserts no error)
+ # extra - follow-up check to handle exceptional cleanup / verification
+ # class - The App::Prove subclass to test. Defaults to FakeProve
+ @SCHEDULE = (
+ { name => 'Create empty',
+ expect => {}
+ },
+ { name => 'Set all options via constructor',
+ args => {
+ archive => 1,
+ argv => [qw(one two three)],
+ blib => 2,
+ color => 3,
+ directives => 4,
+ exec => 5,
+ failures => 7,
+ formatter => 8,
+ harness => 9,
+ includes => [qw(four five six)],
+ lib => 10,
+ merge => 11,
+ parse => 13,
+ quiet => 14,
+ really_quiet => 15,
+ recurse => 16,
+ backwards => 17,
+ shuffle => 18,
+ taint_fail => 19,
+ taint_warn => 20,
+ verbose => 21,
+ warnings_fail => 22,
+ warnings_warn => 23,
+ },
+ expect => {
+ archive => 1,
+ argv => [qw(one two three)],
+ blib => 2,
+ color => 3,
+ directives => 4,
+ exec => 5,
+ failures => 7,
+ formatter => 8,
+ harness => 9,
+ includes => [qw(four five six)],
+ lib => 10,
+ merge => 11,
+ parse => 13,
+ quiet => 14,
+ really_quiet => 15,
+ recurse => 16,
+ backwards => 17,
+ shuffle => 18,
+ taint_fail => 19,
+ taint_warn => 20,
+ verbose => 21,
+ warnings_fail => 22,
+ warnings_warn => 23,
+ }
+ },
+ { name => 'Call with defaults',
+ args => { argv => [qw( one two three )] },
+ expect => {},
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ # Test all options individually
+
+ # { name => 'Just archive',
+ # args => {
+ # argv => [qw( one two three )],
+ # archive => 1,
+ # },
+ # expect => {
+ # archive => 1,
+ # },
+ # runlog => [
+ # [ { archive => 1,
+ # },
+ # 'TAP::Harness',
+ # 'one', 'two',
+ # 'three'
+ # ]
+ # ],
+ # },
+ { name => 'Just argv',
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ argv => [qw( one two three )],
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0, show_count => 1 },
+ 'TAP::Harness',
+ 'one', 'two',
+ 'three'
+ ]
+ ],
+ },
+ { name => 'Just blib',
+ args => {
+ argv => [qw( one two three )],
+ blib => 1,
+ },
+ expect => {
+ blib => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just color',
+ args => {
+ argv => [qw( one two three )],
+ color => 1,
+ },
+ expect => {
+ color => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { color => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just directives',
+ args => {
+ argv => [qw( one two three )],
+ directives => 1,
+ },
+ expect => {
+ directives => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { directives => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just exec',
+ args => {
+ argv => [qw( one two three )],
+ exec => 1,
+ },
+ expect => {
+ exec => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { exec => [1],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just failures',
+ args => {
+ argv => [qw( one two three )],
+ failures => 1,
+ },
+ expect => {
+ failures => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { failures => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just formatter',
+ args => {
+ argv => [qw( one two three )],
+ formatter => 'TAP::Harness',
+ },
+ expect => {
+ formatter => 'TAP::Harness',
+ },
+ runlog => [
+ [ '_runtests',
+ { formatter_class => 'TAP::Harness',
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just includes',
+ args => {
+ argv => [qw( one two three )],
+ includes => [qw( four five six )],
+ },
+ expect => {
+ includes => [qw( four five six )],
+ },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [qw( four five six )] ),
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just lib',
+ args => {
+ argv => [qw( one two three )],
+ lib => 1,
+ },
+ expect => {
+ lib => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( ['lib'] ),
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just merge',
+ args => {
+ argv => [qw( one two three )],
+ merge => 1,
+ },
+ expect => {
+ merge => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { merge => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just parse',
+ args => {
+ argv => [qw( one two three )],
+ parse => 1,
+ },
+ expect => {
+ parse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { errors => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just quiet',
+ args => {
+ argv => [qw( one two three )],
+ quiet => 1,
+ },
+ expect => {
+ quiet => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -1,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just really_quiet',
+ args => {
+ argv => [qw( one two three )],
+ really_quiet => 1,
+ },
+ expect => {
+ really_quiet => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -2,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just recurse',
+ args => {
+ argv => [qw( one two three )],
+ recurse => 1,
+ },
+ expect => {
+ recurse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just reverse',
+ args => {
+ argv => [qw( one two three )],
+ backwards => 1,
+ },
+ expect => {
+ backwards => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'three', 'two', 'one'
+ ]
+ ],
+ },
+
+ { name => 'Just shuffle',
+ args => {
+ argv => [qw( one two three )],
+ shuffle => 1,
+ },
+ expect => {
+ shuffle => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'xxxone', 'xxxtwo',
+ 'xxxthree'
+ ]
+ ],
+ },
+ { name => 'Just taint_fail',
+ args => {
+ argv => [qw( one two three )],
+ taint_fail => 1,
+ },
+ expect => {
+ taint_fail => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-T'],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just taint_warn',
+ args => {
+ argv => [qw( one two three )],
+ taint_warn => 1,
+ },
+ expect => {
+ taint_warn => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-t'],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just verbose',
+ args => {
+ argv => [qw( one two three )],
+ verbose => 1,
+ },
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 1,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just warnings_fail',
+ args => {
+ argv => [qw( one two three )],
+ warnings_fail => 1,
+ },
+ expect => {
+ warnings_fail => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-W'],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just warnings_warn',
+ args => {
+ argv => [qw( one two three )],
+ warnings_warn => 1,
+ },
+ expect => {
+ warnings_warn => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-w'],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ # Command line parsing
+ { name => 'Switch -v',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-v', $dummy_test ],
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 1,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --verbose',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--verbose', $dummy_test ],
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 1,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -f',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-f', $dummy_test ],
+ expect => { failures => 1 },
+ runlog => [
+ [ '_runtests',
+ { failures => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --failures',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--failures', $dummy_test ],
+ expect => { failures => 1 },
+ runlog => [
+ [ '_runtests',
+ { failures => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -l',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-l', $dummy_test ],
+ expect => { lib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( ['lib'] ),
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --lib',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--lib', $dummy_test ],
+ expect => { lib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( ['lib'] ),
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -b',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-b', $dummy_test ],
+ expect => { blib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --blib',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--blib', $dummy_test ],
+ expect => { blib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -s',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-s', $dummy_test ],
+ expect => { shuffle => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ "xxx$dummy_test"
+ ]
+ ],
+ },
+
+ { name => 'Switch --shuffle',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--shuffle', $dummy_test ],
+ expect => { shuffle => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ "xxx$dummy_test"
+ ]
+ ],
+ },
+
+ { name => 'Switch -c',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-c', $dummy_test ],
+ expect => { color => 1 },
+ runlog => [
+ [ '_runtests',
+ { color => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -r',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-r', $dummy_test ],
+ expect => { recurse => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --recurse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--recurse', $dummy_test ],
+ expect => { recurse => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --reverse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--reverse', @dummy_tests ],
+ expect => { backwards => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ reverse @dummy_tests
+ ]
+ ],
+ },
+
+ { name => 'Switch -p',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-p', $dummy_test ],
+ expect => {
+ parse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { errors => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --parse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--parse', $dummy_test ],
+ expect => {
+ parse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { errors => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -q',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-q', $dummy_test ],
+ expect => { quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -1,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --quiet',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--quiet', $dummy_test ],
+ expect => { quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -1,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -Q',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-Q', $dummy_test ],
+ expect => { really_quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -2,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --QUIET',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--QUIET', $dummy_test ],
+ expect => { really_quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -2,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -m',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-m', $dummy_test ],
+ expect => { merge => 1 },
+ runlog => [
+ [ '_runtests',
+ { merge => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --merge',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--merge', $dummy_test ],
+ expect => { merge => 1 },
+ runlog => [
+ [ '_runtests',
+ { merge => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --directives',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--directives', $dummy_test ],
+ expect => { directives => 1 },
+ runlog => [
+ [ '_runtests',
+ { directives => 1,
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # Executing one word (why would it be a -s though?)
+ { name => 'Switch --exec -s',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--exec', '-s', $dummy_test ],
+ expect => { exec => '-s' },
+ runlog => [
+ [ '_runtests',
+ { exec => ['-s'],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # multi-part exec
+ { name => 'Switch --exec "/foo/bar/perl -Ilib"',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--exec', '/foo/bar/perl -Ilib', $dummy_test ],
+ expect => { exec => '/foo/bar/perl -Ilib' },
+ runlog => [
+ [ '_runtests',
+ { exec => [qw(/foo/bar/perl -Ilib)],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # null exec (run tests as compiled binaries)
+ { name => 'Switch --exec ""',
+ switches => [ '--exec', '', $dummy_test ],
+ expect => {
+ exec => # ick, must workaround the || default bit with a sub
+ sub { my $val = shift; defined($val) and !length($val) }
+ },
+ runlog => [
+ [ '_runtests',
+ { exec => [],
+ verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # Plugins
+ { name => 'Load plugin',
+ switches => [ '-P', 'Dummy', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Load plugin (args)',
+ switches => [ '-P', 'Dummy=cracking,cheese,gromit', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded,
+ [ [ 'App::Prove::Plugin::Dummy', 'cracking', 'cheese',
+ 'gromit'
+ ]
+ ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Load plugin (explicit path)',
+ switches => [ '-P', 'App::Prove::Plugin::Dummy', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Load plugin (args + call load method)',
+ switches => [ '-P', 'Dummy2=fou,du,fafa', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy2'],
+ },
+ extra => sub {
+ my @import = get_import_log();
+ is_deeply \@import,
+ [ [ 'App::Prove::Plugin::Dummy2', 'fou', 'du', 'fafa' ] ],
+ "Plugin loaded OK";
+
+ my @loaded = get_plugin_load_log();
+ is( scalar @loaded, 1, 'Plugin->load called OK' );
+ my ( $plugin_class, $args ) = @{ shift @loaded };
+ is( $plugin_class, 'App::Prove::Plugin::Dummy2',
+ 'plugin_class passed'
+ );
+ isa_ok(
+ $args->{app_prove}, 'App::Prove',
+ 'app_prove object passed'
+ );
+ is_deeply(
+ $args->{args}, [qw( fou du fafa )],
+ 'expected args passed'
+ );
+ },
+ plan => 5,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Load module',
+ switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0,
+ show_count => 1,
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # TODO
+ # Hmm, that doesn't work...
+ # { name => 'Switch -h',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-h', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ '_runtests',
+ # {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+
+ # { name => 'Switch --help',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--help', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ # { name => 'Switch -?',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-?', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch -H',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-H', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --man',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--man', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch -V',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-V', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --version',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--version', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --color!',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--color!', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ { name => 'Switch -I=s@',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-Ilib', $dummy_test ],
+ expect => {
+ includes => sub {
+ my ( $val, $attr ) = @_;
+ return
+ 'ARRAY' eq ref $val
+ && 1 == @$val
+ && $val->[0] =~ /lib$/;
+ },
+ },
+ },
+
+ # { name => 'Switch -a',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-a', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --archive=-s',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--archive=-s', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --formatter=-s',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--formatter=-s', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch -e',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-e', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --harness=-s',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--harness=-s', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+
+ );
+
+ # END SCHEDULE
+ ########################################################################
+
+ my $extra_plan = 0;
+ for my $test (@SCHEDULE) {
+ $extra_plan += $test->{plan} || 0;
+ $extra_plan += 2 if $test->{runlog};
+ $extra_plan += 1 if $test->{switches};
+ }
+
+ plan tests => @SCHEDULE * ( 3 + @ATTR ) + $extra_plan;
+} # END PLAN
+
+# ACTUAL TEST
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+ my $class = $test->{class} || 'FakeProve';
+
+ local $ENV{HARNESS_TIMER};
+
+ ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ),
+ "$name: App::Prove created OK";
+
+ isa_ok $app, 'App::Prove';
+ isa_ok $app, $class;
+
+ # Optionally parse command args
+ if ( my $switches = $test->{switches} ) {
+ eval { $app->process_args( '--norc', @$switches ) };
+ if ( my $err_pattern = $test->{parse_error} ) {
+ like $@, $err_pattern, "$name: expected parse error";
+ }
+ else {
+ ok !$@, "$name: no parse error";
+ }
+ }
+
+ my $expect = $test->{expect} || {};
+ for my $attr ( sort @ATTR ) {
+ my $val = $app->$attr();
+ my $assertion = $expect->{$attr} || $DEFAULT_ASSERTION{$attr};
+ my $is_ok = undef;
+
+ if ( 'CODE' eq ref $assertion ) {
+ $is_ok = ok $assertion->( $val, $attr ),
+ "$name: $attr has the expected value";
+ }
+ elsif ( 'Regexp' eq ref $assertion ) {
+ $is_ok = like $val, $assertion, "$name: $attr matches $assertion";
+ }
+ else {
+ $is_ok = is_deeply $val, $assertion,
+ "$name: $attr has the expected value";
+ }
+
+ unless ($is_ok) {
+ diag "got $val for $attr";
+ }
+ }
+
+ if ( my $runlog = $test->{runlog} ) {
+ eval { $app->run };
+ if ( my $err_pattern = $test->{run_error} ) {
+ like $@, $err_pattern, "$name: expected error OK";
+ pass;
+ pass for 1 .. $test->{plan};
+ }
+ else {
+ unless ( ok !$@, "$name: no error OK" ) {
+ diag "$name: error: $@\n";
+ }
+
+ my $gotlog = [ $app->get_log ];
+
+ if ( my $extra = $test->{extra} ) {
+ $extra->($gotlog);
+ }
+
+ unless (
+ is_deeply $gotlog, $runlog,
+ "$name: run results match"
+ )
+ {
+ use Data::Dumper;
+ diag Dumper( { wanted => $runlog, got => $gotlog } );
+ }
+ }
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/proveenv.t perl-5.10.0/ext/Test/Harness/t/proveenv.t
--- perl-5.10.0.orig/ext/Test/Harness/t/proveenv.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/proveenv.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,17 @@
+#!perl
+use strict;
+use lib 't/lib';
+use Test::More tests => 2;
+use App::Prove;
+
+{
+ local $ENV{HARNESS_TIMER} = 0;
+ my $prv = App::Prove->new;
+ ok !$prv->timer, 'timer set via HARNESS_TIMER';
+}
+
+{
+ local $ENV{HARNESS_TIMER} = 1;
+ my $prv = App::Prove->new;
+ ok $prv->timer, 'timer set via HARNESS_TIMER';
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/proverc.t perl-5.10.0/ext/Test/Harness/t/proverc.t
--- perl-5.10.0.orig/ext/Test/Harness/t/proverc.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/proverc.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,37 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use lib 't/lib';
+use Test::More tests => 1;
+use File::Spec;
+use App::Prove;
+
+my $prove = App::Prove->new;
+
+$prove->add_rc_file(
+ File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't', 'data',
+ 'proverc'
+ )
+);
+
+is_deeply $prove->{rc_opts},
+ [ '--should', 'be', '--split', 'correctly', 'Can', 'quote things',
+ 'using single or', 'double quotes', '--this', 'is', 'OK?'
+ ],
+ 'options parsed';
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/proverun.t perl-5.10.0/ext/Test/Harness/t/proverun.t
--- perl-5.10.0.orig/ext/Test/Harness/t/proverun.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/proverun.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,186 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More;
+use File::Spec;
+use App::Prove;
+
+my @SCHEDULE;
+
+BEGIN {
+
+ # to add a new test to proverun, just list the name of the file in
+ # t/sample-tests and a name for the test. The rest is handled
+ # automatically.
+ my @tests = (
+ { file => 'simple',
+ name => 'Create empty',
+ },
+ { file => 'todo_inline',
+ name => 'Passing TODO',
+ },
+ );
+ foreach my $test (@tests) {
+
+ # let's fully expand that filename
+ $test->{file} = File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ $test->{file}
+ );
+ }
+ @SCHEDULE = (
+ map {
+ { name => $_->{name},
+ args => [ $_->{file} ],
+ expect => [
+ [ 'new',
+ 'TAP::Parser::Iterator::Process',
+ { merge => undef,
+ command => [
+ 'PERL',
+ $_->{file},
+ ],
+ setup => \'CODE',
+ teardown => \'CODE',
+
+ }
+ ]
+ ]
+ }
+ } @tests
+ );
+
+ plan tests => @SCHEDULE * 3;
+}
+
+# Waaaaay too much boilerplate
+
+package FakeProve;
+use vars qw( @ISA );
+
+@ISA = qw( App::Prove );
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->{_log} = [];
+ return $self;
+}
+
+sub get_log {
+ my $self = shift;
+ my @log = @{ $self->{_log} };
+ $self->{_log} = [];
+ return @log;
+}
+
+package main;
+
+{
+ use TAP::Parser::Iterator::Process;
+ use TAP::Formatter::Console;
+
+ # Patch TAP::Parser::Iterator::Process
+ my @call_log = ();
+
+ local $^W; # no warnings
+
+ my $orig_new = TAP::Parser::Iterator::Process->can('new');
+
+ # Avoid "used only once" warning
+ *TAP::Parser::Iterator::Process::new
+ = *TAP::Parser::Iterator::Process::new = sub {
+ push @call_log, [ 'new', @_ ];
+
+ # And then new turns round and tramples on our args...
+ $_[1] = { %{ $_[1] } };
+ $orig_new->(@_);
+ };
+
+ # Patch TAP::Formatter::Console;
+ my $orig_output = \&TAP::Formatter::Console::_output;
+ *TAP::Formatter::Console::_output = sub {
+
+ # push @call_log, [ '_output', @_ ];
+ };
+
+ sub get_log {
+ my @log = @call_log;
+ @call_log = ();
+ return @log;
+ }
+}
+
+sub _slacken {
+ my $obj = shift;
+ if ( my $ref = ref $obj ) {
+ if ( 'HASH' eq ref $obj ) {
+ return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
+ }
+ elsif ( 'ARRAY' eq ref $obj ) {
+ return [ map { _slacken($_) } @$obj ];
+ }
+ elsif ( 'SCALAR' eq ref $obj ) {
+ return $obj;
+ }
+ else {
+ return \$ref;
+ }
+ }
+ else {
+ return $obj;
+ }
+}
+
+sub is_slackly($$$) {
+ my ( $got, $want, $msg ) = @_;
+ return is_deeply _slacken($got), _slacken($want), $msg;
+}
+
+# ACTUAL TEST
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+
+ my $app = FakeProve->new;
+ $app->process_args( '--norc', @{ $test->{args} } );
+
+ # Why does this make the output from the test spew out of
+ # our STDOUT?
+ ok eval { $app->run }, 'run returned true';
+ ok !$@, 'no errors' or diag $@;
+
+ my @log = get_log();
+
+ # Bodge: we don't know what pathname will be used for the exe so we
+ # obliterate it here. Need to test that it's sane.
+ for my $call (@log) {
+ if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
+ $call->[2]->{command}->[0] = 'PERL';
+ }
+ }
+
+ is_slackly \@log, $test->{expect}, "$name: command args OK";
+
+ # use Data::Dumper;
+ # diag Dumper(
+ # { got => \@log,
+ # expect => $test->{expect}
+ # }
+ # );
+}
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/regression.t perl-5.10.0/ext/Test/Harness/t/regression.t
--- perl-5.10.0.orig/ext/Test/Harness/t/regression.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/regression.t 2009-03-10 17:38:43.000000000 +0100
@@ -0,0 +1,3190 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+ else {
+ push @INC, 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More 'no_plan';
+
+use File::Spec;
+use Config;
+
+use constant TRUE => "__TRUE__";
+use constant FALSE => "__FALSE__";
+
+# if wait() is non-zero, we cannot reliably predict its value
+use constant NOT_ZERO => "__NOT_ZERO__";
+
+use TAP::Parser;
+
+my $IsVMS = $^O eq 'VMS';
+my $IsWin32 = $^O eq 'MSWin32';
+
+my $SAMPLE_TESTS = File::Spec->catdir(
+ File::Spec->curdir,
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'sample-tests'
+);
+
+my %deprecated = map { $_ => 1 } qw(
+ TAP::Parser::good_plan
+ TAP::Parser::Result::Plan::passed
+ TAP::Parser::Result::Test::passed
+ TAP::Parser::Result::Test::actual_passed
+ TAP::Parser::Result::passed
+);
+$SIG{__WARN__} = sub {
+ if ( $_[0] =~ /is deprecated/ ) {
+ my @caller = caller(1);
+ my $sub = $caller[3];
+ ok exists $deprecated{$sub},
+ "... we should get a deprecated warning for $sub";
+ }
+ else {
+ CORE::warn @_;
+ }
+};
+
+# the %samples keys are the names of test scripts in t/sample-tests
+my %samples = (
+ descriptive => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "Interlock activated",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "Megathrusters are go",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "Head formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "Blazing sword formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "Robeast destroyed",
+ is_unplanned => FALSE,
+ }
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ descriptive_trailing => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "Interlock activated",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "Megathrusters are go",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "Head formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "Blazing sword formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "Robeast destroyed",
+ is_unplanned => FALSE,
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ empty => {
+ results => [],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ is_good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 0,
+ parse_errors => ['No plan found in TAP output'],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ simple => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ space_after_plan => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5 ',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ simple_yaml => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { is_yaml => TRUE,
+ data => [
+ { 'fnurk' => 'skib', 'ponk' => 'gleeb' },
+ { 'bar' => 'krup', 'foo' => 'plink' }
+ ],
+ raw =>
+ " ---\n -\n fnurk: skib\n ponk: gleeb\n -\n bar: krup\n foo: plink\n ...",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { is_yaml => TRUE,
+ data => {
+ 'got' => [ '1', 'pong', '4' ],
+ 'expected' => [ '1', '2', '4' ]
+ },
+ raw =>
+ " ---\n expected:\n - 1\n - 2\n - 4\n got:\n - 1\n - pong\n - 4\n ...",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 13,
+ },
+ simple_fail => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1, 3, 4 ],
+ actual_passed => [ 1, 3, 4 ],
+ failed => [ 2, 5 ],
+ actual_failed => [ 2, 5 ],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ skip => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => TRUE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ explanation => 'rain delay',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [2],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ skip_nomsg => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => TRUE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ ],
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [1],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ todo_inline => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..3',
+ tests_planned => 3,
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 1,
+ description => "- Foo",
+ explanation => 'Just testing the todo interface.',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 2,
+ description => "- Unexpected success",
+ explanation => 'Just testing the todo interface.',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "- This is not todo",
+ explanation => '',
+ },
+ ],
+ plan => '1..3',
+ passed => [ 1, 2, 3 ],
+ actual_passed => [ 2, 3 ],
+ failed => [],
+ actual_failed => [1],
+ todo => [ 1, 2 ],
+ todo_passed => [2],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 3,
+ tests_run => 3,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ todo => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..5 todo 3 2;',
+ tests_planned => 5,
+ todo_list => [ 3, 2 ],
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 2,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 3,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ explanation => '',
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1, 2, 3, 4, 5 ],
+ actual_passed => [ 1, 2, 4, 5 ],
+ failed => [],
+ actual_failed => [3],
+ todo => [ 2, 3 ],
+ todo_passed => [2],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ duplicates => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..10',
+ tests_planned => 10,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 7,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 8,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 9,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 10,
+ description => '',
+ explanation => '',
+ is_unplanned => TRUE,
+ },
+ ],
+ plan => '1..10',
+ passed => [ 1 .. 4, 4 .. 9 ],
+ actual_passed => [ 1 .. 4, 4 .. 10 ],
+ failed => [10],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 10,
+ tests_run => 11,
+ parse_errors => [
+ 'Tests out of sequence. Found (4) but expected (5)',
+ 'Tests out of sequence. Found (5) but expected (6)',
+ 'Tests out of sequence. Found (6) but expected (7)',
+ 'Tests out of sequence. Found (7) but expected (8)',
+ 'Tests out of sequence. Found (8) but expected (9)',
+ 'Tests out of sequence. Found (9) but expected (10)',
+ 'Tests out of sequence. Found (10) but expected (11)',
+ 'Bad plan. You planned 10 tests but ran 11.',
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ no_nums => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ }
+ ],
+ plan => '1..5',
+ passed => [ 1, 2, 4, 5 ],
+ actual_passed => [ 1, 2, 4, 5 ],
+ failed => [3],
+ actual_failed => [3],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ bailout => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { is_bailout => TRUE,
+ explanation => "GERONIMMMOOOOOO!!!",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ }
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ no_output => {
+ results => [],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 0,
+ parse_errors => [ 'No plan found in TAP output', ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ too_many => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..3',
+ tests_planned => 3,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 7,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ ],
+ plan => '1..3',
+ passed => [ 1 .. 3 ],
+ actual_passed => [ 1 .. 7 ],
+ failed => [ 4 .. 7 ],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 3,
+ tests_run => 7,
+ parse_errors => ['Bad plan. You planned 3 tests but ran 7.'],
+ 'exit' => 4,
+ wait => NOT_ZERO,
+ skip_if => sub {$IsVMS},
+ },
+ taint => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "- -T honored",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ ],
+ plan => '1..1',
+ passed => [ 1 .. 1 ],
+ actual_passed => [ 1 .. 1 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => TRUE,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ 'die' => {
+ results => [],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 0,
+ parse_errors => [ 'No plan found in TAP output', ],
+ 'exit' => NOT_ZERO,
+ wait => NOT_ZERO,
+ },
+ die_head_end => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 4,
+ parse_errors => [ 'No plan found in TAP output', ],
+ 'exit' => NOT_ZERO,
+ wait => NOT_ZERO,
+ },
+ die_last_minute => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => NOT_ZERO,
+ wait => NOT_ZERO,
+ },
+ bignum => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 136211425,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 136211426,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1, 2 ],
+ actual_passed => [ 1, 2, 136211425, 136211426 ],
+ failed => [ 136211425, 136211426 ],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 2,
+ tests_run => 4,
+ parse_errors => [
+ 'Tests out of sequence. Found (136211425) but expected (3)',
+ 'Tests out of sequence. Found (136211426) but expected (4)',
+ 'Bad plan. You planned 2 tests but ran 4.'
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ bignum_many => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 99997,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 99998,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 99999,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100000,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100001,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100002,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100003,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100004,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100005,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1, 2 ],
+ actual_passed => [ 1, 2, 99997 .. 100005 ],
+ failed => [ 99997 .. 100005 ],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 2,
+ tests_run => 11,
+ parse_errors => [
+ 'Tests out of sequence. Found (99997) but expected (3)',
+ 'Tests out of sequence. Found (99998) but expected (4)',
+ 'Tests out of sequence. Found (99999) but expected (5)',
+ 'Tests out of sequence. Found (100000) but expected (6)',
+ 'Tests out of sequence. Found (100001) but expected (7)',
+ 'Tests out of sequence. Found (100002) but expected (8)',
+ 'Tests out of sequence. Found (100003) but expected (9)',
+ 'Tests out of sequence. Found (100004) but expected (10)',
+ 'Tests out of sequence. Found (100005) but expected (11)',
+ 'Bad plan. You planned 2 tests but ran 11.'
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ combined => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..10',
+ tests_planned => 10,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => 'basset hounds got long ears',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => 'all hell broke loose',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 4,
+ description => '',
+ explanation => 'if I heard a voice from heaven ...',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => 'say "live without loving",',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => "I'd beg off.",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => '1',
+ has_todo => FALSE,
+ number => 7,
+ description => '',
+ explanation => 'contract negotiations',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 8,
+ description => 'Girls are such exquisite hell',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 9,
+ description => 'Elegy 9B',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 10,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '1..10',
+ passed => [ 1 .. 2, 4 .. 9 ],
+ actual_passed => [ 1 .. 2, 5 .. 9 ],
+ failed => [ 3, 10 ],
+ actual_failed => [ 3, 4, 10 ],
+ todo => [ 4, 9 ],
+ todo_passed => [9],
+ skipped => [7],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 10,
+ tests_run => 10,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ head_end => {
+ results => [
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comments',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comment',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'more ignored stuff',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'and yet more',
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ head_fail => {
+ results => [
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comments',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comment',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'more ignored stuff',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'and yet more',
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1, 3, 4 ],
+ actual_passed => [ 1, 3, 4 ],
+ failed => [2],
+ actual_failed => [2],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ out_of_order => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '- Test that argument passing works',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description =>
+ '- Test that passing arguments as references work',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '- Test a normal sub',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => '- Detach test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 8,
+ description => '- Nested thread test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 9,
+ description => '- Nested thread test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 10,
+ description => '- Wanted 7, got 7',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 11,
+ description => '- Wanted 7, got 7',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 12,
+ description => '- Wanted 8, got 8',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 13,
+ description => '- Wanted 8, got 8',
+ explanation => '',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..15',
+ tests_planned => 15,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => '- Check that Config::threads is true',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 7,
+ description => '- Detach test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 14,
+ description =>
+ '- Check so that tid for threads work for main thread',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 15,
+ description =>
+ '- Check so that tid for threads work for main thread',
+ explanation => '',
+ },
+ ],
+ plan => '1..15',
+ passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ],
+ actual_passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ is_good_plan => FALSE,
+ tests_planned => 15,
+ tests_run => 15,
+
+ # Note that tests 14 and 15 *are* in the correct sequence.
+ parse_errors => [
+ 'Tests out of sequence. Found (2) but expected (1)',
+ 'Tests out of sequence. Found (3) but expected (2)',
+ 'Tests out of sequence. Found (4) but expected (3)',
+ 'Tests out of sequence. Found (6) but expected (4)',
+ 'Tests out of sequence. Found (8) but expected (5)',
+ 'Tests out of sequence. Found (9) but expected (6)',
+ 'Tests out of sequence. Found (10) but expected (7)',
+ 'Tests out of sequence. Found (11) but expected (8)',
+ 'Tests out of sequence. Found (12) but expected (9)',
+ 'Tests out of sequence. Found (13) but expected (10)',
+ 'Plan (1..15) must be at the beginning or end of the TAP output',
+ 'Tests out of sequence. Found (1) but expected (11)',
+ 'Tests out of sequence. Found (5) but expected (12)',
+ 'Tests out of sequence. Found (7) but expected (13)',
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ skipall => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..0 # skipping: rope',
+ tests_planned => 0,
+ passed => TRUE,
+ is_ok => TRUE,
+ directive => 'SKIP',
+ explanation => ''
+ },
+ ],
+ plan => '1..0',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 0,
+ tests_run => 0,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ skip_all => '(no reason given)',
+ },
+ skipall_v13 => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_unknown => TRUE,
+ raw => '1..0 # skipping: rope',
+ },
+ ],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ is_good_plan => FALSE,
+ tests_planned => FALSE,
+ tests_run => 0,
+ parse_errors => ['No plan found in TAP output'],
+ 'exit' => 0,
+ wait => 0,
+ version => 13,
+ },
+ strict => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_plan => TRUE,
+ raw => '1..1',
+ },
+ { is_pragma => TRUE,
+ raw => 'pragma +strict',
+ pragmas => ['+strict'],
+ },
+ { is_unknown => TRUE, raw => 'Nonsense!',
+ },
+ { is_pragma => TRUE,
+ raw => 'pragma -strict',
+ pragmas => ['-strict'],
+ },
+ { is_unknown => TRUE,
+ raw => "Doesn't matter.",
+ },
+ { is_test => TRUE,
+ raw => 'ok 1 All OK',
+ }
+ ],
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => 1,
+ parse_errors => ['Unknown TAP token: "Nonsense!"'],
+ 'exit' => 0, # TODO: Is this right???
+ wait => 0,
+ version => 13,
+ },
+ skipall_nomsg => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..0',
+ tests_planned => 0,
+ passed => TRUE,
+ is_ok => TRUE,
+ directive => 'SKIP',
+ explanation => ''
+ },
+ ],
+ plan => '1..0',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 0,
+ tests_run => 0,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ skip_all => '(no reason given)',
+ },
+ todo_misparse => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..1',
+ tests_planned => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => 'Hamlette # TODOORNOTTODO',
+ explanation => '',
+ },
+ ],
+ plan => '1..1',
+ passed => [],
+ actual_passed => [],
+ failed => [1],
+ actual_failed => [1],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => TRUE,
+ tests_run => 1,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ shbang_misparse => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1 .. 2 ],
+ actual_passed => [ 1 .. 2 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 2,
+ tests_run => 2,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ switches => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ ],
+ __ARGS__ => { switches => ['-Mstrict'] },
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ inc_taint => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ ],
+ __ARGS__ => { switches => ['-Iexamples'] },
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ sequence_misparse => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "\# skipped on foobar system",
+ },
+ { is_comment => TRUE,
+ comment => '1234567890123456789012345678901234567890',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { is_comment => TRUE,
+ comment => '1234567890123456789012345678901234567890',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+
+ # For some reason mixing stdout with stderr is unreliable on Windows
+ ( $IsWin32
+ ? ()
+ : ( stdout_stderr => {
+ results => [
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comments',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comment',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'more ignored stuff',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'and yet more',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ need_open3 => 1,
+ }
+ )
+ ),
+
+ junk_before_plan => {
+ results => [
+ { is_unknown => TRUE,
+ raw => 'this is junk',
+ },
+ { is_comment => TRUE,
+ comment => "this is a comment",
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ ],
+ plan => '1..1',
+ passed => [ 1 .. 1 ],
+ actual_passed => [ 1 .. 1 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => 1,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ version_good => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 13,
+ },
+ version_old => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 12',
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors =>
+ ['Explicit TAP version must be at least 13. Got version 12'],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ version_late => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors =>
+ ['If TAP version is present it must be the first line of output'],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+
+ escape_eol => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description =>
+ 'Should parse as literal backslash --> \\',
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => 'Not a continuation line',
+ is_unplanned => FALSE,
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1 .. 2 ],
+ actual_passed => [ 1 .. 2 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 2,
+ tests_run => 2,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+
+ escape_hash => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..3',
+ tests_planned => 3,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => 'Not a \\# TODO',
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => 'Not a \\# SKIP',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => 'Escaped \\\\\\#',
+ is_unplanned => FALSE,
+ },
+ ],
+ plan => '1..3',
+ passed => [ 1 .. 3 ],
+ actual_passed => [ 1 .. 3 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 3,
+ tests_run => 3,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+);
+
+my %HANDLER_FOR = (
+ NOT_ZERO, sub { local $^W; 0 != shift },
+ TRUE, sub { local $^W; !!shift },
+ FALSE, sub { local $^W; !shift },
+);
+
+my $can_open3 = ( $Config{d_fork} || $IsWin32 ) ? 1 : 0;
+
+for my $hide_fork ( 0 .. $can_open3 ) {
+ if ($hide_fork) {
+ no strict 'refs';
+ local $^W = 0;
+ *{'TAP::Parser::Iterator::Process::_use_open3'} = sub {return};
+ }
+
+ TEST:
+ for my $test ( sort keys %samples ) {
+
+ #next unless 'empty' eq $test;
+ my %details = %{ $samples{$test} };
+
+ if ( my $skip_if = delete $details{skip_if} ) {
+ next TEST if $skip_if->();
+ }
+
+ my $results = delete $details{results};
+ my $args = delete $details{__ARGS__};
+ my $need_open3 = delete $details{need_open3};
+
+ next TEST if $need_open3 && ( $hide_fork || !$can_open3 );
+
+ # the following acrobatics are necessary to make it easy for the
+ # Test::Builder::failure_output() method to be overridden when
+ # TAP::Parser is not installed. Otherwise, these tests will fail.
+
+ unshift @{ $args->{switches} },
+ $ENV{PERL_CORE} ? ( map {"-I$_"} @INC ) : ('-It/lib');
+
+ $args->{source} = File::Spec->catfile( $SAMPLE_TESTS, $test );
+ $args->{merge} = !$hide_fork;
+
+ my $parser = eval { analyze_test( $test, [@$results], $args ) };
+ my $error = $@;
+ ok !$error, "'$test' should parse successfully"
+ or diag $error;
+
+ if ($error) {
+ my $tests = 0;
+ while ( my ( $method, $answer ) = each %details ) {
+ $tests += ref $answer ? 2 : 1;
+ }
+ SKIP: {
+ skip "$test did not parse successfully", $tests;
+ }
+ }
+ else {
+ while ( my ( $method, $answer ) = each %details ) {
+ if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck
+ ok $handler->( $parser->$method() ),
+ "... and $method should return a reasonable value ($test)";
+ }
+ elsif ( !ref $answer ) {
+ local $^W; # uninit warnings
+
+ $answer = _vmsify_answer( $method, $answer );
+
+ is $parser->$method(), $answer,
+ "... and $method should equal $answer ($test)";
+ }
+ else {
+ is scalar $parser->$method(), scalar @$answer,
+ "... and $method should be the correct amount ($test)";
+ is_deeply [ $parser->$method() ], $answer,
+ "... and $method should be the correct values ($test)";
+ }
+ }
+ }
+ }
+}
+
+my %Unix2VMS_Exit_Codes = ( 1 => 4, );
+
+sub _vmsify_answer {
+ my ( $method, $answer ) = @_;
+
+ return $answer unless $IsVMS;
+
+ if ( $method eq 'exit'
+ and exists $Unix2VMS_Exit_Codes{$answer} )
+ {
+ $answer = $Unix2VMS_Exit_Codes{$answer};
+ }
+
+ return $answer;
+}
+
+sub analyze_test {
+ my ( $test, $results, $args ) = @_;
+
+ my $parser = TAP::Parser->new($args);
+ my $count = 1;
+ while ( defined( my $result = $parser->next ) ) {
+
+ my $expected = shift @$results;
+ my $desc
+ = $result->is_test
+ ? $result->description
+ : $result->raw;
+ $desc = $result->plan
+ if $result->is_plan && $desc =~ /SKIP/i;
+ $desc =~ s/#/<hash>/g;
+ $desc =~ s/\s+/ /g; # Drop newlines
+ ok defined $expected,
+ "$test/$count We should have a result for $desc";
+ while ( my ( $method, $answer ) = each %$expected ) {
+
+ if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck
+ ok $handler->( $result->$method() ),
+ "... and $method should return a reasonable value ($test/$count)";
+ }
+ elsif ( ref $answer ) {
+ is_deeply scalar( $result->$method() ), $answer,
+ "... and $method should return the correct structure ($test/$count)";
+ }
+ else {
+ is $result->$method(), $answer,
+ "... and $method should return the correct answer ($test/$count)";
+ }
+ }
+ $count++;
+ }
+ is @$results, 0,
+ "... and we should have the correct number of results ($test)";
+ return $parser;
+}
+
+# vms_nit
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/results.t perl-5.10.0/ext/Test/Harness/t/results.t
--- perl-5.10.0.orig/ext/Test/Harness/t/results.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/results.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,295 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 227;
+
+use TAP::Parser::ResultFactory;
+use TAP::Parser::Result;
+
+use constant RESULT => 'TAP::Parser::Result';
+use constant PLAN => 'TAP::Parser::Result::Plan';
+use constant TEST => 'TAP::Parser::Result::Test';
+use constant COMMENT => 'TAP::Parser::Result::Comment';
+use constant BAILOUT => 'TAP::Parser::Result::Bailout';
+use constant UNKNOWN => 'TAP::Parser::Result::Unknown';
+
+my $warning;
+$SIG{__WARN__} = sub { $warning = shift };
+
+#
+# Note that the are basic unit tests. More comprehensive path coverage is
+# found in the regression tests.
+#
+
+my $factory = TAP::Parser::ResultFactory->new;
+my %inherited_methods = (
+ is_plan => '',
+ is_test => '',
+ is_comment => '',
+ is_bailout => '',
+ is_unknown => '',
+ is_ok => 1,
+);
+
+my $abstract_class = bless { type => 'no_such_type' },
+ RESULT; # you didn't see this
+run_method_tests( $abstract_class, {} ); # check the defaults
+
+can_ok $abstract_class, 'type';
+is $abstract_class->type, 'no_such_type',
+ '... and &type should return the correct result';
+
+can_ok $abstract_class, 'passed';
+$warning = '';
+ok $abstract_class->passed, '... and it should default to true';
+like $warning, qr/^\Qpassed() is deprecated. Please use "is_ok()"/,
+ '... but it should emit a deprecation warning';
+
+can_ok RESULT, 'new';
+
+can_ok $factory, 'make_result';
+eval { $factory->make_result( { type => 'no_such_type' } ) };
+ok my $error = $@, '... and calling it with an unknown class should fail';
+like $error, qr/^Could not determine class for.*no_such_type/s,
+ '... with an appropriate error message';
+
+# register new Result types:
+can_ok $factory, 'class_for';
+can_ok $factory, 'register_type';
+{
+
+ package MyResult;
+ use strict;
+ use vars qw($VERSION @ISA);
+ @ISA = 'TAP::Parser::Result';
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+}
+
+{
+ my $r = eval { $factory->make_result( { type => 'my_type' } ) };
+ my $error = $@;
+ isa_ok( $r, 'MyResult', 'register custom type' );
+ ok( !$error, '... and no error' );
+}
+
+#
+# test unknown tokens
+#
+
+run_tests(
+ { class => UNKNOWN,
+ data => {
+ type => 'unknown',
+ raw => '... this line is junk ... ',
+ },
+ },
+ { is_unknown => 1,
+ raw => '... this line is junk ... ',
+ as_string => '... this line is junk ... ',
+ type => 'unknown',
+ has_directive => '',
+ }
+);
+
+#
+# test comment tokens
+#
+
+run_tests(
+ { class => COMMENT,
+ data => {
+ type => 'comment',
+ raw => '# this is a comment',
+ comment => 'this is a comment',
+ },
+ },
+ { is_comment => 1,
+ raw => '# this is a comment',
+ as_string => '# this is a comment',
+ comment => 'this is a comment',
+ type => 'comment',
+ has_directive => '',
+ }
+);
+
+#
+# test bailout tokens
+#
+
+run_tests(
+ { class => BAILOUT,
+ data => {
+ type => 'bailout',
+ raw => 'Bailout! This blows!',
+ bailout => 'This blows!',
+ },
+ },
+ { is_bailout => 1,
+ raw => 'Bailout! This blows!',
+ as_string => 'This blows!',
+ type => 'bailout',
+ has_directive => '',
+ }
+);
+
+#
+# test plan tokens
+#
+
+run_tests(
+ { class => PLAN,
+ data => {
+ type => 'plan',
+ raw => '1..20',
+ tests_planned => 20,
+ directive => '',
+ explanation => '',
+ },
+ },
+ { is_plan => 1,
+ raw => '1..20',
+ tests_planned => 20,
+ directive => '',
+ explanation => '',
+ has_directive => '',
+ }
+);
+
+run_tests(
+ { class => PLAN,
+ data => {
+ type => 'plan',
+ raw => '1..0 # SKIP help me, Rhonda!',
+ tests_planned => 0,
+ directive => 'SKIP',
+ explanation => 'help me, Rhonda!',
+ },
+ },
+ { is_plan => 1,
+ raw => '1..0 # SKIP help me, Rhonda!',
+ tests_planned => 0,
+ directive => 'SKIP',
+ explanation => 'help me, Rhonda!',
+ has_directive => 1,
+ }
+);
+
+#
+# test 'test' tokens
+#
+
+my $test = run_tests(
+ { class => TEST,
+ data => {
+ ok => 'ok',
+ test_num => 5,
+ description => '... and this test is fine',
+ directive => '',
+ explanation => '',
+ raw => 'ok 5 and this test is fine',
+ type => 'test',
+ },
+ },
+ { is_test => 1,
+ type => 'test',
+ ok => 'ok',
+ number => 5,
+ description => '... and this test is fine',
+ directive => '',
+ explanation => '',
+ is_ok => 1,
+ is_actual_ok => 1,
+ todo_passed => '',
+ has_skip => '',
+ has_todo => '',
+ as_string => 'ok 5 ... and this test is fine',
+ is_unplanned => '',
+ has_directive => '',
+ }
+);
+
+can_ok $test, 'actual_passed';
+$warning = '';
+is $test->actual_passed, $test->is_actual_ok,
+ '... and it should return the correct value';
+like $warning,
+ qr/^\Qactual_passed() is deprecated. Please use "is_actual_ok()"/,
+ '... but issue a deprecation warning';
+
+can_ok $test, 'todo_failed';
+$warning = '';
+is $test->todo_failed, $test->todo_passed,
+ '... and it should return the correct value';
+like $warning,
+ qr/^\Qtodo_failed() is deprecated. Please use "todo_passed()"/,
+ '... but issue a deprecation warning';
+
+# TODO directive
+
+$test = run_tests(
+ { class => TEST,
+ data => {
+ ok => 'not ok',
+ test_num => 5,
+ description => '... and this test is fine',
+ directive => 'TODO',
+ explanation => 'why not?',
+ raw => 'not ok 5 and this test is fine # TODO why not?',
+ type => 'test',
+ },
+ },
+ { is_test => 1,
+ type => 'test',
+ ok => 'not ok',
+ number => 5,
+ description => '... and this test is fine',
+ directive => 'TODO',
+ explanation => 'why not?',
+ is_ok => 1,
+ is_actual_ok => '',
+ todo_passed => '',
+ has_skip => '',
+ has_todo => 1,
+ as_string =>
+ 'not ok 5 ... and this test is fine # TODO why not?',
+ is_unplanned => '',
+ has_directive => 1,
+ }
+);
+
+sub run_tests {
+ my ( $instantiated, $value_for ) = @_;
+ my $result = instantiate($instantiated);
+ run_method_tests( $result, $value_for );
+ return $result;
+}
+
+sub instantiate {
+ my $instantiated = shift;
+ my $class = $instantiated->{class};
+ ok my $result = $factory->make_result( $instantiated->{data} ),
+ 'Creating $class results should succeed';
+ isa_ok $result, $class, '.. and the object it returns';
+ return $result;
+}
+
+sub run_method_tests {
+ my ( $result, $value_for ) = @_;
+ while ( my ( $method, $default ) = each %inherited_methods ) {
+ can_ok $result, $method;
+ if ( defined( my $value = delete $value_for->{$method} ) ) {
+ is $result->$method(), $value,
+ "... and $method should be correct";
+ }
+ else {
+ is $result->$method(), $default,
+ "... and $method default should be correct";
+ }
+ }
+ while ( my ( $method, $value ) = each %$value_for ) {
+ can_ok $result, $method;
+ is $result->$method(), $value, "... and $method should be correct";
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/bailout perl-5.10.0/ext/Test/Harness/t/sample-tests/bailout
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/bailout 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/bailout 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,11 @@
+# Sleep makes Mac OS open3 race problem more repeatable
+sleep 1;
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+Bail out! GERONIMMMOOOOOO!!!
+ok 4
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/bignum perl-5.10.0/ext/Test/Harness/t/sample-tests/bignum
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/bignum 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/bignum 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,7 @@
+print <<DUMMY;
+1..2
+ok 1
+ok 2
+ok 136211425
+ok 136211426
+DUMMY
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/bignum_many perl-5.10.0/ext/Test/Harness/t/sample-tests/bignum_many
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/bignum_many 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/bignum_many 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,14 @@
+print <<DUMMY;
+1..2
+ok 1
+ok 2
+ok 99997
+ok 99998
+ok 99999
+ok 100000
+ok 100001
+ok 100002
+ok 100003
+ok 100004
+ok 100005
+DUMMY
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/combined perl-5.10.0/ext/Test/Harness/t/sample-tests/combined
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/combined 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/combined 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,13 @@
+print <<DUMMY_TEST;
+1..10
+ok 1
+ok 2 basset hounds got long ears
+not ok 3 all hell broke loose
+not ok 4 # TODO if I heard a voice from heaven ...
+ok say "live without loving",
+ok 6 I'd beg off.
+ok 7 # Skip contract negotiations
+ok 8 Girls are such exquisite hell
+ok 9 Elegy 9B # TOdO
+not ok 10
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/combined_compat perl-5.10.0/ext/Test/Harness/t/sample-tests/combined_compat
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/combined_compat 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/combined_compat 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,13 @@
+print <<DUMMY_TEST;
+1..10 todo 4 10
+ok 1
+ok 2 basset hounds got long ears
+not ok 3 all hell broke lose
+ok 4
+ok
+ok 6
+ok 7 # Skip contract negociations
+ok 8
+not ok 9
+not ok 10
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/delayed perl-5.10.0/ext/Test/Harness/t/sample-tests/delayed
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/delayed 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/delayed 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,32 @@
+# Used to test Process.pm
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ }
+}
+
+use Time::HiRes qw(sleep);
+
+my $delay = 0.01;
+
+$| = 1;
+
+my @parts = (
+ "1.",
+ ".5\n",
+ "ok 1 00000\n",
+ "ok 2\nnot",
+ " ok 3",
+ "\nok 4\nok ",
+ "5 00000",
+ ""
+);
+
+my $delay_at = shift || 0;
+
+while (@parts) {
+ sleep $delay if ( $delay_at & 1 );
+ $delay_at >>= 1;
+ print shift @parts;
+}
+sleep $delay if ( $delay_at & 1 );
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/descriptive perl-5.10.0/ext/Test/Harness/t/sample-tests/descriptive
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/descriptive 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/descriptive 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1 Interlock activated
+ok 2 Megathrusters are go
+ok 3 Head formed
+ok 4 Blazing sword formed
+ok 5 Robeast destroyed
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/descriptive_trailing perl-5.10.0/ext/Test/Harness/t/sample-tests/descriptive_trailing
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/descriptive_trailing 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/descriptive_trailing 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+ok 1 Interlock activated
+ok 2 Megathrusters are go
+ok 3 Head formed
+ok 4 Blazing sword formed
+ok 5 Robeast destroyed
+1..5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die perl-5.10.0/ext/Test/Harness/t/sample-tests/die
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/die 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,2 @@
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
+exit 1; # exit because die() can be noisy
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die_head_end perl-5.10.0/ext/Test/Harness/t/sample-tests/die_head_end
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die_head_end 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/die_head_end 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+ok 1
+ok 2
+ok 3
+ok 4
+DUMMY_TEST
+
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
+exit 1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die_last_minute perl-5.10.0/ext/Test/Harness/t/sample-tests/die_last_minute
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die_last_minute 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/die_last_minute 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,10 @@
+print <<DUMMY_TEST;
+ok 1
+ok 2
+ok 3
+ok 4
+1..4
+DUMMY_TEST
+
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
+exit 1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die_unfinished perl-5.10.0/ext/Test/Harness/t/sample-tests/die_unfinished
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/die_unfinished 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/die_unfinished 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+1..4
+ok 1
+ok 2
+ok 3
+DUMMY_TEST
+
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
+exit 1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/duplicates perl-5.10.0/ext/Test/Harness/t/sample-tests/duplicates
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/duplicates 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/duplicates 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,14 @@
+print <<DUMMY_TEST
+1..10
+ok 1
+ok 2
+ok 3
+ok 4
+ok 4
+ok 5
+ok 6
+ok 7
+ok 8
+ok 9
+ok 10
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/echo perl-5.10.0/ext/Test/Harness/t/sample-tests/echo
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/echo 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/echo 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,2 @@
+print '1..', scalar(@ARGV), "\n";
+print "ok $_ ", $ARGV[ $_ - 1 ], "\n" for 1 .. @ARGV;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/empty perl-5.10.0/ext/Test/Harness/t/sample-tests/empty
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/empty 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/empty 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,2 @@
+__END__
+Used to exercise the "empty test" case.
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/escape_eol perl-5.10.0/ext/Test/Harness/t/sample-tests/escape_eol
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/escape_eol 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/escape_eol 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,5 @@
+print <<DUMMY_TEST;
+1..2
+ok 1 Should parse as literal backslash --> \\
+ok 2 Not a continuation line
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/escape_hash perl-5.10.0/ext/Test/Harness/t/sample-tests/escape_hash
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/escape_hash 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/escape_hash 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,6 @@
+print <<DUMMY_TEST;
+1..3
+ok 1 Not a \\# TODO
+ok 2 Not a \\# SKIP
+ok 3 Escaped \\\\\\#
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/head_end perl-5.10.0/ext/Test/Harness/t/sample-tests/head_end
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/head_end 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/head_end 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,11 @@
+print <<DUMMY_TEST;
+# comments
+ok 1
+ok 2
+ok 3
+ok 4
+# comment
+1..4
+# more ignored stuff
+# and yet more
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/head_fail perl-5.10.0/ext/Test/Harness/t/sample-tests/head_fail
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/head_fail 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/head_fail 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,11 @@
+print <<DUMMY_TEST;
+# comments
+ok 1
+not ok 2
+ok 3
+ok 4
+# comment
+1..4
+# more ignored stuff
+# and yet more
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/inc_taint perl-5.10.0/ext/Test/Harness/t/sample-tests/inc_taint
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/inc_taint 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/inc_taint 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,6 @@
+#!/usr/bin/perl -Tw
+
+use Test::More tests => 1;
+
+ok( grep( /examples/, @INC ) );
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/junk_before_plan perl-5.10.0/ext/Test/Harness/t/sample-tests/junk_before_plan
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/junk_before_plan 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/junk_before_plan 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,6 @@
+print <<DUMMY_TEST;
+this is junk
+# this is a comment
+1..1
+ok 1
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/lone_not_bug perl-5.10.0/ext/Test/Harness/t/sample-tests/lone_not_bug
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/lone_not_bug 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/lone_not_bug 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+# There was a bug where the first test would be considered a
+# 'lone not' failure.
+print <<DUMMY;
+ok 1
+ok 2
+ok 3
+ok 4
+1..4
+DUMMY
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/no_nums perl-5.10.0/ext/Test/Harness/t/sample-tests/no_nums
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/no_nums 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/no_nums 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok
+ok
+not ok
+ok
+ok
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/no_output perl-5.10.0/ext/Test/Harness/t/sample-tests/no_output
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/no_output 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/no_output 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,3 @@
+#!/usr/bin/perl -w
+
+exit;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/out_err_mix perl-5.10.0/ext/Test/Harness/t/sample-tests/out_err_mix
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/out_err_mix 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/out_err_mix 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,13 @@
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+_autoflush( \*STDOUT );
+_autoflush( \*STDERR );
+
+print STDOUT "one\n";
+print STDERR "two\n\n";
+print STDOUT "three\n";
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/out_of_order perl-5.10.0/ext/Test/Harness/t/sample-tests/out_of_order
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/out_of_order 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/out_of_order 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,22 @@
+# From a bungled core thread test.
+#
+# The important thing here is that the last test is the right test.
+# Test::Harness would misparse this as being a valid test.
+print <<DUMMY;
+ok 2 - Test that argument passing works
+ok 3 - Test that passing arguments as references work
+ok 4 - Test a normal sub
+ok 6 - Detach test
+ok 8 - Nested thread test
+ok 9 - Nested thread test
+ok 10 - Wanted 7, got 7
+ok 11 - Wanted 7, got 7
+ok 12 - Wanted 8, got 8
+ok 13 - Wanted 8, got 8
+1..15
+ok 1
+ok 5 - Check that Config::threads is true
+ok 7 - Detach test
+ok 14 - Check so that tid for threads work for main thread
+ok 15 - Check so that tid for threads work for main thread
+DUMMY
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/schwern perl-5.10.0/ext/Test/Harness/t/sample-tests/schwern
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/schwern 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/schwern 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,3 @@
+use Test::More;
+plan tests => 1;
+ok 23, 42;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/schwern-todo-quiet perl-5.10.0/ext/Test/Harness/t/sample-tests/schwern-todo-quiet
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/schwern-todo-quiet 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/schwern-todo-quiet 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,13 @@
+print <<DUMMY_TEST;
+1..3
+ok 1
+not ok 2
+# Failed test at ../../andy/schwern.pl line 17.
+# got: '23'
+# expected: '42'
+not ok 3 # TODO Roman numerials still not a built in type
+# Failed (TODO) test at ../../andy/schwern.pl line 20.
+# got: 'XXIII'
+# expected: '23'
+# Looks like you failed 1 test of 3.
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/segfault perl-5.10.0/ext/Test/Harness/t/sample-tests/segfault
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/segfault 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/segfault 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,5 @@
+#!/usr/bin/perl
+
+print "1..1\n";
+print "ok 1\n";
+kill 11, $$;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/sequence_misparse perl-5.10.0/ext/Test/Harness/t/sample-tests/sequence_misparse
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/sequence_misparse 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/sequence_misparse 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,14 @@
+#
+# This was causing parse failures due to an error in the TAP specification.
+# Hash marks *are* allowed in the description.
+#
+print <<DUMMY;
+1..5
+ok 1
+ok 2
+ok 3 # skipped on foobar system
+# 1234567890123456789012345678901234567890
+ok 4
+# 1234567890123456789012345678901234567890
+ok 5
+DUMMY
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/shbang_misparse perl-5.10.0/ext/Test/Harness/t/sample-tests/shbang_misparse
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/shbang_misparse 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/shbang_misparse 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,12 @@
+#!/usr/bin/perl-latest
+
+# The above #! line was misparsed as having a -t.
+# Pre-5.8 this will simply cause perl to choke, since there was no -t.
+# Post-5.8 taint warnings will mistakenly be on.
+
+print "1..2\n";
+print "ok 1\n";
+my $warning = '';
+$SIG{__WARN__} = sub { $warning .= $_[0] };
+eval( "#" . substr( $0, 0, 0 ) );
+print $warning ? "not ok 2\n" : "ok 2\n";
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/simple perl-5.10.0/ext/Test/Harness/t/sample-tests/simple
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/simple 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/simple 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/simple_fail perl-5.10.0/ext/Test/Harness/t/sample-tests/simple_fail
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/simple_fail 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/simple_fail 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+not ok 2
+ok 3
+ok 4
+not ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/simple_yaml perl-5.10.0/ext/Test/Harness/t/sample-tests/simple_yaml
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/simple_yaml 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/simple_yaml 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,27 @@
+print <<DUMMY_TEST;
+TAP version 13
+1..5
+ok 1
+ok 2
+ ---
+ -
+ fnurk: skib
+ ponk: gleeb
+ -
+ bar: krup
+ foo: plink
+ ...
+ok 3
+ok 4
+ ---
+ expected:
+ - 1
+ - 2
+ - 4
+ got:
+ - 1
+ - pong
+ - 4
+ ...
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skip perl-5.10.0/ext/Test/Harness/t/sample-tests/skip
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skip 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/skip 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2 # skip rain delay
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skip_nomsg perl-5.10.0/ext/Test/Harness/t/sample-tests/skip_nomsg
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skip_nomsg 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/skip_nomsg 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,4 @@
+print <<DUMMY;
+1..1
+ok 1 # Skip
+DUMMY
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skipall perl-5.10.0/ext/Test/Harness/t/sample-tests/skipall
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skipall 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/skipall 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,3 @@
+print <<DUMMY_TEST;
+1..0 # skipping: rope
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skipall_nomsg perl-5.10.0/ext/Test/Harness/t/sample-tests/skipall_nomsg
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skipall_nomsg 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/skipall_nomsg 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,2 @@
+print "1..0\n";
+exit 0;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skipall_v13 perl-5.10.0/ext/Test/Harness/t/sample-tests/skipall_v13
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/skipall_v13 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/skipall_v13 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,4 @@
+print <<DUMMY_TEST;
+TAP version 13
+1..0 # skipping: rope
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/space_after_plan perl-5.10.0/ext/Test/Harness/t/sample-tests/space_after_plan
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/space_after_plan 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/space_after_plan 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,3 @@
+# gforth TAP generates a space after the plan. Should probably be allowed.
+print "1..5 \n";
+print "ok $_ \n" for 1..5;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/stdout_stderr perl-5.10.0/ext/Test/Harness/t/sample-tests/stdout_stderr
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/stdout_stderr 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/stdout_stderr 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+use Test::More 'no_plan';
+diag 'comments';
+ok 1;
+ok 1;
+ok 1;
+diag 'comment';
+ok 1;
+diag 'more ignored stuff';
+diag 'and yet more';
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/strict perl-5.10.0/ext/Test/Harness/t/sample-tests/strict
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/strict 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/strict 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+TAP version 13
+1..1
+pragma +strict
+Nonsense!
+pragma -strict
+Doesn't matter.
+ok 1 All OK
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/switches perl-5.10.0/ext/Test/Harness/t/sample-tests/switches
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/switches 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/switches 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,2 @@
+print "1..1\n";
+print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n";
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/taint perl-5.10.0/ext/Test/Harness/t/sample-tests/taint
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/taint 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/taint 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,7 @@
+#!/usr/bin/perl -Tw
+
+use lib qw(t/lib);
+use Test::More tests => 1;
+
+eval { kill 0, $^X };
+like( $@, '/^Insecure dependency/', '-T honored' );
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/taint_warn perl-5.10.0/ext/Test/Harness/t/sample-tests/taint_warn
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/taint_warn 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/taint_warn 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,11 @@
+#!/usr/bin/perl -tw
+
+use lib qw(t/lib);
+use Test::More tests => 1;
+
+my $warnings = '';
+{
+ local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+ kill 0, $^X;
+}
+like( $warnings, '/^Insecure dependency/', '-t honored' );
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/todo perl-5.10.0/ext/Test/Harness/t/sample-tests/todo
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/todo 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/todo 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5 todo 3 2;
+ok 1
+ok 2
+not ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/todo_inline perl-5.10.0/ext/Test/Harness/t/sample-tests/todo_inline
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/todo_inline 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/todo_inline 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,6 @@
+print <<DUMMY_TEST;
+1..3
+not ok 1 - Foo # TODO Just testing the todo interface.
+ok 2 - Unexpected success # TODO Just testing the todo interface.
+ok 3 - This is not todo
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/todo_misparse perl-5.10.0/ext/Test/Harness/t/sample-tests/todo_misparse
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/todo_misparse 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/todo_misparse 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,5 @@
+print <<'END';
+1..1
+not ok 1 Hamlette # TODOORNOTTODO
+END
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/too_many perl-5.10.0/ext/Test/Harness/t/sample-tests/too_many
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/too_many 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/too_many 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,14 @@
+print <<DUMMY;
+1..3
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+ok 6
+ok 7
+DUMMY
+
+exit 4; # simulate Test::More's exit status
+
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/version_good perl-5.10.0/ext/Test/Harness/t/sample-tests/version_good
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/version_good 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/version_good 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+TAP version 13
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/version_late perl-5.10.0/ext/Test/Harness/t/sample-tests/version_late
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/version_late 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/version_late 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+1..5
+TAP version 13
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/version_old perl-5.10.0/ext/Test/Harness/t/sample-tests/version_old
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/version_old 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/version_old 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+TAP version 12
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/vms_nit perl-5.10.0/ext/Test/Harness/t/sample-tests/vms_nit
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/vms_nit 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/vms_nit 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,6 @@
+print <<DUMMY;
+1..2
+not
+ok 1
+ok 2
+DUMMY
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/with_comments perl-5.10.0/ext/Test/Harness/t/sample-tests/with_comments
--- perl-5.10.0.orig/ext/Test/Harness/t/sample-tests/with_comments 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/sample-tests/with_comments 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,14 @@
+print <<DUMMY_TEST;
+# and stuff
+1..5 todo 1 2 4 5;
+# yeah, that
+not ok 1
+# Failed test 1 in t/todo.t at line 9 *TODO*
+ok 2 # (t/todo.t at line 10 TODO?!)
+ok 3
+not ok 4
+# Test 4 got: '0' (t/todo.t at line 12 *TODO*)
+# Expected: '1' (need more tuits)
+ok 5 # (t/todo.t at line 13 TODO?!)
+# woo
+DUMMY_TEST
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/scheduler.t perl-5.10.0/ext/Test/Harness/t/scheduler.t
--- perl-5.10.0.orig/ext/Test/Harness/t/scheduler.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/scheduler.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,225 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+use TAP::Parser::Scheduler;
+
+my $perl_rules = {
+ par => [
+ { seq => '../ext/DB_File/t/*' },
+ { seq => '../ext/IO_Compress_Zlib/t/*' },
+ { seq => '../lib/CPANPLUS/*' },
+ { seq => '../lib/ExtUtils/t/*' },
+ '*'
+ ]
+};
+
+my $incomplete_rules = { par => [ { seq => [ '*A', '*D' ] } ] };
+
+my $some_tests = [
+ '../ext/DB_File/t/A',
+ 'foo',
+ '../ext/DB_File/t/B',
+ '../ext/DB_File/t/C',
+ '../lib/CPANPLUS/D',
+ '../lib/CPANPLUS/E',
+ 'bar',
+ '../lib/CPANPLUS/F',
+ '../ext/DB_File/t/D',
+ '../ext/DB_File/t/E',
+ '../ext/DB_File/t/F',
+];
+
+my @schedule = (
+ { name => 'Sequential, no rules',
+ tests => $some_tests,
+ jobs => 1,
+ },
+ { name => 'Sequential, Perl rules',
+ rules => $perl_rules,
+ tests => $some_tests,
+ jobs => 1,
+ },
+ { name => 'Two in parallel, Perl rules',
+ rules => $perl_rules,
+ tests => $some_tests,
+ jobs => 2,
+ },
+ { name => 'Massively parallel, Perl rules',
+ rules => $perl_rules,
+ tests => $some_tests,
+ jobs => 1000,
+ },
+ { name => 'Massively parallel, no rules',
+ tests => $some_tests,
+ jobs => 1000,
+ },
+ { name => 'Sequential, incomplete rules',
+ rules => $incomplete_rules,
+ tests => $some_tests,
+ jobs => 1,
+ },
+ { name => 'Two in parallel, incomplete rules',
+ rules => $incomplete_rules,
+ tests => $some_tests,
+ jobs => 2,
+ },
+ { name => 'Massively parallel, incomplete rules',
+ rules => $incomplete_rules,
+ tests => $some_tests,
+ jobs => 1000,
+ },
+);
+
+plan tests => @schedule * 2 + 266;
+
+for my $test (@schedule) {
+ test_scheduler(
+ $test->{name},
+ $test->{tests},
+ $test->{rules},
+ $test->{jobs}
+ );
+}
+
+# An ad-hoc test
+
+{
+ my @tests = qw(
+ A1 A2 A3 B1 C1 C8 C5 C7 C4 C6 C3 C2 C9 D1 D2 D3 E3 E2 E1
+ );
+
+ my $rules = {
+ par => [
+ { seq => 'A*' },
+ { par => 'B*' },
+ { seq => [ 'C1', 'C2' ] },
+ { par => [
+ { seq => [ 'C3', 'C4', 'C5' ] },
+ { seq => [ 'C6', 'C7', 'C8' ] }
+ ]
+ },
+ { seq => [
+ { par => ['D*'] },
+ { par => ['E*'] }
+ ]
+ },
+ ]
+ };
+
+ my $scheduler = TAP::Parser::Scheduler->new(
+ tests => \@tests,
+ rules => $rules
+ );
+
+ # diag $scheduler->as_string;
+
+ my $A1 = ok_job( $scheduler, 'A1' );
+ my $B1 = ok_job( $scheduler, 'B1' );
+ finish($A1);
+ my $A2 = ok_job( $scheduler, 'A2' );
+ my $C1 = ok_job( $scheduler, 'C1' );
+ finish( $A2, $C1 );
+ my $A3 = ok_job( $scheduler, 'A3' );
+ my $C2 = ok_job( $scheduler, 'C2' );
+ finish( $A3, $C2 );
+ my $C3 = ok_job( $scheduler, 'C3' );
+ my $C6 = ok_job( $scheduler, 'C6' );
+ my $D1 = ok_job( $scheduler, 'D1' );
+ my $D2 = ok_job( $scheduler, 'D2' );
+ finish($C6);
+ my $C7 = ok_job( $scheduler, 'C7' );
+ my $D3 = ok_job( $scheduler, 'D3' );
+ ok_job( $scheduler, '#' );
+ ok_job( $scheduler, '#' );
+ finish( $D3, $C3, $D1, $B1 );
+ my $C4 = ok_job( $scheduler, 'C4' );
+ finish( $C4, $C7 );
+ my $C5 = ok_job( $scheduler, 'C5' );
+ my $C8 = ok_job( $scheduler, 'C8' );
+ ok_job( $scheduler, '#' );
+ finish($D2);
+ my $E3 = ok_job( $scheduler, 'E3' );
+ my $E2 = ok_job( $scheduler, 'E2' );
+ my $E1 = ok_job( $scheduler, 'E1' );
+ finish( $E1, $E2, $E3, $C5, $C8 );
+ my $C9 = ok_job( $scheduler, 'C9' );
+ ok_job( $scheduler, undef );
+}
+
+{
+ my @tests = ();
+ for my $t ( 'A' .. 'Z' ) {
+ push @tests, map {"$t$_"} 1 .. 9;
+ }
+ my $rules = { par => [ map { { seq => "$_*" } } 'A' .. 'Z' ] };
+
+ my $scheduler = TAP::Parser::Scheduler->new(
+ tests => \@tests,
+ rules => $rules
+ );
+
+ # diag $scheduler->as_string;
+
+ for my $n ( 1 .. 9 ) {
+ my @got = ();
+ push @got, ok_job( $scheduler, "$_$n" ) for 'A' .. 'Z';
+ ok_job( $scheduler, $n == 9 ? undef : '#' );
+ finish(@got);
+ }
+}
+
+sub finish { $_->finish for @_ }
+
+sub ok_job {
+ my ( $scheduler, $want ) = @_;
+ my $job = $scheduler->get_job;
+ if ( !defined $want ) {
+ ok !defined $job, 'undef';
+ }
+ elsif ( $want eq '#' ) {
+ ok $job->is_spinner, 'spinner';
+ }
+ else {
+ is $job->filename, $want, $want;
+ }
+ return $job;
+}
+
+sub test_scheduler {
+ my ( $name, $tests, $rules, $jobs ) = @_;
+
+ ok my $scheduler = TAP::Parser::Scheduler->new(
+ tests => $tests,
+ defined $rules ? ( rules => $rules ) : (),
+ ),
+ "$name: new";
+
+ # diag $scheduler->as_string;
+
+ my @pipeline = ();
+ my @got = ();
+
+ while ( defined( my $job = $scheduler->get_job ) ) {
+
+ # diag $scheduler->as_string;
+ if ( $job->is_spinner || @pipeline >= $jobs ) {
+ die "Oops! Spinner!" unless @pipeline;
+ my $done = shift @pipeline;
+ $done->finish;
+
+ # diag "Completed ", $done->filename;
+ }
+ next if $job->is_spinner;
+
+ # diag " Got ", $job->filename;
+ push @pipeline, $job;
+
+ push @got, $job->filename;
+ }
+
+ is_deeply [ sort @got ], [ sort @$tests ], "$name: got all tests";
+}
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/source.t perl-5.10.0/ext/Test/Harness/t/source.t
--- perl-5.10.0.orig/ext/Test/Harness/t/source.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/source.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,103 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More tests => 26;
+
+use File::Spec;
+
+use EmptyParser;
+use TAP::Parser::Source;
+use TAP::Parser::Source::Perl;
+
+my $parser = EmptyParser->new;
+my $test = File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'source_tests',
+ 'source'
+);
+
+my $perl = $^X;
+
+can_ok 'TAP::Parser::Source', 'new';
+my $source = TAP::Parser::Source->new;
+isa_ok $source, 'TAP::Parser::Source';
+
+can_ok $source, 'source';
+eval { $source->source("$perl -It/lib $test") };
+ok my $error = $@, '... and calling it with a string should fail';
+like $error, qr/^Argument to &source must be an array reference/,
+ '... with an appropriate error message';
+ok $source->source( [ $perl, '-It/lib', '-T', $test ] ),
+ '... and calling it with valid args should succeed';
+
+can_ok $source, 'get_stream';
+my $stream = $source->get_stream($parser);
+
+isa_ok $stream, 'TAP::Parser::Iterator::Process',
+ 'get_stream returns the right object';
+can_ok $stream, 'next';
+is $stream->next, '1..1', '... and the first line should be correct';
+is $stream->next, 'ok 1', '... as should the second';
+ok !$stream->next, '... and we should have no more results';
+
+can_ok 'TAP::Parser::Source::Perl', 'new';
+$source = TAP::Parser::Source::Perl->new;
+isa_ok $source, 'TAP::Parser::Source::Perl', '... and the object it returns';
+
+can_ok $source, 'source';
+ok $source->source( [$test] ),
+ '... and calling it with valid args should succeed';
+
+can_ok $source, 'get_stream';
+$stream = $source->get_stream($parser);
+
+isa_ok $stream, 'TAP::Parser::Iterator::Process',
+ '... and the object it returns';
+can_ok $stream, 'next';
+is $stream->next, '1..1', '... and the first line should be correct';
+is $stream->next, 'ok 1', '... as should the second';
+ok !$stream->next, '... and we should have no more results';
+
+# internals tests!
+
+can_ok $source, '_switches';
+ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ),
+ '... and it should find the taint switch'
+);
+
+# coverage test for TAP::PArser::Source
+
+{
+
+ # coverage for method get_steam
+
+ my $source = TAP::Parser::Source->new( { parser => $parser } );
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $source->get_stream;
+ };
+
+ is @die, 1, 'coverage testing of get_stream';
+
+ like pop @die, qr/No command found!/, '...and it failed as expect';
+}
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness perl-5.10.0/ext/Test/Harness/t/source_tests/harness
--- perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/source_tests/harness 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,6 @@
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..1
+ok 1 - this is a test
+END_TESTS
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_badtap perl-5.10.0/ext/Test/Harness/t/source_tests/harness_badtap
--- perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_badtap 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/source_tests/harness_badtap 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..2
+ok 1 - this is a test
+not ok 2 - this is another test
+1..2
+END_TESTS
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_complain perl-5.10.0/ext/Test/Harness/t/source_tests/harness_complain
--- perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_complain 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/source_tests/harness_complain 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,7 @@
+#!/usr/bin/perl
+
+print "1..1\n";
+
+die "I should have no args -- @ARGV" if (@ARGV);
+print "ok 1 - this is a test\n";
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_directives perl-5.10.0/ext/Test/Harness/t/source_tests/harness_directives
--- perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_directives 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/source_tests/harness_directives 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,8 @@
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..3
+ok 1 - this is a test
+not ok 2 - we have a something # TODO some output
+ok 3 houston, we don't have liftoff # SKIP no funding
+END_TESTS
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_failure perl-5.10.0/ext/Test/Harness/t/source_tests/harness_failure
--- perl-5.10.0.orig/ext/Test/Harness/t/source_tests/harness_failure 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/source_tests/harness_failure 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,7 @@
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..2
+ok 1 - this is a test
+not ok 2 - this is another test
+END_TESTS
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/source_tests/source perl-5.10.0/ext/Test/Harness/t/source_tests/source
--- perl-5.10.0.orig/ext/Test/Harness/t/source_tests/source 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/source_tests/source 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,15 @@
+#!/usr/bin/perl -wT
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::More tests => 1;
+
+ok 1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/spool.t perl-5.10.0/ext/Test/Harness/t/spool.t
--- perl-5.10.0.orig/ext/Test/Harness/t/spool.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/spool.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,145 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+# test T::H::_open_spool and _close_spool - these are good examples
+# of the 'Fragile Test' pattern - messing with I/O primitives breaks
+# nearly everything
+
+use strict;
+use Test::More;
+
+my $useOrigOpen;
+my $useOrigClose;
+
+# setup replacements for core open and close - breaking these makes everything very fragile
+BEGIN {
+ $useOrigOpen = $useOrigClose = 1;
+
+ # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2
+
+ *CORE::GLOBAL::open = \&my_open;
+
+ sub my_open (*@) {
+ if ($useOrigOpen) {
+ if ( defined( $_[0] ) ) {
+ use Symbol qw();
+ my $handle = Symbol::qualify( $_[0], (caller)[0] );
+ no strict 'refs';
+ if ( @_ == 1 ) {
+ return CORE::open($handle);
+ }
+ elsif ( @_ == 2 ) {
+ return CORE::open( $handle, $_[1] );
+ }
+ else {
+ die "Can't open with more than two args";
+ }
+ }
+ }
+ else {
+ return;
+ }
+ }
+
+ *CORE::GLOBAL::close = sub (*) {
+ if ($useOrigClose) { return CORE::close(shift) }
+ else {return}
+ };
+
+}
+
+use TAP::Harness;
+use TAP::Parser;
+
+plan tests => 4;
+
+{
+
+ # coverage tests for the basically untested T::H::_open_spool
+
+ my @spool = ( $ENV{PERL_CORE} ? ('spool') : ( 't', 'spool' ) );
+ $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
+
+# now given that we're going to be writing stuff to the file system, make sure we have
+# a cleanup hook
+
+ END {
+ use File::Path;
+
+ $useOrigOpen = $useOrigClose = 1;
+
+ # remove the tree if we made it this far
+ rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
+ if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
+ }
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ # use the broken open
+ $useOrigOpen = 0;
+
+ TAP::Harness->_open_spool(
+ File::Spec->catfile(qw (source_tests harness )) );
+
+ # restore universal sanity
+ $useOrigOpen = 1;
+ };
+
+ is @die, 1, 'open failed, die as expected';
+
+ my $spoolDir = quotemeta(
+ File::Spec->catfile( @spool, qw( source_tests harness ) ) );
+
+ like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message';
+
+ # now make close fail
+
+ use Symbol;
+
+ my $spoolHandle = gensym;
+
+ my $tap = <<'END_TAP';
+1..1
+ok 1 - input file opened
+
+END_TAP
+
+ my $parser = TAP::Parser->new(
+ { spool => $spoolHandle,
+ stream =>
+ TAP::Parser::IteratorFactory->new( [ split /\n/ => $tap ] )
+ }
+ );
+
+ @die = ();
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ # use the broken CORE::close
+ $useOrigClose = 0;
+
+ TAP::Harness->_close_spool($parser);
+
+ $useOrigClose = 1;
+ };
+
+ unless ( is @die, 1, 'close failed, die as expected' ) {
+ diag " >>> $_ <<<\n" for @die;
+ }
+
+ like pop @die, qr/ Error closing TAP spool file[(] /,
+ '...with expected message';
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/state.t perl-5.10.0/ext/Test/Harness/t/state.t
--- perl-5.10.0.orig/ext/Test/Harness/t/state.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/state.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,262 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More;
+use App::Prove::State;
+use App::Prove::State::Result;
+
+sub mn {
+ my $pfx = $ENV{PERL_CORE} ? '../ext/Test/Harness/' : '';
+ return map {"$pfx$_"} @_;
+}
+
+my @schedule = (
+ { options => 'all',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'failed',
+ get_tests_args => [],
+ expect => [
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ ],
+ },
+ { options => 'passed',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'last',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/source.t',
+ ],
+ },
+ { options => 'todo',
+ get_tests_args => [],
+ expect => [
+ 't/compat/version.t',
+ 't/compat/failure.t',
+ ],
+
+ },
+ { options => 'hot',
+ get_tests_args => [],
+ expect => [
+ 't/compat/version.t',
+ 't/yamlish-writer.t',
+ 't/compat/env.t',
+ ],
+ },
+ { options => 'adrian',
+ get_tests_args => [],
+ expect => [
+ 't/compat/version.t',
+ 't/yamlish-writer.t',
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/compat/inc_taint.t',
+ 't/source.t',
+ ],
+ },
+ { options => 'failed,passed',
+ get_tests_args => [],
+ expect => [
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => [ 'failed', 'passed' ],
+ get_tests_args => [],
+ expect => [
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'slow',
+ get_tests_args => [],
+ expect => [
+ 't/yamlish-writer.t',
+ 't/compat/env.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ ],
+ },
+ { options => 'fast',
+ get_tests_args => [],
+ expect => [
+ 't/source.t',
+ 't/compat/failure.t',
+ 't/compat/version.t',
+ 't/compat/inc_taint.t',
+ 't/compat/env.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'old',
+ get_tests_args => [],
+ expect => [
+ 't/source.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/yamlish-writer.t',
+ 't/compat/failure.t',
+ 't/compat/env.t',
+ ],
+ },
+ { options => 'new',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/yamlish-writer.t',
+ 't/compat/version.t',
+ 't/compat/inc_taint.t',
+ 't/source.t',
+ ],
+ },
+ { options => 'fresh',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ ],
+ },
+);
+
+plan tests => @schedule * 2;
+
+for my $test (@schedule) {
+ my $state = App::Prove::State->new;
+ isa_ok $state, 'App::Prove::State';
+
+ my $desc = $test->{options};
+
+ # Naughty
+ $state->{_} = get_state();
+ my $options = $test->{options};
+ $options = [$options] unless 'ARRAY' eq ref $options;
+ $state->apply_switch(@$options);
+
+ my @got = $state->get_tests( @{ $test->{get_tests_args} } );
+ my @expect = mn( @{ $test->{expect} } );
+ unless ( is_deeply \@got, \@expect, "$desc: order OK" ) {
+ use Data::Dumper;
+ diag( Dumper( { got => \@got, want => \@expect } ) );
+ }
+}
+
+sub get_state {
+ return App::Prove::State::Result->new(
+ { generation => 51,
+ last_run_time => 1196285439,
+ tests => {
+ mn('t/compat/failure.t') => {
+ last_result => 0,
+ last_run_time => 1196371471.57738,
+ last_pass_time => 1196371471.57738,
+ total_passes => 48,
+ seq => 1549,
+ gen => 51,
+ elapsed => 0.1230,
+ last_todo => 1,
+ mtime => 1196285623,
+ },
+ mn('t/yamlish-writer.t') => {
+ last_result => 0,
+ last_run_time => 1196371480.5761,
+ last_pass_time => 1196371480.5761,
+ last_fail_time => 1196368609,
+ total_passes => 41,
+ seq => 1578,
+ gen => 49,
+ elapsed => 12.2983,
+ last_todo => 0,
+ mtime => 1196285400,
+ },
+ mn('t/compat/env.t') => {
+ last_result => 0,
+ last_run_time => 1196371471.42967,
+ last_pass_time => 1196371471.42967,
+ last_fail_time => 1196368608,
+ total_passes => 48,
+ seq => 1548,
+ gen => 52,
+ elapsed => 3.1290,
+ last_todo => 0,
+ mtime => 1196285739,
+ },
+ mn('t/compat/version.t') => {
+ last_result => 2,
+ last_run_time => 1196371472.96476,
+ last_pass_time => 1196371472.96476,
+ last_fail_time => 1196368609,
+ total_passes => 47,
+ seq => 1555,
+ gen => 51,
+ elapsed => 0.2363,
+ last_todo => 4,
+ mtime => 1196285239,
+ },
+ mn('t/compat/inc_taint.t') => {
+ last_result => 3,
+ last_run_time => 1196371471.89682,
+ last_pass_time => 1196371471.89682,
+ total_passes => 47,
+ seq => 1551,
+ gen => 51,
+ elapsed => 1.6938,
+ last_todo => 0,
+ mtime => 1196185639,
+ },
+ mn('t/source.t') => {
+ last_result => 0,
+ last_run_time => 1196371479.72508,
+ last_pass_time => 1196371479.72508,
+ total_passes => 41,
+ seq => 1570,
+ gen => 51,
+ elapsed => 0.0143,
+ last_todo => 0,
+ mtime => 1186285639,
+ },
+ }
+ }
+ );
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/state_results.t perl-5.10.0/ext/Test/Harness/t/state_results.t
--- perl-5.10.0.orig/ext/Test/Harness/t/state_results.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/state_results.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,154 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 25;
+use App::Prove::State;
+
+my $test_suite_data = test_suite_data();
+
+#
+# Test test suite results
+#
+
+can_ok 'App::Prove::State::Result', 'new';
+isa_ok my $result = App::Prove::State::Result->new($test_suite_data),
+ 'App::Prove::State::Result', '... and the object it returns';
+
+ok $result, 'state_version';
+ok defined $result->state_version, '... and it should be defined';
+
+can_ok $result, 'generation';
+is $result->generation, $test_suite_data->{generation},
+ '... and it should return the correct generation';
+
+can_ok $result, 'num_tests';
+is $result->num_tests, scalar keys %{ $test_suite_data->{tests} },
+ '... and it should return the number of tests run';
+
+can_ok $result, 'raw';
+is_deeply $result->raw, $test_suite_data,
+ '... and it should return the raw, unblessed data';
+
+#
+# Check individual tests.
+#
+
+can_ok $result, 'tests';
+
+can_ok $result, 'test';
+eval { $result->test };
+my $error = $@;
+like $error, qr/^\Qtest() requires a test name/,
+ '... and it should croak() if a test name is not supplied';
+
+my $name = 't/compat/failure.t';
+ok my $test = $result->test('t/compat/failure.t'),
+ 'result() should succeed if the test name is found';
+isa_ok $test, 'App::Prove::State::Result::Test',
+ '... and the object it returns';
+
+can_ok $test, 'name';
+is $test->name, $name, '... and it should return the test name';
+
+can_ok $test, 'last_pass_time';
+like $test->last_pass_time, qr/^\d+\.\d+$/,
+ '... and it should return a numeric value';
+
+can_ok $test, 'last_fail_time';
+ok !defined $test->last_fail_time,
+ '... and it should return undef if the test has never failed';
+
+can_ok $result, 'remove';
+ok $result->remove($name), '... and calling it should succeed';
+
+ok $test = $result->test($name),
+ '... and fetching the removed test should suceed';
+ok !defined $test->last_pass_time, '... and it should have clean values';
+
+sub test_suite_data {
+ return {
+ 'version' => App::Prove::State::Result->state_version,
+ 'generation' => '51',
+ 'tests' => {
+ 't/compat/failure.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371471.57738',
+ 'last_pass_time' => '1196371471.57738',
+ 'total_passes' => '48',
+ 'seq' => '1549',
+ 'gen' => '51',
+ 'elapsed' => 0.1230,
+ 'last_todo' => '1',
+ 'mtime' => 1196285623,
+ },
+ 't/yamlish-writer.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371480.5761',
+ 'last_pass_time' => '1196371480.5761',
+ 'last_fail_time' => '1196368609',
+ 'total_passes' => '41',
+ 'seq' => '1578',
+ 'gen' => '49',
+ 'elapsed' => 12.2983,
+ 'last_todo' => '0',
+ 'mtime' => 1196285400,
+ },
+ 't/compat/env.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371471.42967',
+ 'last_pass_time' => '1196371471.42967',
+ 'last_fail_time' => '1196368608',
+ 'total_passes' => '48',
+ 'seq' => '1548',
+ 'gen' => '52',
+ 'elapsed' => 3.1290,
+ 'last_todo' => '0',
+ 'mtime' => 1196285739,
+ },
+ 't/compat/version.t' => {
+ 'last_result' => '2',
+ 'last_run_time' => '1196371472.96476',
+ 'last_pass_time' => '1196371472.96476',
+ 'last_fail_time' => '1196368609',
+ 'total_passes' => '47',
+ 'seq' => '1555',
+ 'gen' => '51',
+ 'elapsed' => 0.2363,
+ 'last_todo' => '4',
+ 'mtime' => 1196285239,
+ },
+ 't/compat/inc_taint.t' => {
+ 'last_result' => '3',
+ 'last_run_time' => '1196371471.89682',
+ 'last_pass_time' => '1196371471.89682',
+ 'total_passes' => '47',
+ 'seq' => '1551',
+ 'gen' => '51',
+ 'elapsed' => 1.6938,
+ 'last_todo' => '0',
+ 'mtime' => 1196185639,
+ },
+ 't/source.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371479.72508',
+ 'last_pass_time' => '1196371479.72508',
+ 'total_passes' => '41',
+ 'seq' => '1570',
+ 'gen' => '51',
+ 'elapsed' => 0.0143,
+ 'last_todo' => '0',
+ 'mtime' => 1186285639,
+ },
+ }
+ };
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/streams.t perl-5.10.0/ext/Test/Harness/t/streams.t
--- perl-5.10.0.orig/ext/Test/Harness/t/streams.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/streams.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,171 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 47;
+
+use TAP::Parser;
+use TAP::Parser::IteratorFactory;
+
+my $STREAMED = 'TAP::Parser';
+my $ITER = 'TAP::Parser::Iterator';
+my $ITER_FH = "${ITER}::Stream";
+my $ITER_ARRAY = "${ITER}::Array";
+
+my $factory = TAP::Parser::IteratorFactory->new;
+my $stream = $factory->make_iterator( \*DATA );
+isa_ok $stream, 'TAP::Parser::Iterator';
+my $parser = TAP::Parser->new( { stream => $stream } );
+isa_ok $parser, 'TAP::Parser',
+ '... and creating a streamed parser should succeed';
+
+can_ok $parser, '_stream';
+is ref $parser->_stream, $ITER_FH,
+ '... and it should return the proper iterator';
+can_ok $parser, 'next';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+
+ok !$parser->parse_errors, '... and we should have no parse errors';
+
+# plan at end
+
+my $tap = <<'END_TAP';
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+1..5
+END_TAP
+
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
+ok $parser = TAP::Parser->new( { stream => $stream } ),
+ 'Now we create a parser with the plan at the end';
+isa_ok $parser->_stream, $ITER_ARRAY,
+ '... and now we should have an array iterator';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+
+ok !$parser->parse_errors, '... and we should have no parse errors';
+
+# misplaced plan (and one-off errors)
+
+$tap = <<'END_TAP';
+ok 1 - input file opened
+1..5
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+END_TAP
+
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
+
+ok $parser = TAP::Parser->new( { stream => $stream } ),
+ 'Now we create a parser with a plan as the second line';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+
+ok $parser->parse_errors, '... and we should have one parse error';
+is + ( $parser->parse_errors )[0],
+ 'Plan (1..5) must be at the beginning or end of the TAP output',
+ '... telling us that our plan went awry';
+
+$tap = <<'END_TAP';
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+1..5
+ok 5 # skip we have no description
+END_TAP
+
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
+
+ok $parser = TAP::Parser->new( { stream => $stream } ),
+ 'Now we create a parser with the plan as the second to last line';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+
+ok $parser->parse_errors, '... and we should have one parse error';
+is + ( $parser->parse_errors )[0],
+ 'Plan (1..5) must be at the beginning or end of the TAP output',
+ '... telling us that our plan went awry';
+
+__DATA__
+1..5
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/subclass_tests/non_perl_source perl-5.10.0/ext/Test/Harness/t/subclass_tests/non_perl_source
--- perl-5.10.0.orig/ext/Test/Harness/t/subclass_tests/non_perl_source 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/subclass_tests/non_perl_source 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,3 @@
+#!/bin/sh
+echo "1..1"
+echo "ok 1 - this is a test"
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/subclass_tests/perl_source perl-5.10.0/ext/Test/Harness/t/subclass_tests/perl_source
--- perl-5.10.0.orig/ext/Test/Harness/t/subclass_tests/perl_source 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/subclass_tests/perl_source 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,6 @@
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..1
+ok 1 - this is a test
+END_TESTS
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/taint.t perl-5.10.0/ext/Test/Harness/t/taint.t
--- perl-5.10.0.orig/ext/Test/Harness/t/taint.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/taint.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,55 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+# Test that options in PERL5OPT are propogated to tainted tests
+
+use strict;
+use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 1 ) );
+
+use Config;
+use TAP::Parser;
+
+my $lib_path = join( ', ', map "'$_'", grep !ref, grep defined, @INC );
+
+sub run_test_file {
+ my ( $test_template, @args ) = @_;
+
+ my $test_file = 'temp_test.tmp';
+
+ open TEST, ">$test_file" or die $!;
+ printf TEST $test_template, @args;
+ close TEST;
+
+ my $p = TAP::Parser->new(
+ { source => $test_file,
+
+ # Test taint when there's spaces in a -I path
+ switches => [q["-Ifoo bar"]],
+ }
+ );
+ 1 while $p->next;
+ ok !$p->has_problems;
+
+ unlink $test_file;
+}
+
+{
+ local $ENV{PERL5OPT} = '-Mstrict';
+ run_test_file(<<'END');
+#!/usr/bin/perl -T
+
+print "1..1\n";
+print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n";
+END
+}
+
+1;
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/testargs.t perl-5.10.0/ext/Test/Harness/t/testargs.t
--- perl-5.10.0.orig/ext/Test/Harness/t/testargs.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/testargs.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,136 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ chdir 't' and @INC = '../lib' if $ENV{PERL_CORE};
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 19;
+use File::Spec;
+use TAP::Parser;
+use TAP::Harness;
+use App::Prove;
+
+my $test = File::Spec->catfile(
+ ( $ENV{PERL_CORE}
+ ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
+ : ()
+ ),
+ 't',
+ 'sample-tests',
+ 'echo'
+);
+
+diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV;
+
+sub echo_ok {
+ my $options = shift;
+ my @args = @_;
+ my $parser = TAP::Parser->new( { %$options, test_args => \@args } );
+ my @got = ();
+ while ( my $result = $parser->next ) {
+ push @got, $result;
+ }
+ my $plan = shift @got;
+ ok $plan->is_plan;
+ for (@got) {
+ is $_->description, shift(@args),
+ join( ', ', keys %$options ) . ": option passed OK";
+ }
+}
+
+for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) {
+ echo_ok( { source => $test }, @$args );
+ echo_ok( { exec => [ $^X, $test ] }, @$args );
+}
+
+{
+ my $harness = TAP::Harness->new(
+ { verbosity => -9, test_args => [qw( magic hat brigade )] } );
+ my $aggregate = $harness->runtests($test);
+
+ is $aggregate->total, 3, "ran the right number of tests";
+ is $aggregate->passed, 3, "and they passed";
+}
+
+package Test::Prove;
+
+use vars qw(@ISA);
+@ISA = 'App::Prove';
+
+sub _runtests {
+ my $self = shift;
+ push @{ $self->{_log} }, [@_];
+ return;
+}
+
+sub get_run_log {
+ my $self = shift;
+ return $self->{_log};
+}
+
+package main;
+
+{
+ my $app = Test::Prove->new;
+
+ $app->process_args( '--norc', $test, '::', 'one', 'two', 'huh' );
+ $app->run();
+ my $log = $app->get_run_log;
+ is_deeply $log->[0]->[0]->{test_args}, [ 'one', 'two', 'huh' ],
+ "prove args match";
+}
+
+sub bigness {
+ my $str = join '', @_;
+ my @cdef = (
+ '0000000000000000', '1818181818001800', '6c6c6c0000000000',
+ '36367f367f363600', '0c3f683e0b7e1800', '60660c1830660600',
+ '386c6c386d663b00', '0c18300000000000', '0c18303030180c00',
+ '30180c0c0c183000', '00187e3c7e180000', '0018187e18180000',
+ '0000000000181830', '0000007e00000000', '0000000000181800',
+ '00060c1830600000', '3c666e7e76663c00', '1838181818187e00',
+ '3c66060c18307e00', '3c66061c06663c00', '0c1c3c6c7e0c0c00',
+ '7e607c0606663c00', '1c30607c66663c00', '7e060c1830303000',
+ '3c66663c66663c00', '3c66663e060c3800', '0000181800181800',
+ '0000181800181830', '0c18306030180c00', '00007e007e000000',
+ '30180c060c183000', '3c660c1818001800', '3c666e6a6e603c00',
+ '3c66667e66666600', '7c66667c66667c00', '3c66606060663c00',
+ '786c6666666c7800', '7e60607c60607e00', '7e60607c60606000',
+ '3c66606e66663c00', '6666667e66666600', '7e18181818187e00',
+ '3e0c0c0c0c6c3800', '666c7870786c6600', '6060606060607e00',
+ '63777f6b6b636300', '6666767e6e666600', '3c66666666663c00',
+ '7c66667c60606000', '3c6666666a6c3600', '7c66667c6c666600',
+ '3c66603c06663c00', '7e18181818181800', '6666666666663c00',
+ '66666666663c1800', '63636b6b7f776300', '66663c183c666600',
+ '6666663c18181800', '7e060c1830607e00', '7c60606060607c00',
+ '006030180c060000', '3e06060606063e00', '183c664200000000',
+ '00000000000000ff', '1c36307c30307e00', '00003c063e663e00',
+ '60607c6666667c00', '00003c6660663c00', '06063e6666663e00',
+ '00003c667e603c00', '1c30307c30303000', '00003e66663e063c',
+ '60607c6666666600', '1800381818183c00', '1800381818181870',
+ '6060666c786c6600', '3818181818183c00', '0000367f6b6b6300',
+ '00007c6666666600', '00003c6666663c00', '00007c66667c6060',
+ '00003e66663e0607', '00006c7660606000', '00003e603c067c00',
+ '30307c3030301c00', '0000666666663e00', '00006666663c1800',
+ '0000636b6b7f3600', '0000663c183c6600', '00006666663e063c',
+ '00007e0c18307e00', '0c18187018180c00', '1818180018181800',
+ '3018180e18183000', '316b460000000000'
+ );
+ my @chars = unpack( 'C*', $str );
+ my @out = ();
+ for my $row ( 0 .. 7 ) {
+ for my $char (@chars) {
+ next if $char < 32 || $char > 126;
+ my $size = scalar(@cdef);
+ my $byte = hex( substr( $cdef[ $char - 32 ], $row * 2, 2 ) );
+ my $bits = sprintf( '%08b', $byte );
+ $bits =~ tr/01/ #/;
+ push @out, $bits;
+ }
+ push @out, "\n";
+ }
+ return join '', @out;
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/unicode.t perl-5.10.0/ext/Test/Harness/t/unicode.t
--- perl-5.10.0.orig/ext/Test/Harness/t/unicode.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/unicode.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,125 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+use Test::More;
+use TAP::Parser;
+
+my @schedule;
+my %make_test;
+
+BEGIN {
+
+ # TODO: Investigate failure on 5.8.0
+ plan skip_all => "unicode on Perl <= 5.8.0"
+ unless $] > 5.008;
+
+ plan skip_all => "PERL_UNICODE set"
+ if defined $ENV{PERL_UNICODE};
+
+ eval "use File::Temp";
+ plan skip_all => "File::Temp unavailable"
+ if $@;
+
+ eval "use Encode";
+ plan skip_all => "Encode unavailable"
+ if $@;
+
+ # Subs that take the supplied TAP and turn it into a set of args to
+ # supply to TAP::Harness->new. The returned hash includes the
+ # temporary file so that its reference count doesn't go to zero
+ # until we're finished with it.
+ %make_test = (
+ file => sub {
+ my $source = shift;
+ my $tmp = File::Temp->new;
+ open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n";
+ eval 'binmode( $fh, ":utf8" )';
+ print $fh join( "\n", @$source ), "\n";
+ close $fh;
+
+ open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n";
+ eval 'binmode( $taph, ":utf8" )';
+ return {
+ temp => $tmp,
+ args => { source => $taph },
+ };
+ },
+ script => sub {
+ my $source = shift;
+ my $tmp = File::Temp->new;
+ open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n";
+ eval 'binmode( $fh, ":utf8" )';
+ print $fh map {"print qq{$_\\n};\n"} @$source;
+ close $fh;
+
+ open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n";
+ return {
+ temp => $tmp,
+ args => { exec => [ $^X, "$tmp" ] },
+ };
+ },
+ );
+
+ @schedule = (
+ { name => 'Non-unicode warm up',
+ source => [
+ 'TAP version 13',
+ '1..1',
+ 'ok 1 Everything is fine',
+ ],
+ expect => [
+ { isa => 'TAP::Parser::Result::Version', },
+ { isa => 'TAP::Parser::Result::Plan', },
+ { isa => 'TAP::Parser::Result::Test',
+ description => "Everything is fine"
+ },
+ ],
+ },
+ { name => 'Unicode smiley',
+ source => [
+ 'TAP version 13',
+ '1..1',
+
+ # Funky quoting / eval to avoid errors on older Perls
+ eval qq{"ok 1 Everything is fine \\x{263a}"},
+ ],
+ expect => [
+ { isa => 'TAP::Parser::Result::Version', },
+ { isa => 'TAP::Parser::Result::Plan', },
+ { isa => 'TAP::Parser::Result::Test',
+ description => eval qq{"Everything is fine \\x{263a}"}
+ },
+ ],
+ }
+ );
+
+ plan 'no_plan';
+}
+
+for my $test (@schedule) {
+ for my $type ( sort keys %make_test ) {
+ my $name = sprintf( "%s (%s)", $test->{name}, $type );
+ my $args = $make_test{$type}->( $test->{source} );
+
+ my $parser = TAP::Parser->new( $args->{args} );
+ isa_ok $parser, 'TAP::Parser';
+ my @expect = @{ $test->{expect} };
+ while ( my $tok = $parser->next ) {
+ my $exp = shift @expect;
+ for my $item ( sort keys %$exp ) {
+ my $val = $exp->{$item};
+ if ( 'isa' eq $item ) {
+ isa_ok $tok, $val;
+ }
+ elsif ( 'CODE' eq ref $val ) {
+ ok $val->($tok), "$name: assertion for $item";
+ }
+ else {
+ my $got = $tok->$item();
+ is $got, $val, "$name: value for $item matches";
+ }
+ }
+ }
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/utils.t perl-5.10.0/ext/Test/Harness/t/utils.t
--- perl-5.10.0.orig/ext/Test/Harness/t/utils.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/utils.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,65 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ chdir 't' and @INC = '../lib' if $ENV{PERL_CORE};
+}
+
+use strict;
+use lib 't/lib';
+
+use TAP::Parser::Utils qw( split_shell );
+use Test::More;
+
+my @schedule = (
+ { name => 'Bare words',
+ in => 'bare words are here',
+ out => [ 'bare', 'words', 'are', 'here' ],
+ },
+ { name => 'Single quotes',
+ in => "'bare' 'words' 'are' 'here'",
+ out => [ 'bare', 'words', 'are', 'here' ],
+ },
+ { name => 'Double quotes',
+ in => '"bare" "words" "are" "here"',
+ out => [ 'bare', 'words', 'are', 'here' ],
+ },
+ { name => 'Escapes',
+ in => '\ "ba\"re" \'wo\\\'rds\' \\\\"are" "here"',
+ out => [ ' ', 'ba"re', "wo'rds", '\\are', 'here' ],
+ },
+ { name => 'Flag',
+ in => '-e "system(shift)"',
+ out => [ '-e', 'system(shift)' ],
+ },
+ { name => 'Nada',
+ in => undef,
+ out => [],
+ },
+ { name => 'Nada II',
+ in => '',
+ out => [],
+ },
+ { name => 'Zero',
+ in => 0,
+ out => ['0'],
+ },
+ { name => 'Empty',
+ in => '""',
+ out => [''],
+ },
+ { name => 'Empty II',
+ in => "''",
+ out => [''],
+ },
+);
+
+plan tests => 1 * @schedule;
+
+for my $test (@schedule) {
+ my $name = $test->{name};
+ my @got = split_shell( $test->{in} );
+ unless ( is_deeply \@got, $test->{out}, "$name: parse OK" ) {
+ use Data::Dumper;
+ diag( Dumper( { want => $test->{out}, got => \@got } ) );
+ }
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/yamlish-output.t perl-5.10.0/ext/Test/Harness/t/yamlish-output.t
--- perl-5.10.0.orig/ext/Test/Harness/t/yamlish-output.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/yamlish-output.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,100 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 9;
+
+use TAP::Parser::YAMLish::Writer;
+
+my $out = [
+ "---",
+ "bill-to:",
+ " address:",
+ " city: \"Royal Oak\"",
+ " lines: \"458 Walkman Dr.\\nSuite #292\\n\"",
+ " postal: 48046",
+ " state: MI",
+ " family: Dumars",
+ " given: Chris",
+ "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"",
+ "date: 2001-01-23",
+ "invoice: 34843",
+ "product:",
+ " -",
+ " description: Basketball",
+ " price: 450.00",
+ " quantity: 4",
+ " sku: BL394D",
+ " -",
+ " description: \"Super Hoop\"",
+ " price: 2392.00",
+ " quantity: 1",
+ " sku: BL4438H",
+ "tax: 251.42",
+ "total: 4443.52",
+ "...",
+];
+
+my $in = {
+ 'bill-to' => {
+ 'given' => 'Chris',
+ 'address' => {
+ 'city' => 'Royal Oak',
+ 'postal' => '48046',
+ 'lines' => "458 Walkman Dr.\nSuite #292\n",
+ 'state' => 'MI'
+ },
+ 'family' => 'Dumars'
+ },
+ 'invoice' => '34843',
+ 'date' => '2001-01-23',
+ 'tax' => '251.42',
+ 'product' => [
+ { 'sku' => 'BL394D',
+ 'quantity' => '4',
+ 'price' => '450.00',
+ 'description' => 'Basketball'
+ },
+ { 'sku' => 'BL4438H',
+ 'quantity' => '1',
+ 'price' => '2392.00',
+ 'description' => 'Super Hoop'
+ }
+ ],
+ 'comments' =>
+ "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n",
+ 'total' => '4443.52'
+};
+
+my @buf1 = ();
+my @buf2 = ();
+my $buf3 = '';
+
+my @destination = (
+ { name => 'Array reference',
+ destination => \@buf1,
+ normalise => sub { return \@buf1 },
+ },
+ { name => 'Closure',
+ destination => sub { push @buf2, shift },
+ normalise => sub { return \@buf2 },
+ },
+ { name => 'Scalar',
+ destination => \$buf3,
+ normalise => sub {
+ my @ar = split( /\n/, $buf3 );
+ return \@ar;
+ },
+ },
+);
+
+for my $dest (@destination) {
+ my $name = $dest->{name};
+ ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created";
+ isa_ok $yaml, 'TAP::Parser::YAMLish::Writer';
+
+ $yaml->write( $in, $dest->{destination} );
+ my $got = $dest->{normalise}->();
+ is_deeply $got, $out, "$name: Result matches";
+}
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/yamlish-writer.t perl-5.10.0/ext/Test/Harness/t/yamlish-writer.t
--- perl-5.10.0.orig/ext/Test/Harness/t/yamlish-writer.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/yamlish-writer.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,274 @@
+#!/usr/bin/perl
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+
+use TAP::Parser::YAMLish::Reader;
+use TAP::Parser::YAMLish::Writer;
+
+my @SCHEDULE;
+
+BEGIN {
+ @SCHEDULE = (
+ { name => 'Simple scalar',
+ in => 1,
+ out => [
+ '--- 1',
+ '...',
+ ],
+ },
+ { name => 'Undef',
+ in => undef,
+ out => [
+ '--- ~',
+ '...',
+ ],
+ },
+ { name => 'Unprintable',
+ in => "\x01\n\t",
+ out => [
+ '--- "\x01\n\t"',
+ '...',
+ ],
+ },
+ { name => 'Simple array',
+ in => [ 1, 2, 3 ],
+ out => [
+ '---',
+ '- 1',
+ '- 2',
+ '- 3',
+ '...',
+ ],
+ },
+ { name => 'Empty array',
+ in => [],
+ out => [
+ '--- []',
+ '...'
+ ],
+ },
+ { name => 'Empty hash',
+ in => {},
+ out => [
+ '--- {}',
+ '...'
+ ],
+ },
+ { name => 'Array, two elements, undef',
+ in => [ undef, undef ],
+ out => [
+ '---',
+ '- ~',
+ '- ~',
+ '...',
+ ],
+ },
+ { name => 'Nested array',
+ in => [ 1, 2, [ 3, 4 ], 5 ],
+ out => [
+ '---',
+ '- 1',
+ '- 2',
+ '-',
+ ' - 3',
+ ' - 4',
+ '- 5',
+ '...',
+ ],
+ },
+ { name => 'Nested empty',
+ in => [ 1, 2, [], 5 ],
+ out => [
+ '---',
+ '- 1',
+ '- 2',
+ '- []',
+ '- 5',
+ '...',
+ ],
+ },
+ { name => 'Simple hash',
+ in => { one => '1', two => '2', three => '3' },
+ out => [
+ '---',
+ 'one: 1',
+ 'three: 3',
+ 'two: 2',
+ '...',
+ ],
+ },
+ { name => 'Nested hash',
+ in => {
+ one => '1', two => '2',
+ more => { three => '3', four => '4' }
+ },
+ out => [
+ '---',
+ 'more:',
+ ' four: 4',
+ ' three: 3',
+ 'one: 1',
+ 'two: 2',
+ '...',
+ ],
+ },
+ { name => 'Nested empty',
+ in => { one => '1', two => '2', more => {} },
+ out => [
+ '---',
+ 'more: {}',
+ 'one: 1',
+ 'two: 2',
+ '...',
+ ],
+ },
+ { name => 'Unprintable key',
+ in => { one => '1', "\x02" => '2', three => '3' },
+ out => [
+ '---',
+ '"\x02": 2',
+ 'one: 1',
+ 'three: 3',
+ '...',
+ ],
+ },
+ { name => 'Empty key',
+ in => { '' => 'empty' },
+ out => [
+ '---',
+ "'': empty",
+ '...',
+ ],
+ },
+ { name => 'Empty value',
+ in => { '' => '' },
+ out => [
+ '---',
+ "'': ''",
+ '...',
+ ],
+ },
+ { name => 'Funky hash key',
+ in => { './frob' => 'is_frob' },
+ out => [
+ '---',
+ '"./frob": is_frob',
+ '...',
+ ]
+ },
+ { name => 'Complex',
+ in => {
+ 'bill-to' => {
+ 'given' => 'Chris',
+ 'address' => {
+ 'city' => 'Royal Oak',
+ 'postal' => '48046',
+ 'lines' => "458 Walkman Dr.\nSuite #292\n",
+ 'state' => 'MI'
+ },
+ 'family' => 'Dumars'
+ },
+ 'invoice' => '34843',
+ 'date' => '2001-01-23',
+ 'tax' => '251.42',
+ 'product' => [
+ { 'sku' => 'BL394D',
+ 'quantity' => '4',
+ 'price' => '450.00',
+ 'description' => 'Basketball'
+ },
+ { 'sku' => 'BL4438H',
+ 'quantity' => '1',
+ 'price' => '2392.00',
+ 'description' => 'Super Hoop'
+ }
+ ],
+ 'comments' =>
+ "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n",
+ 'total' => '4443.52'
+ },
+ out => [
+ "---",
+ "bill-to:",
+ " address:",
+ " city: \"Royal Oak\"",
+ " lines: \"458 Walkman Dr.\\nSuite #292\\n\"",
+ " postal: 48046",
+ " state: MI",
+ " family: Dumars",
+ " given: Chris",
+ "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"",
+ "date: 2001-01-23",
+ "invoice: 34843",
+ "product:",
+ " -",
+ " description: Basketball",
+ " price: 450.00",
+ " quantity: 4",
+ " sku: BL394D",
+ " -",
+ " description: \"Super Hoop\"",
+ " price: 2392.00",
+ " quantity: 1",
+ " sku: BL4438H",
+ "tax: 251.42",
+ "total: 4443.52",
+ "...",
+ ],
+ },
+ );
+
+ plan tests => @SCHEDULE * 6;
+}
+
+sub iter {
+ my $ar = shift;
+ return sub {
+ return shift @$ar;
+ };
+}
+
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+ ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created";
+ isa_ok $yaml, 'TAP::Parser::YAMLish::Writer';
+
+ my $got = [];
+ my $writer = sub { push @$got, shift };
+
+ my $data = $test->{in};
+
+ eval { $yaml->write( $data, $writer ) };
+
+ if ( my $err = $test->{error} ) {
+ unless ( like $@, $err, "$name: Error message" ) {
+ diag "Error: $@\n";
+ }
+ is_deeply $got, [], "$name: No result";
+ pass;
+ }
+ else {
+ my $want = $test->{out};
+ unless ( ok !$@, "$name: No error" ) {
+ diag "Error: $@\n";
+ }
+ unless ( is_deeply $got, $want, "$name: Result matches" ) {
+ use Data::Dumper;
+ diag Dumper($got);
+ diag Dumper($want);
+ }
+
+ my $yr = TAP::Parser::YAMLish::Reader->new;
+
+ # Now try parsing it
+ my $reader = sub { shift @$got };
+ my $parsed = eval { $yr->read($reader) };
+ ok !$@, "$name: no error" or diag "$@";
+
+ is_deeply $parsed, $data, "$name: Reparse OK";
+ }
+}
+
diff -urN perl-5.10.0.orig/ext/Test/Harness/t/yamlish.t perl-5.10.0/ext/Test/Harness/t/yamlish.t
--- perl-5.10.0.orig/ext/Test/Harness/t/yamlish.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Test/Harness/t/yamlish.t 2009-03-10 17:20:31.000000000 +0100
@@ -0,0 +1,529 @@
+#!perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+
+use TAP::Parser::YAMLish::Reader;
+
+my @SCHEDULE;
+
+BEGIN {
+ @SCHEDULE = (
+ { name => 'Hello World',
+ in => [
+ '--- Hello, World',
+ '...',
+ ],
+ out => "Hello, World",
+ },
+ { name => 'Hello World 2',
+ in => [
+ '--- \'Hello, \'\'World\'',
+ '...',
+ ],
+ out => "Hello, 'World",
+ },
+ { name => 'Hello World 3',
+ in => [
+ '--- "Hello, World"',
+ '...',
+ ],
+ out => "Hello, World",
+ },
+ { name => 'Hello World 4',
+ in => [
+ '--- "Hello, World"',
+ '...',
+ ],
+ out => "Hello, World",
+ },
+ { name => 'Hello World 4',
+ in => [
+ '--- >',
+ ' Hello,',
+ ' World',
+ '...',
+ ],
+ out => "Hello, World\n",
+ },
+ { name => 'Hello World Block',
+ in => [
+ '--- |',
+ ' Hello,',
+ ' World',
+ '...',
+ ],
+ out => "Hello,\n World\n",
+ },
+ { name => 'Hello World 5',
+ in => [
+ '--- >',
+ ' Hello,',
+ ' World',
+ '...',
+ ],
+ error => qr{Missing\s+'[.][.][.]'},
+ },
+ { name => 'Simple array',
+ in => [
+ '---',
+ '- 1',
+ '- 2',
+ '- 3',
+ '...',
+ ],
+ out => [ '1', '2', '3' ],
+ },
+ { name => 'Mixed array',
+ in => [
+ '---',
+ '- 1',
+ '- \'two\'',
+ '- "three\n"',
+ '...',
+ ],
+ out => [ '1', 'two', "three\n" ],
+ },
+ { name => 'Hash in array',
+ in => [
+ '---',
+ '- 1',
+ '- two: 2',
+ '- 3',
+ '...',
+ ],
+ out => [ '1', { two => '2' }, '3' ],
+ },
+ { name => 'Hash in array 2',
+ in => [
+ '---',
+ '- 1',
+ '- two: 2',
+ ' three: 3',
+ '- 4',
+ '...',
+ ],
+ out => [ '1', { two => '2', three => '3' }, '4' ],
+ },
+ { name => 'Nested array',
+ in => [
+ '---',
+ '- one',
+ '-',
+ ' - two',
+ ' -',
+ ' - three',
+ ' - four',
+ '- five',
+ '...',
+ ],
+ out => [ 'one', [ 'two', ['three'], 'four' ], 'five' ],
+ },
+ { name => 'Nested hash',
+ in => [
+ '---',
+ 'one:',
+ ' five: 5',
+ ' two:',
+ ' four: 4',
+ ' three: 3',
+ 'six: 6',
+ '...',
+ ],
+ out => {
+ one => { two => { three => '3', four => '4' }, five => '5' },
+ six => '6'
+ },
+ },
+ { name => 'Space after colon',
+ in => [ '---', 'spog: ', ' - 1', ' - 2', '...' ],
+ out => { spog => [ 1, 2 ] },
+ },
+ { name => 'Original YAML::Tiny test',
+ in => [
+ '---',
+ 'invoice: 34843',
+ 'date : 2001-01-23',
+ 'bill-to:',
+ ' given : Chris',
+ ' family : Dumars',
+ ' address:',
+ ' lines: |',
+ ' 458 Walkman Dr.',
+ ' Suite #292',
+ ' city : Royal Oak',
+ ' state : MI',
+ ' postal : 48046',
+ 'product:',
+ ' - sku : BL394D',
+ ' quantity : 4',
+ ' description : Basketball',
+ ' price : 450.00',
+ ' - sku : BL4438H',
+ ' quantity : 1',
+ ' description : Super Hoop',
+ ' price : 2392.00',
+ 'tax : 251.42',
+ 'total: 4443.52',
+ 'comments: >',
+ ' Late afternoon is best.',
+ ' Backup contact is Nancy',
+ ' Billsmer @ 338-4338',
+ '...',
+ ],
+ out => {
+ 'bill-to' => {
+ 'given' => 'Chris',
+ 'address' => {
+ 'city' => 'Royal Oak',
+ 'postal' => '48046',
+ 'lines' => "458 Walkman Dr.\nSuite #292\n",
+ 'state' => 'MI'
+ },
+ 'family' => 'Dumars'
+ },
+ 'invoice' => '34843',
+ 'date' => '2001-01-23',
+ 'tax' => '251.42',
+ 'product' => [
+ { 'sku' => 'BL394D',
+ 'quantity' => '4',
+ 'price' => '450.00',
+ 'description' => 'Basketball'
+ },
+ { 'sku' => 'BL4438H',
+ 'quantity' => '1',
+ 'price' => '2392.00',
+ 'description' => 'Super Hoop'
+ }
+ ],
+ 'comments' =>
+ "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n",
+ 'total' => '4443.52'
+ }
+ },
+
+ # Tests harvested from YAML::Tiny
+ { in => ['...'],
+ name => 'Regression: empty',
+ error => qr{document\s+header\s+not\s+found}
+ },
+ { in => [
+ '# comment',
+ '...'
+ ],
+ name => 'Regression: only_comment',
+ error => qr{document\s+header\s+not\s+found}
+ },
+ { out => undef,
+ in => [
+ '---',
+ '...'
+ ],
+ name => 'Regression: only_header',
+ error => qr{Premature\s+end}i,
+ },
+ { out => undef,
+ in => [
+ '---',
+ '---',
+ '...'
+ ],
+ name => 'Regression: two_header',
+ error => qr{Unexpected\s+start}i,
+ },
+ { out => undef,
+ in => [
+ '--- ~',
+ '...'
+ ],
+ name => 'Regression: one_undef'
+ },
+ { out => undef,
+ in => [
+ '--- ~',
+ '...'
+ ],
+ name => 'Regression: one_undef2'
+ },
+ { in => [
+ '--- ~',
+ '---',
+ '...'
+ ],
+ name => 'Regression: two_undef',
+ error => qr{Missing\s+'[.][.][.]'},
+ },
+ { out => 'foo',
+ in => [
+ '--- foo',
+ '...'
+ ],
+ name => 'Regression: one_scalar',
+ },
+ { out => 'foo',
+ in => [
+ '--- foo',
+ '...'
+ ],
+ name => 'Regression: one_scalar2',
+ },
+ { in => [
+ '--- foo',
+ '--- bar',
+ '...'
+ ],
+ name => 'Regression: two_scalar',
+ error => qr{Missing\s+'[.][.][.]'},
+ },
+ { out => ['foo'],
+ in => [
+ '---',
+ '- foo',
+ '...'
+ ],
+ name => 'Regression: one_list1'
+ },
+ { out => [
+ 'foo',
+ 'bar'
+ ],
+ in => [
+ '---',
+ '- foo',
+ '- bar',
+ '...'
+ ],
+ name => 'Regression: one_list2'
+ },
+ { out => [
+ undef,
+ 'bar'
+ ],
+ in => [
+ '---',
+ '- ~',
+ '- bar',
+ '...'
+ ],
+ name => 'Regression: one_listundef'
+ },
+ { out => { 'foo' => 'bar' },
+ in => [
+ '---',
+ 'foo: bar',
+ '...'
+ ],
+ name => 'Regression: one_hash1'
+ },
+ { out => {
+ 'foo' => 'bar',
+ 'this' => undef
+ },
+ in => [
+ '---',
+ 'foo: bar',
+ 'this: ~',
+ '...'
+ ],
+ name => 'Regression: one_hash2'
+ },
+ { out => {
+ 'foo' => [
+ 'bar',
+ undef,
+ 'baz'
+ ]
+ },
+ in => [
+ '---',
+ 'foo:',
+ ' - bar',
+ ' - ~',
+ ' - baz',
+ '...'
+ ],
+ name => 'Regression: array_in_hash'
+ },
+ { out => {
+ 'bar' => { 'foo' => 'bar' },
+ 'foo' => undef
+ },
+ in => [
+ '---',
+ 'foo: ~',
+ 'bar:',
+ ' foo: bar',
+ '...'
+ ],
+ name => 'Regression: hash_in_hash'
+ },
+ { out => [
+ { 'foo' => undef,
+ 'this' => 'that'
+ },
+ 'foo', undef,
+ { 'foo' => 'bar',
+ 'this' => 'that'
+ }
+ ],
+ in => [
+ '---',
+ '-',
+ ' foo: ~',
+ ' this: that',
+ '- foo',
+ '- ~',
+ '-',
+ ' foo: bar',
+ ' this: that',
+ '...'
+ ],
+ name => 'Regression: hash_in_array'
+ },
+ { out => ['foo'],
+ in => [
+ '---',
+ '- \'foo\'',
+ '...'
+ ],
+ name => 'Regression: single_quote1'
+ },
+ { out => [' '],
+ in => [
+ '---',
+ '- \' \'',
+ '...'
+ ],
+ name => 'Regression: single_spaces'
+ },
+ { out => [''],
+ in => [
+ '---',
+ '- \'\'',
+ '...'
+ ],
+ name => 'Regression: single_null'
+ },
+ { out => ' ',
+ in => [
+ '--- " "',
+ '...'
+ ],
+ name => 'Regression: only_spaces'
+ },
+ { out => [
+ undef,
+ { 'foo' => 'bar',
+ 'this' => 'that'
+ },
+ 'baz'
+ ],
+ in => [
+ '---',
+ '- ~',
+ '- foo: bar',
+ ' this: that',
+ '- baz',
+ '...'
+ ],
+ name => 'Regression: inline_nested_hash'
+ },
+ { name => "Unprintables",
+ in => [
+ "---",
+ "- \"\\z\\x01\\x02\\x03\\x04\\x05\\x06\\a\\x08\\t\\n\\v\\f\\r\\x0e\\x0f\"",
+ "- \"\\x10\\x11\\x12\\x13\\x14\\x15\\x16\\x17\\x18\\x19\\x1a\\e\\x1c\\x1d\\x1e\\x1f\"",
+ "- \" !\\\"#\$%&'()*+,-./\"",
+ "- 0123456789:;<=>?",
+ "- '\@ABCDEFGHIJKLMNO'",
+ "- 'PQRSTUVWXYZ[\\]^_'",
+ "- '`abcdefghijklmno'",
+ "- 'pqrstuvwxyz{|}~\177'",
+ "- \200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217",
+ "- \220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237",
+ "- \240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257",
+ "- \260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277",
+ "- \300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317",
+ "- \320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337",
+ "- \340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357",
+ "- \360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377",
+ "..."
+ ],
+ out => [
+ "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17",
+ "\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37",
+ " !\"#\$%&'()*+,-./",
+ "0123456789:;<=>?",
+ "\@ABCDEFGHIJKLMNO",
+ "PQRSTUVWXYZ[\\]^_",
+ "`abcdefghijklmno",
+ "pqrstuvwxyz{|}~\177",
+ "\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217",
+ "\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237",
+ "\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257",
+ "\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277",
+ "\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317",
+ "\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337",
+ "\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357",
+ "\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377"
+ ],
+ },
+ { name => 'Quoted hash keys',
+ in => [
+ '---',
+ ' "quoted": Magic!',
+ ' "\n\t": newline, tab',
+ '...',
+ ],
+ out => {
+ quoted => 'Magic!',
+ "\n\t" => 'newline, tab',
+ },
+ },
+ { name => 'Empty',
+ in => [],
+ out => undef,
+ },
+ );
+
+ plan tests => @SCHEDULE * 5;
+}
+
+sub iter {
+ my $ar = shift;
+ return sub {
+ return shift @$ar;
+ };
+}
+
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+ ok my $yaml = TAP::Parser::YAMLish::Reader->new, "$name: Created";
+ isa_ok $yaml, 'TAP::Parser::YAMLish::Reader';
+
+ my $source = join( "\n", @{ $test->{in} } ) . "\n";
+
+ my $iter = iter( $test->{in} );
+ my $got = eval { $yaml->read($iter) };
+
+ my $raw = $yaml->get_raw;
+
+ if ( my $err = $test->{error} ) {
+ unless ( like $@, $err, "$name: Error message" ) {
+ diag "Error: $@\n";
+ }
+ ok !$got, "$name: No result";
+ pass;
+ }
+ else {
+ my $want = $test->{out};
+ unless ( ok !$@, "$name: No error" ) {
+ diag "Error: $@\n";
+ }
+ is_deeply $got, $want, "$name: Result matches";
+ is $raw, $source, "$name: Captured source matches";
+ }
+}
diff -urN perl-5.10.0.orig/lib/App/Prove/State/Result/Test.pm perl-5.10.0/lib/App/Prove/State/Result/Test.pm
--- perl-5.10.0.orig/lib/App/Prove/State/Result/Test.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/App/Prove/State/Result/Test.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,153 @@
+package App::Prove::State::Result::Test;
+
+use strict;
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+App::Prove::State::Result::Test - Individual test results.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+my %methods = (
+ name => { method => 'name' },
+ elapsed => { method => 'elapsed', default => 0 },
+ gen => { method => 'generation', default => 1 },
+ last_pass_time => { method => 'last_pass_time', default => undef },
+ last_fail_time => { method => 'last_fail_time', default => undef },
+ last_result => { method => 'result', default => 0 },
+ last_run_time => { method => 'run_time', default => undef },
+ last_todo => { method => 'num_todo', default => 0 },
+ mtime => { method => 'mtime', default => undef },
+ seq => { method => 'sequence', default => 1 },
+ total_passes => { method => 'total_passes', default => 0 },
+ total_failures => { method => 'total_failures', default => 0 },
+ parser => { method => 'parser' },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ bless $arg_for => $class;
+}
+
+=head2 Instance Methods
+
+=head3 C<name>
+
+The name of the test. Usually a filename.
+
+=head3 C<elapsed>
+
+The total elapsed times the test took to run, in seconds from the epoch..
+
+=head3 C<generation>
+
+The number for the "generation" of the test run. The first generation is 1
+(one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_pass_time>
+
+The last time the test program passed, in seconds from the epoch.
+
+Returns C<undef> if the program has never passed.
+
+=head3 C<last_fail_time>
+
+The last time the test suite failed, in seconds from the epoch.
+
+Returns C<undef> if the program has never failed.
+
+=head3 C<mtime>
+
+Returns the mtime of the test, in seconds from the epoch.
+
+=head3 C<raw>
+
+Returns a hashref of raw test data, suitable for serialization by YAML.
+
+=head3 C<result>
+
+Currently, whether or not the test suite passed with no 'problems' (such as
+TODO passed).
+
+=head3 C<run_time>
+
+The total time it took for the test to run, in seconds. If C<Time::HiRes> is
+available, it will have finer granularity.
+
+=head3 C<num_todo>
+
+The number of tests with TODO directives.
+
+=head3 C<sequence>
+
+The order in which this test was run for the given test suite result.
+
+=head3 C<total_passes>
+
+The number of times the test has passed.
+
+=head3 C<total_failures>
+
+The number of times the test has failed.
+
+=head3 C<parser>
+
+The underlying parser object. This is useful if you need the full
+information for the test program.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ # this is backwards-compatibility hack and is not guaranteed.
+ delete $raw{name};
+ delete $raw{parser};
+ return \%raw;
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/App/Prove/State/Result.pm perl-5.10.0/lib/App/Prove/State/Result.pm
--- perl-5.10.0.orig/lib/App/Prove/State/Result.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/App/Prove/State/Result.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,233 @@
+package App::Prove::State::Result;
+
+use strict;
+use Carp 'croak';
+
+use App::Prove::State::Result::Test;
+use vars qw($VERSION);
+
+use constant STATE_VERSION => 1;
+
+=head1 NAME
+
+App::Prove::State::Result - Individual test suite results.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test suite run.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $result = App::Prove::State::Result->new({
+ generation => $generation,
+ tests => \%tests,
+ });
+
+Returns a new C<App::Prove::State::Result> instance.
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ my %instance_data = %$arg_for; # shallow copy
+ $instance_data{version} = $class->state_version;
+ my $tests = delete $instance_data{tests} || {};
+ my $self = bless \%instance_data => $class;
+ $self->_initialize($tests);
+ return $self;
+}
+
+sub _initialize {
+ my ( $self, $tests ) = @_;
+ my %tests;
+ while ( my ( $name, $test ) = each %$tests ) {
+ $tests{$name} = $self->test_class->new(
+ { %$test,
+ name => $name
+ }
+ );
+ }
+ $self->tests( \%tests );
+ return $self;
+}
+
+=head2 C<state_version>
+
+Returns the current version of state storage.
+
+=cut
+
+sub state_version {STATE_VERSION}
+
+=head2 C<test_class>
+
+Returns the name of the class used for tracking individual tests. This class
+should either subclass from C<App::Prove::State::Result::Test> or provide an
+identical interface.
+
+=cut
+
+sub test_class {
+ return 'App::Prove::State::Result::Test';
+}
+
+my %methods = (
+ generation => { method => 'generation', default => 0 },
+ last_run_time => { method => 'last_run_time', default => undef },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head3 C<generation>
+
+Getter/setter for the "generation" of the test suite run. The first
+generation is 1 (one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_run_time>
+
+Getter/setter for the time of the test suite run.
+
+=head3 C<tests>
+
+Returns the tests for a given generation. This is a hashref or a hash,
+depending on context called. The keys to the hash are the individual
+test names and the value is a hashref with various interesting values.
+Each k/v pair might resemble something like this:
+
+ 't/foo.t' => {
+ elapsed => '0.0428488254547119',
+ gen => '7',
+ last_pass_time => '1219328376.07815',
+ last_result => '0',
+ last_run_time => '1219328376.07815',
+ last_todo => '0',
+ mtime => '1191708862',
+ seq => '192',
+ total_passes => '6',
+ }
+
+=cut
+
+sub tests {
+ my $self = shift;
+ if (@_) {
+ $self->{tests} = shift;
+ return $self;
+ }
+ my %tests = %{ $self->{tests} };
+ my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
+ return wantarray ? @tests : \@tests;
+}
+
+=head3 C<test>
+
+ my $test = $result->test('t/customer/create.t');
+
+Returns an individual C<App::Prove::State::Result::Test> instance for the
+given test name (usually the filename). Will return a new
+C<App::Prove::State::Result::Test> instance if the name is not found.
+
+=cut
+
+sub test {
+ my ( $self, $name ) = @_;
+ croak("test() requires a test name") unless defined $name;
+
+ my $tests = $self->{tests} ||= {};
+ if ( my $test = $tests->{$name} ) {
+ return $test;
+ }
+ else {
+ my $test = $self->test_class->new( { name => $name } );
+ $self->{tests}->{$name} = $test;
+ return $test;
+ }
+}
+
+=head3 C<test_names>
+
+Returns an list of test names, sorted by run order.
+
+=cut
+
+sub test_names {
+ my $self = shift;
+ return map { $_->name } $self->tests;
+}
+
+=head3 C<remove>
+
+ $result->remove($test_name); # remove the test
+ my $test = $result->test($test_name); # fatal error
+
+Removes a given test from results. This is a no-op if the test name is not
+found.
+
+=cut
+
+sub remove {
+ my ( $self, $name ) = @_;
+ delete $self->{tests}->{$name};
+ return $self;
+}
+
+=head3 C<num_tests>
+
+Returns the number of tests for a given test suite result.
+
+=cut
+
+sub num_tests { keys %{ shift->{tests} } }
+
+=head3 C<raw>
+
+Returns a hashref of raw results, suitable for serialization by YAML.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ my %tests;
+ foreach my $test ( $self->tests ) {
+ $tests{ $test->name } = $test->raw;
+ }
+ $raw{tests} = \%tests;
+ return \%raw;
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/App/Prove/State.pm perl-5.10.0/lib/App/Prove/State.pm
--- perl-5.10.0.orig/lib/App/Prove/State.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/App/Prove/State.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,510 @@
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+
+use App::Prove::State::Result;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+BEGIN {
+ @ISA = qw( TAP::Base );
+ __PACKAGE__->mk_methods('result_class');
+}
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant NEED_GLOB => IS_WIN32;
+
+=head1 NAME
+
+App::Prove::State - State storage for the C<prove> command.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module implements that state
+and the operations that may be performed on it.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Accepts a hashref with the following key/value pairs:
+
+=over 4
+
+=item * C<store>
+
+The filename of the data store holding the data that App::Prove::State reads.
+
+=item * C<extension> (optional)
+
+The test name extension. Defaults to C<.t>.
+
+=item * C<result_class> (optional)
+
+The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
+
+=back
+
+=cut
+
+# override TAP::Base::new:
+sub new {
+ my $class = shift;
+ my %args = %{ shift || {} };
+
+ my $self = bless {
+ select => [],
+ seq => 1,
+ store => delete $args{store},
+ extension => ( delete $args{extension} || '.t' ),
+ result_class =>
+ ( delete $args{result_class} || 'App::Prove::State::Result' ),
+ }, $class;
+
+ $self->{_} = $self->result_class->new(
+ { tests => {},
+ generation => 1,
+ }
+ );
+ my $store = $self->{store};
+ $self->load($store)
+ if defined $store && -f $store;
+
+ return $self;
+}
+
+=head2 C<result_class>
+
+Getter/setter for the name of the class used for tracking test results. This
+class should either subclass from C<App::Prove::State::Result> or provide an
+identical interface.
+
+=cut
+
+=head2 C<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+ my $self = shift;
+ $self->{extension} = shift if @_;
+ return $self->{extension};
+}
+
+=head2 C<results>
+
+Get the results of the last test run. Returns a C<result_class()> instance.
+
+=cut
+
+sub results {
+ my $self = shift;
+ $self->{_} || $self->result_class->new;
+}
+
+=head2 C<commit>
+
+Save the test results. Should be called after all tests have run.
+
+=cut
+
+sub commit {
+ my $self = shift;
+ if ( $self->{should_save} ) {
+ $self->save;
+ }
+}
+
+=head2 Instance Methods
+
+=head3 C<apply_switch>
+
+Apply a list of switch options to the state.
+
+=over
+
+=item C<last>
+
+Run in the same order as last time
+
+=item C<failed>
+
+Run only the failed tests from last time
+
+=item C<passed>
+
+Run only the passed tests from last time
+
+=item C<all>
+
+Run all tests in normal order
+
+=item C<hot>
+
+Run the tests that most recently failed first
+
+=item C<todo>
+
+Run the tests ordered by number of todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order.
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<save>
+
+Save the state on exit.
+
+=back
+
+=cut
+
+sub apply_switch {
+ my $self = shift;
+ my @opts = @_;
+
+ my $last_gen = $self->results->generation - 1;
+ my $last_run_time = $self->results->last_run_time;
+ my $now = $self->get_time;
+
+ my @switches = map { split /,/ } @opts;
+
+ my %handler = (
+ last => sub {
+ $self->_select(
+ where => sub { $_->generation >= $last_gen },
+ order => sub { $_->sequence }
+ );
+ },
+ failed => sub {
+ $self->_select(
+ where => sub { $_->result != 0 },
+ order => sub { -$_->result }
+ );
+ },
+ passed => sub {
+ $self->_select( where => sub { $_->result == 0 } );
+ },
+ all => sub {
+ $self->_select();
+ },
+ todo => sub {
+ $self->_select(
+ where => sub { $_->num_todo != 0 },
+ order => sub { -$_->num_todo; }
+ );
+ },
+ hot => sub {
+ $self->_select(
+ where => sub { defined $_->last_fail_time },
+ order => sub { $now - $_->last_fail_time }
+ );
+ },
+ slow => sub {
+ $self->_select( order => sub { -$_->elapsed } );
+ },
+ fast => sub {
+ $self->_select( order => sub { $_->elapsed } );
+ },
+ new => sub {
+ $self->_select( order => sub { -$_->mtime } );
+ },
+ old => sub {
+ $self->_select( order => sub { $_->mtime } );
+ },
+ fresh => sub {
+ $self->_select( where => sub { $_->mtime >= $last_run_time } );
+ },
+ save => sub {
+ $self->{should_save}++;
+ },
+ adrian => sub {
+ unshift @switches, qw( hot all save );
+ },
+ );
+
+ while ( defined( my $ele = shift @switches ) ) {
+ my ( $opt, $arg )
+ = ( $ele =~ /^([^:]+):(.*)/ )
+ ? ( $1, $2 )
+ : ( $ele, undef );
+ my $code = $handler{$opt}
+ || croak "Illegal state option: $opt";
+ $code->($arg);
+ }
+}
+
+sub _select {
+ my ( $self, %spec ) = @_;
+ push @{ $self->{select} }, \%spec;
+}
+
+=head3 C<get_tests>
+
+Given a list of args get the names of tests that should run
+
+=cut
+
+sub get_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my %seen;
+
+ my @selected = $self->_query;
+
+ unless ( @argv || @{ $self->{select} } ) {
+ @argv = $recurse ? '.' : 't';
+ croak qq{No tests named and '@argv' directory not found}
+ unless -d $argv[0];
+ }
+
+ push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
+ return grep { !$seen{$_}++ } @selected;
+}
+
+sub _query {
+ my $self = shift;
+ if ( my @sel = @{ $self->{select} } ) {
+ warn "No saved state, selection will be empty\n"
+ unless $self->results->num_tests;
+ return map { $self->_query_clause($_) } @sel;
+ }
+ return;
+}
+
+sub _query_clause {
+ my ( $self, $clause ) = @_;
+ my @got;
+ my $results = $self->results;
+ my $where = $clause->{where} || sub {1};
+
+ # Select
+ for my $name ( $results->test_names ) {
+ next unless -f $name;
+ local $_ = $results->test($name);
+ push @got, $name if $where->();
+ }
+
+ # Sort
+ if ( my $order = $clause->{order} ) {
+ @got = map { $_->[0] }
+ sort {
+ ( defined $b->[1] <=> defined $a->[1] )
+ || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
+ } map {
+ [ $_,
+ do { local $_ = $results->test($_); $order->() }
+ ]
+ } @got;
+ }
+
+ return @got;
+}
+
+sub _get_raw_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my @tests;
+
+ # Do globbing on Win32.
+ @argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
+
+ for my $arg (@argv) {
+ if ( '-' eq $arg ) {
+ push @argv => <STDIN>;
+ chomp(@argv);
+ next;
+ }
+
+ push @tests,
+ sort -d $arg
+ ? $recurse
+ ? $self->_expand_dir_recursive( $arg, $extension )
+ : glob( File::Spec->catfile( $arg, "*$extension" ) )
+ : $arg;
+ }
+ return @tests;
+}
+
+sub _expand_dir_recursive {
+ my ( $self, $dir, $extension ) = @_;
+
+ my @tests;
+ find(
+ { follow => 1, #21938
+ follow_skip => 2,
+ wanted => sub {
+ -f
+ && /\Q$extension\E$/
+ && push @tests => $File::Find::name;
+ }
+ },
+ $dir
+ );
+ return @tests;
+}
+
+=head3 C<observe_test>
+
+Store the results of a test.
+
+=cut
+
+# Store:
+# last fail time
+# last pass time
+# last run time
+# most recent result
+# most recent todos
+# total failures
+# total passes
+# state generation
+# parser
+
+sub observe_test {
+
+ my ( $self, $test_info, $parser ) = @_;
+ my $name = $test_info->[0];
+ my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
+ my $todo = scalar( $parser->todo );
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time,
+
+ my $test = $self->results->test($name);
+
+ $test->sequence( $self->{seq}++ );
+ $test->generation( $self->results->generation );
+
+ $test->run_time($end_time);
+ $test->result($fail);
+ $test->num_todo($todo);
+ $test->elapsed( $end_time - $start_time );
+
+ $test->parser($parser);
+
+ if ($fail) {
+ $test->total_failures( $test->total_failures + 1 );
+ $test->last_fail_time($end_time);
+ }
+ else {
+ $test->total_passes( $test->total_passes + 1 );
+ $test->last_pass_time($end_time);
+ }
+}
+
+=head3 C<save>
+
+Write the state to a file.
+
+=cut
+
+sub save {
+ my ($self) = @_;
+
+ my $store = $self->{store} or return;
+ $self->results->last_run_time( $self->get_time );
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+ local *FH;
+ open FH, ">$store" or croak "Can't write $store ($!)";
+ $writer->write( $self->results->raw, \*FH );
+ close FH;
+}
+
+=head3 C<load>
+
+Load the state from a file
+
+=cut
+
+sub load {
+ my ( $self, $name ) = @_;
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+ local *FH;
+ open FH, "<$name" or croak "Can't read $name ($!)";
+
+ # XXX this is temporary
+ $self->{_} = $self->result_class->new(
+ $reader->read(
+ sub {
+ my $line = <FH>;
+ defined $line && chomp $line;
+ return $line;
+ }
+ )
+ );
+
+ # $writer->write( $self->{tests} || {}, \*FH );
+ close FH;
+ $self->_regen_seq;
+ $self->_prune_and_stamp;
+ $self->results->generation( $self->results->generation + 1 );
+}
+
+sub _prune_and_stamp {
+ my $self = shift;
+
+ my $results = $self->results;
+ my @tests = $self->results->tests;
+ for my $test (@tests) {
+ my $name = $test->name;
+ if ( my @stat = stat $name ) {
+ $test->mtime( $stat[9] );
+ }
+ else {
+ $results->remove($name);
+ }
+ }
+}
+
+sub _regen_seq {
+ my $self = shift;
+ for my $test ( $self->results->tests ) {
+ $self->{seq} = $test->sequence + 1
+ if defined $test->sequence && $test->sequence >= $self->{seq};
+ }
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/App/Prove.pm perl-5.10.0/lib/App/Prove.pm
--- perl-5.10.0.orig/lib/App/Prove.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/App/Prove.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,775 @@
+package App::Prove;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Harness;
+use TAP::Parser::Utils qw( split_shell );
+use File::Spec;
+use Getopt::Long;
+use App::Prove::State;
+use Carp;
+
+=head1 NAME
+
+App::Prove - Implements the C<prove> command.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+L<Test::Harness> provides a command, C<prove>, which runs a TAP based
+test suite and prints a report. The C<prove> command is a minimal
+wrapper around an instance of this module.
+
+=head1 SYNOPSIS
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ $app->run;
+
+=cut
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => $^O eq 'VMS';
+use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
+
+use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
+use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
+
+use constant PLUGINS => 'App::Prove::Plugin';
+
+my @ATTR;
+
+BEGIN {
+ @ISA = qw(TAP::Object);
+
+ @ATTR = qw(
+ archive argv blib show_count color directives exec failures fork
+ formatter harness includes modules plugins jobs lib merge parse quiet
+ really_quiet recurse backwards shuffle taint_fail taint_warn timer
+ verbose warnings_fail warnings_warn show_help show_man show_version
+ state_class test_args state dry extension ignore_exit rules state_manager
+ );
+ __PACKAGE__->mk_methods(@ATTR);
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new C<App::Prove>. Optionally a hash ref of attribute
+initializers may be passed.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ my $args = shift || {};
+
+ # setup defaults:
+ for my $key (qw( argv rc_opts includes modules state plugins rules )) {
+ $self->{$key} = [];
+ }
+ $self->{harness_class} = 'TAP::Harness';
+
+ for my $attr (@ATTR) {
+ if ( exists $args->{$attr} ) {
+
+ # TODO: Some validation here
+ $self->{$attr} = $args->{$attr};
+ }
+ }
+
+ my %env_provides_default = (
+ HARNESS_TIMER => 'timer',
+ );
+
+ while ( my ( $env, $attr ) = each %env_provides_default ) {
+ $self->{$attr} = 1 if $ENV{$env};
+ }
+ $self->state_class('App::Prove::State');
+ return $self;
+}
+
+=head3 C<state_class>
+
+Getter/setter for the name of the class used for maintaining state. This
+class should either subclass from C<App::Prove::State> or provide an identical
+interface.
+
+=head3 C<state_manager>
+
+Getter/setter for the instance of the C<state_class>.
+
+=cut
+
+=head3 C<add_rc_file>
+
+ $prove->add_rc_file('myproj/.proverc');
+
+Called before C<process_args> to prepend the contents of an rc file to
+the options.
+
+=cut
+
+sub add_rc_file {
+ my ( $self, $rc_file ) = @_;
+
+ local *RC;
+ open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
+ while ( defined( my $line = <RC> ) ) {
+ push @{ $self->{rc_opts} }, grep $_ && $_ !~ /^#/,
+ $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S*) }xg;
+ }
+ close RC;
+}
+
+=head3 C<process_args>
+
+ $prove->process_args(@args);
+
+Processes the command-line arguments. Attributes will be set
+appropriately. Any filenames may be found in the C<argv> attribute.
+
+Dies on invalid arguments.
+
+=cut
+
+sub process_args {
+ my $self = shift;
+
+ my @rc = RC_FILE;
+ unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
+
+ # Preprocess meta-args.
+ my @args;
+ while ( defined( my $arg = shift ) ) {
+ if ( $arg eq '--norc' ) {
+ @rc = ();
+ }
+ elsif ( $arg eq '--rc' ) {
+ defined( my $rc = shift )
+ or croak "Missing argument to --rc";
+ push @rc, $rc;
+ }
+ elsif ( $arg =~ m{^--rc=(.+)$} ) {
+ push @rc, $1;
+ }
+ else {
+ push @args, $arg;
+ }
+ }
+
+ # Everything after the arisdottle '::' gets passed as args to
+ # test programs.
+ if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
+ my @test_args = splice @args, $stop_at;
+ shift @test_args;
+ $self->{test_args} = \@test_args;
+ }
+
+ # Grab options from RC files
+ $self->add_rc_file($_) for grep -f, @rc;
+ unshift @args, @{ $self->{rc_opts} };
+
+ if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
+ die "Long options should be written with two dashes: ",
+ join( ', ', @bad ), "\n";
+ }
+
+ # And finally...
+
+ {
+ local @ARGV = @args;
+ Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
+
+ # Don't add coderefs to GetOptions
+ GetOptions(
+ 'v|verbose' => \$self->{verbose},
+ 'f|failures' => \$self->{failures},
+ 'l|lib' => \$self->{lib},
+ 'b|blib' => \$self->{blib},
+ 's|shuffle' => \$self->{shuffle},
+ 'color!' => \$self->{color},
+ 'colour!' => \$self->{color},
+ 'count!' => \$self->{show_count},
+ 'c' => \$self->{color},
+ 'D|dry' => \$self->{dry},
+ 'ext=s' => \$self->{extension},
+ 'harness=s' => \$self->{harness},
+ 'ignore-exit' => \$self->{ignore_exit},
+ 'formatter=s' => \$self->{formatter},
+ 'r|recurse' => \$self->{recurse},
+ 'reverse' => \$self->{backwards},
+ 'fork' => \$self->{fork},
+ 'p|parse' => \$self->{parse},
+ 'q|quiet' => \$self->{quiet},
+ 'Q|QUIET' => \$self->{really_quiet},
+ 'e|exec=s' => \$self->{exec},
+ 'm|merge' => \$self->{merge},
+ 'I=s@' => $self->{includes},
+ 'M=s@' => $self->{modules},
+ 'P=s@' => $self->{plugins},
+ 'state=s@' => $self->{state},
+ 'directives' => \$self->{directives},
+ 'h|help|?' => \$self->{show_help},
+ 'H|man' => \$self->{show_man},
+ 'V|version' => \$self->{show_version},
+ 'a|archive=s' => \$self->{archive},
+ 'j|jobs=i' => \$self->{jobs},
+ 'timer' => \$self->{timer},
+ 'T' => \$self->{taint_fail},
+ 't' => \$self->{taint_warn},
+ 'W' => \$self->{warnings_fail},
+ 'w' => \$self->{warnings_warn},
+ 'rules=s@' => $self->{rules},
+ ) or croak('Unable to continue');
+
+ # Stash the remainder of argv for later
+ $self->{argv} = [@ARGV];
+ }
+
+ return;
+}
+
+sub _first_pos {
+ my $want = shift;
+ for ( 0 .. $#_ ) {
+ return $_ if $_[$_] eq $want;
+ }
+ return;
+}
+
+sub _help {
+ my ( $self, $verbosity ) = @_;
+
+ eval('use Pod::Usage 1.12 ()');
+ if ( my $err = $@ ) {
+ die 'Please install Pod::Usage for the --help option '
+ . '(or try `perldoc prove`.)'
+ . "\n ($@)";
+ }
+
+ Pod::Usage::pod2usage( { -verbose => $verbosity } );
+
+ return;
+}
+
+sub _color_default {
+ my $self = shift;
+
+ return -t STDOUT && !IS_WIN32;
+}
+
+sub _get_args {
+ my $self = shift;
+
+ my %args;
+
+ if ( defined $self->color ? $self->color : $self->_color_default ) {
+ $args{color} = 1;
+ }
+ if ( !defined $self->show_count ) {
+ $args{show_count} = 1;
+ }
+ else {
+ $args{show_count} = $self->show_count;
+ }
+
+ if ( $self->archive ) {
+ $self->require_harness( archive => 'TAP::Harness::Archive' );
+ $args{archive} = $self->archive;
+ }
+
+ if ( my $jobs = $self->jobs ) {
+ $args{jobs} = $jobs;
+ }
+
+ if ( my $fork = $self->fork ) {
+ $args{fork} = $fork;
+ }
+
+ if ( my $harness_opt = $self->harness ) {
+ $self->require_harness( harness => $harness_opt );
+ }
+
+ if ( my $formatter = $self->formatter ) {
+ $args{formatter_class} = $formatter;
+ }
+
+ if ( $self->ignore_exit ) {
+ $args{ignore_exit} = 1;
+ }
+
+ if ( $self->taint_fail && $self->taint_warn ) {
+ die '-t and -T are mutually exclusive';
+ }
+
+ if ( $self->warnings_fail && $self->warnings_warn ) {
+ die '-w and -W are mutually exclusive';
+ }
+
+ for my $a (qw( lib switches )) {
+ my $method = "_get_$a";
+ my $val = $self->$method();
+ $args{$a} = $val if defined $val;
+ }
+
+ # Handle verbose, quiet, really_quiet flags
+ my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
+
+ my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
+ keys %verb_map;
+
+ die "Only one of verbose, quiet or really_quiet should be specified\n"
+ if @verb_adj > 1;
+
+ $args{verbosity} = shift @verb_adj || 0;
+
+ for my $a (qw( merge failures timer directives )) {
+ $args{$a} = 1 if $self->$a();
+ }
+
+ $args{errors} = 1 if $self->parse;
+
+ # defined but zero-length exec runs test files as binaries
+ $args{exec} = [ split( /\s+/, $self->exec ) ]
+ if ( defined( $self->exec ) );
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ if ( @{ $self->rules } ) {
+ my @rules;
+ for ( @{ $self->rules } ) {
+ if (/^par=(.*)/) {
+ push @rules, $1;
+ }
+ elsif (/^seq=(.*)/) {
+ push @rules, { seq => $1 };
+ }
+ }
+ $args{rules} = { par => [@rules] };
+ }
+
+ return ( \%args, $self->{harness_class} );
+}
+
+sub _find_module {
+ my ( $self, $class, @search ) = @_;
+
+ croak "Bad module name $class"
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ for my $pfx (@search) {
+ my $name = join( '::', $pfx, $class );
+ eval "require $name";
+ return $name unless $@;
+ }
+
+ eval "require $class";
+ return $class unless $@;
+ return;
+}
+
+sub _load_extension {
+ my ( $self, $name, @search ) = @_;
+
+ my @args = ();
+ if ( $name =~ /^(.*?)=(.*)/ ) {
+ $name = $1;
+ @args = split( /,/, $2 );
+ }
+
+ if ( my $class = $self->_find_module( $name, @search ) ) {
+ $class->import(@args);
+ if ( $class->can('load') ) {
+ $class->load( { app_prove => $self, args => [@args] } );
+ }
+ }
+ else {
+ croak "Can't load module $name";
+ }
+}
+
+sub _load_extensions {
+ my ( $self, $ext, @search ) = @_;
+ $self->_load_extension( $_, @search ) for @$ext;
+}
+
+=head3 C<run>
+
+Perform whatever actions the command line args specified. The C<prove>
+command line tool consists of the following code:
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ exit( $app->run ? 0 : 1 ); # if you need the exit code
+
+=cut
+
+sub run {
+ my $self = shift;
+
+ unless ( $self->state_manager ) {
+ $self->state_manager(
+ $self->state_class->new( { store => STATE_FILE } ) );
+ }
+
+ if ( $self->show_help ) {
+ $self->_help(1);
+ }
+ elsif ( $self->show_man ) {
+ $self->_help(2);
+ }
+ elsif ( $self->show_version ) {
+ $self->print_version;
+ }
+ elsif ( $self->dry ) {
+ print "$_\n" for $self->_get_tests;
+ }
+ else {
+
+ $self->_load_extensions( $self->modules );
+ $self->_load_extensions( $self->plugins, PLUGINS );
+
+ local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
+
+ return $self->_runtests( $self->_get_args, $self->_get_tests );
+ }
+
+ return 1;
+}
+
+sub _get_tests {
+ my $self = shift;
+
+ my $state = $self->state_manager;
+ my $ext = $self->extension;
+ $state->extension($ext) if defined $ext;
+ if ( defined( my $state_switch = $self->state ) ) {
+ $state->apply_switch(@$state_switch);
+ }
+
+ my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
+
+ $self->_shuffle(@tests) if $self->shuffle;
+ @tests = reverse @tests if $self->backwards;
+
+ return @tests;
+}
+
+sub _runtests {
+ my ( $self, $args, $harness_class, @tests ) = @_;
+ my $harness = $harness_class->new($args);
+
+ my $state = $self->state_manager;
+
+ $harness->callback(
+ after_test => sub {
+ $state->observe_test(@_);
+ }
+ );
+
+ $harness->callback(
+ after_runtests => sub {
+ $state->commit(@_);
+ }
+ );
+
+ my $aggregator = $harness->runtests(@tests);
+
+ return !$aggregator->has_errors;
+}
+
+sub _get_switches {
+ my $self = shift;
+ my @switches;
+
+ # notes that -T or -t must be at the front of the switches!
+ if ( $self->taint_fail ) {
+ push @switches, '-T';
+ }
+ elsif ( $self->taint_warn ) {
+ push @switches, '-t';
+ }
+ if ( $self->warnings_fail ) {
+ push @switches, '-W';
+ }
+ elsif ( $self->warnings_warn ) {
+ push @switches, '-w';
+ }
+
+ push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
+
+ return @switches ? \@switches : ();
+}
+
+sub _get_lib {
+ my $self = shift;
+ my @libs;
+ if ( $self->lib ) {
+ push @libs, 'lib';
+ }
+ if ( $self->blib ) {
+ push @libs, 'blib/lib', 'blib/arch';
+ }
+ if ( @{ $self->includes } ) {
+ push @libs, @{ $self->includes };
+ }
+
+ #24926
+ @libs = map { File::Spec->rel2abs($_) } @libs;
+
+ # Huh?
+ return @libs ? \@libs : ();
+}
+
+sub _shuffle {
+ my $self = shift;
+
+ # Fisher-Yates shuffle
+ my $i = @_;
+ while ($i) {
+ my $j = rand $i--;
+ @_[ $i, $j ] = @_[ $j, $i ];
+ }
+ return;
+}
+
+=head3 C<require_harness>
+
+Load a harness replacement class.
+
+ $prove->require_harness($for => $class_name);
+
+=cut
+
+sub require_harness {
+ my ( $self, $for, $class ) = @_;
+
+ my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
+
+ # Emulate Perl's -MModule=arg1,arg2 behaviour
+ $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
+
+ eval("use $class;");
+ die "$class_name is required to use the --$for feature: $@" if $@;
+
+ $self->{harness_class} = $class_name;
+
+ return;
+}
+
+=head3 C<print_version>
+
+Display the version numbers of the loaded L<TAP::Harness> and the
+current Perl.
+
+=cut
+
+sub print_version {
+ my $self = shift;
+ printf(
+ "TAP::Harness v%s and Perl v%vd\n",
+ $TAP::Harness::VERSION, $^V
+ );
+
+ return;
+}
+
+1;
+
+# vim:ts=4:sw=4:et:sta
+
+__END__
+
+=head2 Attributes
+
+After command line parsing the following attributes reflect the values
+of the corresponding command line switches. They may be altered before
+calling C<run>.
+
+=over
+
+=item C<archive>
+
+=item C<argv>
+
+=item C<backwards>
+
+=item C<blib>
+
+=item C<color>
+
+=item C<directives>
+
+=item C<dry>
+
+=item C<exec>
+
+=item C<extension>
+
+=item C<failures>
+
+=item C<fork>
+
+=item C<formatter>
+
+=item C<harness>
+
+=item C<ignore_exit>
+
+=item C<includes>
+
+=item C<jobs>
+
+=item C<lib>
+
+=item C<merge>
+
+=item C<modules>
+
+=item C<parse>
+
+=item C<plugins>
+
+=item C<quiet>
+
+=item C<really_quiet>
+
+=item C<recurse>
+
+=item C<rules>
+
+=item C<show_count>
+
+=item C<show_help>
+
+=item C<show_man>
+
+=item C<show_version>
+
+=item C<shuffle>
+
+=item C<state>
+
+=item C<state_class>
+
+=item C<taint_fail>
+
+=item C<taint_warn>
+
+=item C<test_args>
+
+=item C<timer>
+
+=item C<verbose>
+
+=item C<warnings_fail>
+
+=item C<warnings_warn>
+
+=back
+
+=head1 PLUGINS
+
+C<App::Prove> provides support for 3rd-party plugins. These are currently
+loaded at run-time, I<after> arguments have been parsed (so you can not
+change the way arguments are processed, sorry), typically with the
+C<< -PI<plugin> >> switch, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass an argument to your plugin by appending an C<=> after the plugin
+name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
+
+ prove -PMyPlugin=foo,bar,baz
+
+These are passed in to your plugin's C<load()> class method (if it has one),
+along with a reference to the C<App::Prove> object that is invoking your plugin:
+
+ sub load {
+ my ($class, $p) = @_;
+
+ my @args = @{ $p->{args} };
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ $p->{app_prove}->do_something;
+ ...
+ }
+
+Note that the user's arguments are also passed to your plugin's C<import()>
+function as a list, eg:
+
+ sub import {
+ my ($class, @args) = @_;
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ ...
+ }
+
+This is for backwards compatibility, and may be deprecated in the future.
+
+=head2 Sample Plugin
+
+Here's a sample plugin, for your reference:
+
+ package App::Prove::Plugin::Foo;
+
+ # Sample plugin, try running with:
+ # prove -PFoo=bar -r -j3
+ # prove -PFoo -Q
+ # prove -PFoo=bar,My::Formatter
+
+ use strict;
+ use warnings;
+
+ sub load {
+ my ($class, $p) = @_;
+ my @args = @{ $p->{args} };
+ my $app = $p->{app_prove};
+
+ print "loading plugin: $class, args: ", join(', ', @args ), "\n";
+
+ # turn on verbosity
+ $app->verbose( 1 );
+
+ # set the formatter?
+ $app->formatter( $args[1] ) if @args > 1;
+
+ # print some of App::Prove's state:
+ for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
+ my $val = $app->$attr;
+ $val = 'undef' unless defined( $val );
+ print "$attr: $val\n";
+ }
+
+ return 1;
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<prove>, L<TAP::Harness>
+
+=cut
diff -urN perl-5.10.0.orig/lib/TAP/Base.pm perl-5.10.0/lib/TAP/Base.pm
--- perl-5.10.0.orig/lib/TAP/Base.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Base.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,131 @@
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser>
+and L<TAP::Harness>
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+my $GOT_TIME_HIRES;
+
+BEGIN {
+ eval 'use Time::HiRes qw(time);';
+ $GOT_TIME_HIRES = $@ ? 0 : 1;
+}
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
+
+ # ... later ...
+
+ my $thing = TAP::Whatever->new();
+
+ $thing->callback( event => sub {
+ # do something interesting
+ } );
+
+=head1 DESCRIPTION
+
+C<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for, $ok_callback ) = @_;
+
+ my %ok_map = map { $_ => 1 } @$ok_callback;
+
+ $self->{ok_callbacks} = \%ok_map;
+
+ if ( my $cb = delete $arg_for->{callbacks} ) {
+ while ( my ( $event, $callback ) = each %$cb ) {
+ $self->callback( $event, $callback );
+ }
+ }
+
+ return $self;
+}
+
+=head3 C<callback>
+
+Install a callback for a named event.
+
+=cut
+
+sub callback {
+ my ( $self, $event, $callback ) = @_;
+
+ my %ok_map = %{ $self->{ok_callbacks} };
+
+ $self->_croak('No callbacks may be installed')
+ unless %ok_map;
+
+ $self->_croak( "Callback $event is not supported. Valid callbacks are "
+ . join( ', ', sort keys %ok_map ) )
+ unless exists $ok_map{$event};
+
+ push @{ $self->{code_for}{$event} }, $callback;
+
+ return;
+}
+
+sub _has_callbacks {
+ my $self = shift;
+ return keys %{ $self->{code_for} } != 0;
+}
+
+sub _callback_for {
+ my ( $self, $event ) = @_;
+ return $self->{code_for}{$event};
+}
+
+sub _make_callback {
+ my $self = shift;
+ my $event = shift;
+
+ my $cb = $self->_callback_for($event);
+ return unless defined $cb;
+ return map { $_->(@_) } @$cb;
+}
+
+=head3 C<get_time>
+
+Return the current time using Time::HiRes if available.
+
+=cut
+
+sub get_time { return time() }
+
+=head3 C<time_is_hires>
+
+Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
+
+=cut
+
+sub time_is_hires { return $GOT_TIME_HIRES }
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/Base.pm perl-5.10.0/lib/TAP/Formatter/Base.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/Base.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Base.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,438 @@
+package TAP::Formatter::Base;
+
+use strict;
+use TAP::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+my $MAX_ERRORS = 5;
+my %VALIDATION_FOR;
+
+BEGIN {
+ @ISA = qw(TAP::Base);
+
+ %VALIDATION_FOR = (
+ directives => sub { shift; shift },
+ verbosity => sub { shift; shift },
+ timer => sub { shift; shift },
+ failures => sub { shift; shift },
+ errors => sub { shift; shift },
+ color => sub { shift; shift },
+ jobs => sub { shift; shift },
+ show_count => sub { shift; shift },
+ stdout => sub {
+ my ( $self, $ref ) = @_;
+ $self->_croak("option 'stdout' needs a filehandle")
+ unless ( ref $ref || '' ) eq 'GLOB'
+ or eval { $ref->can('print') };
+ return $ref;
+ },
+ );
+
+ my @getter_setters = qw(
+ _longest
+ _printed_summary_header
+ _colorizer
+ );
+
+ __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
+}
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ $self->verbosity(0);
+
+ for my $name ( keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+ $self->$name( $self->$validate($property) );
+ }
+ }
+
+ if ( my @props = keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ $self->stdout( \*STDOUT ) unless $self->stdout;
+
+ if ( $self->color ) {
+ require TAP::Formatter::Color;
+ $self->_colorizer( TAP::Formatter::Color->new );
+ }
+
+ return $self;
+}
+
+sub verbose { shift->verbosity >= 1 }
+sub quiet { shift->verbosity <= -1 }
+sub really_quiet { shift->verbosity <= -2 }
+sub silent { shift->verbosity <= -3 }
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbose => 1,
+ )
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console> object. If
+a L<TAP::Harness> is created with no C<formatter> a
+C<TAP::Formatter::Console> is automatically created. If any of the
+following options were given to TAP::Harness->new they well be passed to
+this constructor which accepts an optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level.
+
+=item * C<verbose>
+
+Printing individual test results to STDOUT.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<quiet>
+
+Suppressing some test output (mostly failures while tests are running).
+
+=item * C<really_quiet>
+
+Suppressing everything but the tests summary.
+
+=item * C<silent>
+
+Suppressing all output.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be made
+in the summary report. To see all of the parse errors, set this argument to
+true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose> or C<failures>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> is not
+defined it will default to color output if color support is available on
+the current platform and output is not being redirected.
+
+=item * C<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+Called by Test::Harness before any test output is generated.
+
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ }
+
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";
+
+ if ( $self->timer ) {
+ my $stamp = $self->_format_now();
+ return "$stamp $name$periods";
+ }
+ else {
+ return "$name$periods";
+ }
+
+}
+
+=head3 C<open_test>
+
+Called to create a new test session. A test session looks like this:
+
+ my $session = $formatter->open_test( $test, $parser );
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+ $session->close_test;
+
+=cut
+
+sub open_test {
+ die "Unimplemented.";
+}
+
+=head3 C<summary>
+
+ $harness->summary( $aggregate );
+
+C<summary> prints the summary report after all tests are run. The argument is
+an aggregate.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+
+ return if $self->silent;
+
+ my @t = $aggregate->descriptions;
+ my $tests = \@t;
+
+ my $runtime = $aggregate->elapsed_timestr;
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+
+ if ( $self->timer ) {
+ $self->_output( $self->_format_now(), "\n" );
+ }
+
+ # TODO: Check this condition still works when all subtests pass but
+ # the exit status is nonzero
+
+ if ( $aggregate->all_passed ) {
+ $self->_output("All tests successful.\n");
+ }
+
+ # ~TODO option where $aggregate->skipped generates reports
+ if ( $total != $passed or $aggregate->has_problems ) {
+ $self->_output("\nTest Summary Report");
+ $self->_output("\n-------------------\n");
+ foreach my $test (@$tests) {
+ $self->_printed_summary_header(0);
+ my ($parser) = $aggregate->parsers($test);
+ $self->_output_summary_failure(
+ 'failed',
+ [ ' Failed test: ', ' Failed tests: ' ],
+ $test, $parser
+ );
+ $self->_output_summary_failure(
+ 'todo_passed',
+ " TODO passed: ", $test, $parser
+ );
+
+ # ~TODO this cannot be the default
+ #$self->_output_summary_failure( 'skipped', " Tests skipped: " );
+
+ if ( my $exit = $parser->exit ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero exit status: $exit\n");
+ }
+ elsif ( my $wait = $parser->wait ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero wait status: $wait\n");
+ }
+
+ if ( my @errors = $parser->parse_errors ) {
+ my $explain;
+ if ( @errors > $MAX_ERRORS && !$self->errors ) {
+ $explain
+ = "Displayed the first $MAX_ERRORS of "
+ . scalar(@errors)
+ . " TAP syntax errors.\n"
+ . "Re-run prove with the -p option to see them all.\n";
+ splice @errors, $MAX_ERRORS;
+ }
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(
+ sprintf " Parse errors: %s\n",
+ shift @errors
+ );
+ foreach my $error (@errors) {
+ my $spaces = ' ' x 16;
+ $self->_failure_output("$spaces$error\n");
+ }
+ $self->_failure_output($explain) if $explain;
+ }
+ }
+ }
+ my $files = @$tests;
+ $self->_output("Files=$files, Tests=$total, $runtime\n");
+ my $status = $aggregate->get_status;
+ $self->_output("Result: $status\n");
+}
+
+sub _output_summary_failure {
+ my ( $self, $method, $name, $test, $parser ) = @_;
+
+ # ugly hack. Must rethink this :(
+ my $output = $method eq 'failed' ? '_failure_output' : '_output';
+
+ if ( my @r = $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ my ( $singular, $plural )
+ = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
+ $self->$output( @r == 1 ? $singular : $plural );
+ my @results = $self->_balanced_range( 40, @r );
+ $self->$output( sprintf "%s\n" => shift @results );
+ my $spaces = ' ' x 16;
+ while (@results) {
+ $self->$output( sprintf "$spaces%s\n" => shift @results );
+ }
+ }
+}
+
+sub _summary_test_header {
+ my ( $self, $test, $parser ) = @_;
+ return if $self->_printed_summary_header;
+ my $spaces = ' ' x ( $self->_longest - length $test );
+ $spaces = ' ' unless $spaces;
+ my $output = $self->_get_output_method($parser);
+ $self->$output(
+ sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
+ $parser->wait, $parser->tests_run, scalar $parser->failed
+ );
+ $self->_printed_summary_header(1);
+}
+
+sub _output {
+ my $self = shift;
+
+ print { $self->stdout } @_;
+}
+
+sub _failure_output {
+ my $self = shift;
+
+ $self->_output(@_);
+}
+
+sub _balanced_range {
+ my ( $self, $limit, @range ) = @_;
+ @range = $self->_range(@range);
+ my $line = "";
+ my @lines;
+ my $curr = 0;
+ while (@range) {
+ if ( $curr < $limit ) {
+ my $range = ( shift @range ) . ", ";
+ $line .= $range;
+ $curr += length $range;
+ }
+ elsif (@range) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ $line = '';
+ $curr = 0;
+ }
+ }
+ if ($line) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ }
+ return @lines;
+}
+
+sub _range {
+ my ( $self, @numbers ) = @_;
+
+ # shouldn't be needed, but subclasses might call this
+ @numbers = sort { $a <=> $b } @numbers;
+ my ( $min, @range );
+
+ foreach my $i ( 0 .. $#numbers ) {
+ my $num = $numbers[$i];
+ my $next = $numbers[ $i + 1 ];
+ if ( defined $next && $next == $num + 1 ) {
+ if ( !defined $min ) {
+ $min = $num;
+ }
+ }
+ elsif ( defined $min ) {
+ push @range => "$min-$num";
+ undef $min;
+ }
+ else {
+ push @range => $num;
+ }
+ }
+ return @range;
+}
+
+sub _get_output_method {
+ my ( $self, $parser ) = @_;
+ return $parser->has_problems ? '_failure_output' : '_output';
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/Color.pm perl-5.10.0/lib/TAP/Formatter/Color.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/Color.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Color.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,148 @@
+package TAP::Formatter::Color;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+
+@ISA = qw(TAP::Object);
+
+my $NO_COLOR;
+
+BEGIN {
+ $NO_COLOR = 0;
+
+ if (IS_WIN32) {
+ eval 'use Win32::Console';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
+
+ # eval here because we might not know about these variables
+ my $fg = eval '$FG_LIGHTGRAY';
+ my $bg = eval '$BG_BLACK';
+
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+
+ my $var;
+ if ( $color eq 'reset' ) {
+ $fg = eval '$FG_LIGHTGRAY';
+ $bg = eval '$BG_BLACK';
+ }
+ elsif ( $color =~ /^on_(.+)$/ ) {
+ $bg = eval '$BG_' . uc($1);
+ }
+ else {
+ $fg = eval '$FG_' . uc($color);
+ }
+
+ # In case of colors that aren't defined
+ $self->set_color('reset')
+ unless defined $bg && defined $fg;
+
+ $console->Attr( $bg | $fg );
+ };
+ }
+ }
+ else {
+ eval 'use Term::ANSIColor';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+ $output->( color($color) );
+ };
+ }
+ }
+
+ if ($NO_COLOR) {
+ *set_color = sub { };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Color - Run Perl test scripts with color
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+Note that this harness is I<experimental>. You may not like the colors I've
+chosen and I haven't yet provided an easy way to override them.
+
+This test harness is the same as L<TAP::Harness>, but test results are output
+in color. Passing tests are printed in green. Failing tests are in red.
+Skipped tests are blue on a white background and TODO tests are printed in
+white.
+
+If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running
+under Windows) tests will be run without color.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Color;
+ my $harness = TAP::Formatter::Color->new( \%args );
+ $harness->runtests(@tests);
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor returns a new C<TAP::Formatter::Color> object. If
+L<Term::ANSIColor> is not installed, returns undef.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+
+ if ($NO_COLOR) {
+
+ # shorten that message a bit
+ ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
+ warn "Note: Cannot run tests in color: $error\n";
+ return; # abort object construction
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<can_color>
+
+ Test::Formatter::Color->can_color()
+
+Returns a boolean indicating whether or not this module can actually
+generate colored output. This will be false if it could not load the
+modules needed for the current platform.
+
+=cut
+
+sub can_color {
+ return !$NO_COLOR;
+}
+
+=head3 C<set_color>
+
+Set the output color.
+
+=cut
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/Console/ParallelSession.pm perl-5.10.0/lib/TAP/Formatter/Console/ParallelSession.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/Console/ParallelSession.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Console/ParallelSession.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,202 @@
+package TAP::Formatter::Console::ParallelSession;
+
+use strict;
+use File::Spec;
+use File::Path;
+use TAP::Formatter::Console::Session;
+use Carp;
+
+use constant WIDTH => 72; # Because Eric says
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Console::Session);
+
+my %shared;
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ $self->SUPER::_initialize($arg_for);
+ my $formatter = $self->formatter;
+
+ # Horrid bodge. This creates our shared context per harness. Maybe
+ # TAP::Harness should give us this?
+ my $context = $shared{$formatter} ||= $self->_create_shared_context;
+ push @{ $context->{active} }, $self;
+
+ return $self;
+}
+
+sub _create_shared_context {
+ my $self = shift;
+ return {
+ active => [],
+ tests => 0,
+ fails => 0,
+ };
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for L<TAP::Harness>
+when run with multiple L<TAP::Harness/jobs>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+Output test preamble
+
+=cut
+
+sub header {
+}
+
+sub _clear_ruler {
+ my $self = shift;
+ $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
+}
+
+my $now = 0;
+my $start;
+
+my $trailer = '... )===';
+my $chop_length = WIDTH - length $trailer;
+
+sub _output_ruler {
+ my ( $self, $refresh ) = @_;
+ my $new_now = time;
+ return if $new_now == $now and !$refresh;
+ $now = $new_now;
+ $start ||= $now;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $context = $shared{$formatter};
+
+ my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start;
+
+ foreach my $active ( @{ $context->{active} } ) {
+ my $parser = $active->parser;
+ my $tests = $parser->tests_run;
+ my $planned = $parser->tests_planned || '?';
+
+ $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests;
+ }
+ chop $ruler; # Remove a trailing space
+ $ruler .= ')===';
+
+ if ( length $ruler > WIDTH ) {
+ $ruler =~ s/(.{$chop_length}).*/$1$trailer/o;
+ }
+ else {
+ $ruler .= '=' x ( WIDTH - length($ruler) );
+ }
+ $formatter->_output("\r$ruler");
+}
+
+=head3 C<result>
+
+ Called by the harness for each line of TAP it receives .
+
+=cut
+
+sub result {
+ my ( $self, $result ) = @_;
+ my $formatter = $self->formatter;
+
+ # my $really_quiet = $formatter->really_quiet;
+ # my $show_count = $self->_should_show_count;
+
+ if ( $result->is_test ) {
+ my $context = $shared{$formatter};
+ $context->{tests}++;
+
+ my $active = $context->{active};
+ if ( @$active == 1 ) {
+
+ # There is only one test, so use the serial output format.
+ return $self->SUPER::result($result);
+ }
+
+ $self->_output_ruler( $self->parser->tests_run == 1 );
+ }
+ elsif ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+}
+
+=head3 C<clear_for_close>
+
+=cut
+
+sub clear_for_close {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+ my $context = $shared{$formatter};
+ if ( @{ $context->{active} } == 1 ) {
+ $self->SUPER::clear_for_close;
+ }
+ else {
+ $self->_clear_ruler;
+ }
+}
+
+=head3 C<close_test>
+
+=cut
+
+sub close_test {
+ my $self = shift;
+ my $name = $self->name;
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ $self->SUPER::close_test;
+
+ my $active = $context->{active};
+
+ my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
+
+ die "Can't find myself" unless @pos;
+ splice @$active, $pos[0], 1;
+
+ if ( @$active > 1 ) {
+ $self->_output_ruler(1);
+ }
+ elsif ( @$active == 1 ) {
+
+ # Print out "test/name.t ...."
+ $active->[0]->SUPER::header;
+ }
+ else {
+
+ # $self->formatter->_output("\n");
+ delete $shared{$formatter};
+ }
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/Console/Session.pm perl-5.10.0/lib/TAP/Formatter/Console/Session.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/Console/Session.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Console/Session.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,217 @@
+package TAP::Formatter::Console::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+my @ACCESSOR;
+
+BEGIN {
+ my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
+
+ for my $method (@CLOSURE_BINDING) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return ( $self->{_closures} ||= $self->_closures )->{$method}
+ ->(@_);
+ };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::Session - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=cut
+
+sub _get_output_result {
+ my $self = shift;
+
+ my @color_map = (
+ { test => sub { $_->is_test && !$_->is_ok },
+ colors => ['red'],
+ },
+ { test => sub { $_->is_test && $_->has_skip },
+ colors => [
+ 'white',
+ 'on_blue'
+ ],
+ },
+ { test => sub { $_->is_test && $_->has_todo },
+ colors => ['yellow'],
+ },
+ );
+
+ my $formatter = $self->formatter;
+ my $parser = $self->parser;
+
+ return $formatter->_colorizer
+ ? sub {
+ my $result = shift;
+ for my $col (@color_map) {
+ local $_ = $result;
+ if ( $col->{test}->() ) {
+ $formatter->_set_colors( @{ $col->{colors} } );
+ last;
+ }
+ }
+ $formatter->_output( $result->as_string );
+ $formatter->_set_colors('reset');
+ }
+ : sub {
+ $formatter->_output( shift->as_string );
+ };
+}
+
+sub _closures {
+ my $self = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+ my $show_count = $self->show_count;
+
+ my $really_quiet = $formatter->really_quiet;
+ my $quiet = $formatter->quiet;
+ my $verbose = $formatter->verbose;
+ my $directives = $formatter->directives;
+ my $failures = $formatter->failures;
+
+ my $output_result = $self->_get_output_result;
+
+ my $output = '_output';
+ my $plan = '';
+ my $newline_printed = 0;
+
+ my $last_status_printed = 0;
+
+ return {
+ header => sub {
+ $formatter->_output($pretty)
+ unless $really_quiet;
+ },
+
+ result => sub {
+ my $result = shift;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ return if $really_quiet;
+
+ my $is_test = $result->is_test;
+
+ # These are used in close_test - but only if $really_quiet
+ # is false - so it's safe to only set them here unless that
+ # relationship changes.
+
+ if ( !$plan ) {
+ my $planned = $parser->tests_planned || '?';
+ $plan = "/$planned ";
+ }
+ $output = $formatter->_get_output_method($parser);
+
+ if ( $show_count and $is_test ) {
+ my $number = $result->number;
+ my $now = CORE::time;
+
+ # Print status roughly once per second.
+ # We will always get the first number as a side effect of
+ # $last_status_printed starting with the value 0, which $now
+ # will never be. (Unless someone sets their clock to 1970)
+ if ( $last_status_printed != $now ) {
+ $formatter->$output("\r$pretty$number$plan");
+ $last_status_printed = $now;
+ }
+ }
+
+ if (!$quiet
+ && ( ( $verbose && !$failures )
+ || ( $is_test && $failures && !$result->is_ok )
+ || ( $result->has_directive && $directives ) )
+ )
+ {
+ unless ($newline_printed) {
+ $formatter->_output("\n");
+ $newline_printed = 1;
+ }
+ $output_result->($result);
+ $formatter->_output("\n");
+ }
+ },
+
+ clear_for_close => sub {
+ my $spaces
+ = ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
+ $formatter->$output("\r$spaces");
+ },
+
+ close_test => sub {
+ if ( $show_count && !$really_quiet ) {
+ $self->clear_for_close;
+ $formatter->$output("\r$pretty");
+ }
+
+ # Avoid circular references
+ $self->parser(undef);
+ $self->{_closures} = {};
+
+ return if $really_quiet;
+
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output("skipped: $skip_all\n");
+ }
+ elsif ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output("ok$time_report\n");
+ }
+ },
+ };
+}
+
+=head2 C<< clear_for_close >>
+
+=head2 C<< close_test >>
+
+=head2 C<< header >>
+
+=head2 C<< result >>
+
+=cut
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/Console.pm perl-5.10.0/lib/TAP/Formatter/Console.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/Console.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Console.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,84 @@
+package TAP::Formatter::Console;
+
+use strict;
+use TAP::Formatter::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $class
+ = $self->jobs > 1
+ ? 'TAP::Formatter::Console::ParallelSession'
+ : 'TAP::Formatter::Console::Session';
+
+ eval "require $class";
+ $self->_croak($@) if $@;
+
+ my $session = $class->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ show_count => $self->show_count,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+# Use _colorizer delegate to set output color. NOP if we have no delegate
+sub _set_colors {
+ my ( $self, @colors ) = @_;
+ if ( my $colorizer = $self->_colorizer ) {
+ my $output_func = $self->{_output_func} ||= sub {
+ $self->_output(@_);
+ };
+ $colorizer->set_color( $output_func, $_ ) for @colors;
+ }
+}
+
+sub _failure_output {
+ my $self = shift;
+ $self->_set_colors('red');
+ my $out = join '', @_;
+ my $has_newline = chomp $out;
+ $self->_output($out);
+ $self->_set_colors('reset');
+ $self->_output($/)
+ if $has_newline;
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/File/Session.pm perl-5.10.0/lib/TAP/Formatter/File/Session.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/File/Session.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/File/Session.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,109 @@
+package TAP::Formatter::File::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+=head1 NAME
+
+TAP::Formatter::File::Session - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for L<TAP::Harness>.
+It is particularly important when running with parallel tests, as it
+ensures that test results are not interleaved, even when run
+verbosely.
+
+=cut
+
+=head1 METHODS
+
+=head2 result
+
+Stores results for later output, all together.
+
+=cut
+
+sub result {
+ my $self = shift;
+ my $result = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ return;
+ }
+
+ if (!$formatter->quiet
+ && ( ( $formatter->verbose && !$formatter->failures )
+ || ( $result->is_test && $formatter->failures && !$result->is_ok )
+ || ( $result->has_directive && $formatter->directives ) )
+ )
+ {
+ $self->{results} .= $result->as_string . "\n";
+ }
+}
+
+=head2 close_test
+
+When the test file finishes, outputs the summary, together.
+
+=cut
+
+sub close_test {
+ my $self = shift;
+
+ # Avoid circular references
+ $self->parser(undef);
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+
+ return if $formatter->really_quiet;
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output( $pretty . "skipped: $skip_all\n" );
+ }
+ elsif ( $parser->has_problems ) {
+ $formatter->_output(
+ $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) );
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output( $pretty
+ . ( $self->{results} ? "\n" . $self->{results} : "" )
+ . "ok$time_report\n" );
+ }
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/File.pm perl-5.10.0/lib/TAP/Formatter/File.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/File.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/File.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,58 @@
+package TAP::Formatter::File;
+
+use strict;
+use TAP::Formatter::Base ();
+use TAP::Formatter::File::Session;
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::File - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::File;
+ my $harness = TAP::Formatter::File->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $session = TAP::Formatter::File::Session->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+sub _should_show_count {
+ return 0;
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Formatter/Session.pm perl-5.10.0/lib/TAP/Formatter/Session.pm
--- perl-5.10.0.orig/lib/TAP/Formatter/Session.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Session.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,175 @@
+package TAP::Formatter::Session;
+
+use strict;
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+my @ACCESSOR;
+
+BEGIN {
+
+ @ACCESSOR = qw( name formatter parser show_count );
+
+ for my $method (@ACCESSOR) {
+ no strict 'refs';
+ *$method = sub { shift->{$method} };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Session - Abstract base class for harness output delegate
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=item * C<show_count>
+
+=back
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name (@ACCESSOR) {
+ $self->{$name} = delete $arg_for{$name};
+ }
+
+ if ( !defined $self->show_count ) {
+ $self->{show_count} = 1; # defaults to true
+ }
+ if ( $self->show_count ) { # but may be a damned lie!
+ $self->{show_count} = $self->_should_show_count;
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ return $self;
+}
+
+=head3 C<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+Called to close a test session.
+
+=head3 C<clear_for_close>
+
+Called by C<close_test> to clear the line showing test progress, or the parallel
+test ruler, prior to printing the final test result.
+
+=cut
+
+sub header { }
+
+sub result { }
+
+sub close_test { }
+
+sub clear_for_close { }
+
+sub _should_show_count {
+ my $self = shift;
+ return !$self->formatter->verbose && -t $self->formatter->stdout;
+}
+
+sub _output_test_failure {
+ my ( $self, $parser ) = @_;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $tests_run = $parser->tests_run;
+ my $tests_planned = $parser->tests_planned;
+
+ my $total
+ = defined $tests_planned
+ ? $tests_planned
+ : $tests_run;
+
+ my $passed = $parser->passed;
+
+ # The total number of fails includes any tests that were planned but
+ # didn't run
+ my $failed = $parser->failed + $total - $tests_run;
+ my $exit = $parser->exit;
+
+ if ( my $exit = $parser->exit ) {
+ my $wstat = $parser->wait;
+ my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
+ $formatter->_failure_output("Dubious, test returned $status\n");
+ }
+
+ if ( $failed == 0 ) {
+ $formatter->_failure_output(
+ $total
+ ? "All $total subtests passed "
+ : 'No subtests run '
+ );
+ }
+ else {
+ $formatter->_failure_output("Failed $failed/$total subtests ");
+ if ( !$total ) {
+ $formatter->_failure_output("\nNo tests run!");
+ }
+ }
+
+ if ( my $skipped = $parser->skipped ) {
+ $passed -= $skipped;
+ my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
+ $formatter->_output(
+ "\n\t(less $skipped skipped $test: $passed okay)");
+ }
+
+ if ( my $failed = $parser->todo_passed ) {
+ my $test = $failed > 1 ? 'tests' : 'test';
+ $formatter->_output(
+ "\n\t($failed TODO $test unexpectedly succeeded)");
+ }
+
+ $formatter->_output("\n");
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Harness.pm perl-5.10.0/lib/TAP/Harness.pm
--- perl-5.10.0.orig/lib/TAP/Harness.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Harness.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,872 @@
+package TAP::Harness;
+
+use strict;
+use Carp;
+
+use File::Spec;
+use File::Path;
+use IO::Handle;
+
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run test scripts with statistics
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+=head1 DESCRIPTION
+
+This is a simple test harness which allows tests to be run and results
+automatically aggregated and output to STDOUT.
+
+=head1 SYNOPSIS
+
+ use TAP::Harness;
+ my $harness = TAP::Harness->new( \%args );
+ $harness->runtests(@tests);
+
+=cut
+
+my %VALIDATION_FOR;
+my @FORMATTER_ARGS;
+
+sub _error {
+ my $self = shift;
+ return $self->{error} unless @_;
+ $self->{error} = shift;
+}
+
+BEGIN {
+
+ @FORMATTER_ARGS = qw(
+ directives verbosity timer failures errors stdout color show_count
+ );
+
+ %VALIDATION_FOR = (
+ lib => sub {
+ my ( $self, $libs ) = @_;
+ $libs = [$libs] unless 'ARRAY' eq ref $libs;
+
+ return [ map {"-I$_"} @$libs ];
+ },
+ switches => sub { shift; shift },
+ exec => sub { shift; shift },
+ merge => sub { shift; shift },
+ aggregator_class => sub { shift; shift },
+ formatter_class => sub { shift; shift },
+ multiplexer_class => sub { shift; shift },
+ parser_class => sub { shift; shift },
+ scheduler_class => sub { shift; shift },
+ formatter => sub { shift; shift },
+ jobs => sub { shift; shift },
+ fork => sub { shift; shift },
+ test_args => sub { shift; shift },
+ ignore_exit => sub { shift; shift },
+ rules => sub { shift; shift },
+ );
+
+ for my $method ( sort keys %VALIDATION_FOR ) {
+ no strict 'refs';
+ if ( $method eq 'lib' || $method eq 'switches' ) {
+ *{$method} = sub {
+ my $self = shift;
+ unless (@_) {
+ $self->{$method} ||= [];
+ return wantarray
+ ? @{ $self->{$method} }
+ : $self->{$method};
+ }
+ $self->_croak("Too many arguments to method '$method'")
+ if @_ > 1;
+ my $args = shift;
+ $args = [$args] unless ref $args;
+ $self->{$method} = $args;
+ return $self;
+ };
+ }
+ else {
+ *{$method} = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+
+ for my $method (@FORMATTER_ARGS) {
+ no strict 'refs';
+ *{$method} = sub {
+ my $self = shift;
+ return $self->formatter->$method(@_);
+ };
+ }
+}
+
+##############################################################################
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbosity => 1,
+ lib => [ 'lib', 'blib/lib' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an
+optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level:
+
+ 1 verbose Print individual test results to STDOUT.
+ 0 normal
+ -1 quiet Suppress some test output (mostly failures
+ while tests are running).
+ -2 really quiet Suppress everything but the tests summary.
+ -3 silent Suppress everything.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if
+available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<show_count>
+
+Update the running test count during testing.
+
+=item * C<lib>
+
+Accepts a scalar value or array ref of scalar values indicating which
+paths to allowed libraries should be included if Perl tests are
+executed. Naturally, this only makes sense in the context of tests
+written in Perl.
+
+=item * C<switches>
+
+Accepts a scalar value or array ref of scalar values indicating which
+switches should be included if Perl tests are executed. Naturally, this
+only makes sense in the context of tests written in Perl.
+
+=item * C<test_args>
+
+A reference to an C<@INC> style array of arguments to be passed to each
+test program.
+
+=item * C<color>
+
+Attempt to produce color output.
+
+=item * C<exec>
+
+Typically, Perl tests are run through this. However, anything which
+spits out TAP is fine. You can use this argument to specify the name of
+the program (and optional switches) to run your tests with:
+
+ exec => ['/usr/bin/ruby', '-w']
+
+You can also pass a subroutine reference in order to determine and
+return the proper program to run based on a given test script. The
+subroutine reference should expect the TAP::Harness object itself as the
+first argument, and the file name as the second argument. It should
+return an array reference containing the command to be run and including
+the test file name. It can also simply return C<undef>, in which case
+TAP::Harness will fall back on executing the test script in Perl:
+
+ exec => sub {
+ my ( $harness, $test_file ) = @_;
+
+ # Let Perl tests run.
+ return undef if $test_file =~ /[.]t$/;
+ return [ qw( /usr/bin/ruby -w ), $test_file ]
+ if $test_file =~ /[.]rb$/;
+ }
+
+=item * C<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<aggregator_class>
+
+The name of the class to use to aggregate test results. The default is
+L<TAP::Parser::Aggregator>.
+
+=item * C<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
+isn't a TTY.
+
+=item * C<multiplexer_class>
+
+The name of the class to use to multiplex tests during parallel testing.
+The default is L<TAP::Parser::Multiplexer>.
+
+=item * C<parser_class>
+
+The name of the class to use to parse TAP. The default is
+L<TAP::Parser>.
+
+=item * C<scheduler_class>
+
+The name of the class to use to schedule test execution. The default is
+L<TAP::Parser::Scheduler>.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting the
+TAP output. See L<TAP::Formatter::Console> for an example.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be
+made in the summary report. To see all of the parse errors, set this
+argument to true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be
+displayed. This overrides other settings such as C<verbose> or
+C<failures>.
+
+=item * C<ignore_exit>
+
+If set to a true value instruct C<TAP::Parser> to ignore exit and wait
+status from test scripts.
+
+=item * C<jobs>
+
+The maximum number of parallel tests to run at any time. Which tests
+can be run in parallel is controlled by C<rules>. The default is to
+run only one test at a time.
+
+=item * C<fork>
+
+If true the harness will attempt to fork and run the parser for each
+test in a separate process. Currently this option requires
+L<Parallel::Iterator> to be installed.
+
+=item * C<rules>
+
+A reference to a hash of rules that control which tests may be
+executed in parallel. This is an experimental feature and the
+interface may change.
+
+ $harness->rules(
+ { par => [
+ { seq => '../ext/DB_File/t/*' },
+ { seq => '../ext/IO_Compress_Zlib/t/*' },
+ { seq => '../lib/CPANPLUS/*' },
+ { seq => '../lib/ExtUtils/t/*' },
+ '*'
+ ]
+ }
+ );
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+{
+ my @legal_callback = qw(
+ parser_args
+ made_parser
+ before_runtests
+ after_runtests
+ after_test
+ );
+
+ my %default_class = (
+ aggregator_class => 'TAP::Parser::Aggregator',
+ formatter_class => 'TAP::Formatter::Console',
+ multiplexer_class => 'TAP::Parser::Multiplexer',
+ parser_class => 'TAP::Parser',
+ scheduler_class => 'TAP::Parser::Scheduler',
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name ( sort keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+
+ my $value = $self->$validate($property);
+ if ( $self->_error ) {
+ $self->_croak;
+ }
+ $self->$name($value);
+ }
+ }
+
+ $self->jobs(1) unless defined $self->jobs;
+
+ local $default_class{formatter_class} = 'TAP::Formatter::File'
+ unless -t ( $arg_for{stdout} || \*STDOUT );
+
+ while ( my ( $attr, $class ) = each %default_class ) {
+ $self->$attr( $self->$attr() || $class );
+ }
+
+ unless ( $self->formatter ) {
+
+ # This is a little bodge to preserve legacy behaviour. It's
+ # pretty horrible that we know which args are destined for
+ # the formatter.
+ my %formatter_args = ( jobs => $self->jobs );
+ for my $name (@FORMATTER_ARGS) {
+ if ( defined( my $property = delete $arg_for{$name} ) ) {
+ $formatter_args{$name} = $property;
+ }
+ }
+
+ $self->formatter(
+ $self->_construct( $self->formatter_class, \%formatter_args )
+ );
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+
+ return $self;
+ }
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<runtests>
+
+ $harness->runtests(@tests);
+
+Accepts and array of C<@tests> to be run. This should generally be the
+names of test files, but this is not required. Each element in C<@tests>
+will be passed to C<TAP::Parser::new()> as a C<source>. See
+L<TAP::Parser> for more information.
+
+It is possible to provide aliases that will be displayed in place of the
+test name by supplying the test as a reference to an array containing
+C<< [ $test, $alias ] >>:
+
+ $harness->runtests( [ 't/foo.t', 'Foo Once' ],
+ [ 't/foo.t', 'Foo Twice' ] );
+
+Normally it is an error to attempt to run the same test twice. Aliases
+allow you to overcome this limitation by giving each run of the test a
+unique name.
+
+Tests will be run in the order found.
+
+If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
+should name a directory into which a copy of the raw TAP for each test
+will be written. TAP is written to files named for each test.
+Subdirectories will be created as needed.
+
+Returns a L<TAP::Parser::Aggregator> containing the test results.
+
+=cut
+
+sub runtests {
+ my ( $self, @tests ) = @_;
+
+ my $aggregate = $self->_construct( $self->aggregator_class );
+
+ $self->_make_callback( 'before_runtests', $aggregate );
+ $aggregate->start;
+ $self->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop;
+ $self->summary($aggregate);
+ $self->_make_callback( 'after_runtests', $aggregate );
+
+ return $aggregate;
+}
+
+=head3 C<summary>
+
+Output the summary for a TAP::Parser::Aggregator.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+ $self->formatter->summary($aggregate);
+}
+
+sub _after_test {
+ my ( $self, $aggregate, $job, $parser ) = @_;
+
+ $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
+ $aggregate->add( $job->description, $parser );
+}
+
+sub _aggregate_forked {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ eval { require Parallel::Iterator };
+
+ croak "Parallel::Iterator required for --fork option ($@)"
+ if $@;
+
+ my $iter = Parallel::Iterator::iterate(
+ { workers => $self->jobs || 0 },
+ sub {
+ my $job = shift;
+
+ return if $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+
+ while ( defined( my $result = $parser->next ) ) {
+ $self->_bailout($result) if $result->is_bailout;
+ }
+
+ $self->finish_parser( $parser, $session );
+
+ # Can't serialise coderefs...
+ delete $parser->{_iter};
+ delete $parser->{_stream};
+ delete $parser->{_grammar};
+ return $parser;
+ },
+ sub { $scheduler->get_job }
+ );
+
+ while ( my ( $job, $parser ) = $iter->() ) {
+ next if $job->is_spinner;
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+
+ return;
+}
+
+sub _bailout {
+ my ( $self, $result ) = @_;
+ my $explanation = $result->explanation;
+ die "FAILED--Further testing stopped"
+ . ( $explanation ? ": $explanation\n" : ".\n" );
+}
+
+sub _aggregate_parallel {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ my $jobs = $self->jobs;
+ my $mux = $self->_construct( $self->multiplexer_class );
+
+ RESULT: {
+
+ # Keep multiplexer topped up
+ FILL:
+ while ( $mux->parsers < $jobs ) {
+ my $job = $scheduler->get_job;
+
+ # If we hit a spinner stop filling and start running.
+ last FILL if !defined $job || $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+ $mux->add( $parser, [ $session, $job ] );
+ }
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ my ( $session, $job ) = @$stash;
+ if ( defined $result ) {
+ $session->result($result);
+ $self->_bailout($result) if $result->is_bailout;
+ }
+ else {
+
+ # End of parser. Automatically removed from the mux.
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+ redo RESULT;
+ }
+ }
+
+ return;
+}
+
+sub _aggregate_single {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ JOB:
+ while ( my $job = $scheduler->get_job ) {
+ next JOB if $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ if ( $result->is_bailout ) {
+
+ # Keep reading until input is exhausted in the hope
+ # of allowing any pending diagnostics to show up.
+ 1 while $parser->next;
+ $self->_bailout($result);
+ }
+ }
+
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+
+ return;
+}
+
+=head3 C<aggregate_tests>
+
+ $harness->aggregate_tests( $aggregate, @tests );
+
+Run the named tests and display a summary of result. Tests will be run
+in the order found.
+
+Test results will be added to the supplied L<TAP::Parser::Aggregator>.
+C<aggregate_tests> may be called multiple times to run several sets of
+tests. Multiple C<Test::Harness> instances may be used to pass results
+to a single aggregator so that different parts of a complex test suite
+may be run using different C<TAP::Harness> settings. This is useful, for
+example, in the case where some tests should run in parallel but others
+are unsuitable for parallel execution.
+
+ my $formatter = TAP::Formatter::Console->new;
+ my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
+ my $par_harness = TAP::Harness->new(
+ { formatter => $formatter,
+ jobs => 9
+ }
+ );
+ my $aggregator = TAP::Parser::Aggregator->new;
+
+ $aggregator->start();
+ $ser_harness->aggregate_tests( $aggregator, @ser_tests );
+ $par_harness->aggregate_tests( $aggregator, @par_tests );
+ $aggregator->stop();
+ $formatter->summary($aggregator);
+
+Note that for simpler testing requirements it will often be possible to
+replace the above code with a single call to C<runtests>.
+
+Each elements of the @tests array is either
+
+=over
+
+=item * the file name of a test script to run
+
+=item * a reference to a [ file name, display name ] array
+
+=back
+
+When you supply a separate display name it becomes possible to run a
+test more than once; the display name is effectively the alias by which
+the test is known inside the harness. The harness doesn't care if it
+runs the same script more than once when each invocation uses a
+different name.
+
+=cut
+
+sub aggregate_tests {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $jobs = $self->jobs;
+ my $scheduler = $self->make_scheduler(@tests);
+
+ # #12458
+ local $ENV{HARNESS_IS_VERBOSE} = 1
+ if $self->formatter->verbosity > 0;
+
+ # Formatter gets only names.
+ $self->formatter->prepare( map { $_->description } $scheduler->get_all );
+
+ if ( $self->jobs > 1 ) {
+ if ( $self->fork ) {
+ $self->_aggregate_forked( $aggregate, $scheduler );
+ }
+ else {
+ $self->_aggregate_parallel( $aggregate, $scheduler );
+ }
+ }
+ else {
+ $self->_aggregate_single( $aggregate, $scheduler );
+ }
+
+ return;
+}
+
+sub _add_descriptions {
+ my $self = shift;
+
+ # Turn unwrapped scalars into anonymous arrays and copy the name as
+ # the description for tests that have only a name.
+ return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ }
+ map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
+}
+
+=head3 C<make_scheduler>
+
+Called by the harness when it needs to create a
+L<TAP::Parser::Scheduler>. Override in a subclass to provide an
+alternative scheduler. C<make_scheduler> is passed the list of tests
+that was passed to C<aggregate_tests>.
+
+=cut
+
+sub make_scheduler {
+ my ( $self, @tests ) = @_;
+ return $self->_construct(
+ $self->scheduler_class,
+ tests => [ $self->_add_descriptions(@tests) ],
+ rules => $self->rules
+ );
+}
+
+=head3 C<jobs>
+
+Gets or sets the number of concurrent test runs the harness is
+handling. By default, this value is 1 -- for parallel testing, this
+should be set higher.
+
+=head3 C<fork>
+
+If true the harness will attempt to fork and run the parser for each
+test in a separate process. Currently this option requires
+L<Parallel::Iterator> to be installed.
+
+=cut
+
+##############################################################################
+
+=head1 SUBCLASSING
+
+C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
+don't like how a particular feature functions, just override the
+desired methods.
+
+=head2 Methods
+
+TODO: This is out of date
+
+The following methods are ones you may wish to override if you want to
+subclass C<TAP::Harness>.
+
+=head3 C<summary>
+
+ $harness->summary( \%args );
+
+C<summary> prints the summary report after all tests are run. The
+argument is a hashref with the following keys:
+
+=over 4
+
+=item * C<start>
+
+This is created with C<< Benchmark->new >> and it the time the tests
+started. You can print a useful summary time, if desired, with:
+
+ $self->output(
+ timestr( timediff( Benchmark->new, $start_time ), 'nop' ) );
+
+=item * C<tests>
+
+This is an array reference of all test names. To get the L<TAP::Parser>
+object for individual tests:
+
+ my $aggregate = $args->{aggregate};
+ my $tests = $args->{tests};
+
+ for my $name ( @$tests ) {
+ my ($parser) = $aggregate->parsers($test);
+ ... do something with $parser
+ }
+
+This is a bit clunky and will be cleaned up in a later release.
+
+=back
+
+=cut
+
+sub _get_parser_args {
+ my ( $self, $job ) = @_;
+ my $test_prog = $job->filename;
+ my %args = ();
+ my @switches;
+ @switches = $self->lib if $self->lib;
+ push @switches => $self->switches if $self->switches;
+ $args{switches} = \@switches;
+ $args{spool} = $self->_open_spool($test_prog);
+ $args{merge} = $self->merge;
+ $args{ignore_exit} = $self->ignore_exit;
+
+ if ( my $exec = $self->exec ) {
+ $args{exec}
+ = ref $exec eq 'CODE'
+ ? $exec->( $self, $test_prog )
+ : [ @$exec, $test_prog ];
+ $args{source} = $test_prog unless $args{exec};
+ }
+ else {
+ $args{source} = $test_prog;
+ }
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ return \%args;
+}
+
+=head3 C<make_parser>
+
+Make a new parser and display formatter session. Typically used and/or
+overridden in subclasses.
+
+ my ( $parser, $session ) = $harness->make_parser;
+
+=cut
+
+sub make_parser {
+ my ( $self, $job ) = @_;
+
+ my $args = $self->_get_parser_args($job);
+ $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
+ my $parser = $self->_construct( $self->parser_class, $args );
+
+ $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
+ my $session = $self->formatter->open_test( $job->description, $parser );
+
+ return ( $parser, $session );
+}
+
+=head3 C<finish_parser>
+
+Terminate use of a parser. Typically used and/or overridden in
+subclasses. The parser isn't destroyed as a result of this.
+
+=cut
+
+sub finish_parser {
+ my ( $self, $parser, $session ) = @_;
+
+ $session->close_test;
+ $self->_close_spool($parser);
+
+ return $parser;
+}
+
+sub _open_spool {
+ my $self = shift;
+ my $test = shift;
+
+ if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
+
+ my $spool = File::Spec->catfile( $spool_dir, $test );
+
+ # Make the directory
+ my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
+ my $path = File::Spec->catpath( $vol, $dir, '' );
+ eval { mkpath($path) };
+ $self->_croak($@) if $@;
+
+ my $spool_handle = IO::Handle->new;
+ open( $spool_handle, ">$spool" )
+ or $self->_croak(" Can't write $spool ( $! ) ");
+
+ return $spool_handle;
+ }
+
+ return;
+}
+
+sub _close_spool {
+ my $self = shift;
+ my ($parser) = @_;
+
+ if ( my $spool_handle = $parser->delete_spool ) {
+ close($spool_handle)
+ or $self->_croak(" Error closing TAP spool file( $! ) \n ");
+ }
+
+ return;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ unless ($message) {
+ $message = $self->_error;
+ }
+ $self->SUPER::_croak($message);
+
+ return;
+}
+
+=head1 REPLACING
+
+If you like the C<prove> utility and L<TAP::Parser> but you want your
+own harness, all you need to do is write one and provide C<new> and
+C<runtests> methods. Then you can use the C<prove> utility like so:
+
+ prove --harness My::Test::Harness
+
+Note that while C<prove> accepts a list of tests (or things to be
+tested), C<new> has a fairly rich set of arguments. You'll probably want
+to read over this code carefully to see how all of them are being used.
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
diff -urN perl-5.10.0.orig/lib/TAP/Object.pm perl-5.10.0/lib/TAP/Object.pm
--- perl-5.10.0.orig/lib/TAP/Object.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Object.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,139 @@
+package TAP::Object;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Object - Base class that provides common functionality to all C<TAP::*> modules
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use strict;
+ use vars qw(@ISA);
+
+ use TAP::Object;
+
+ @ISA = qw(TAP::Object);
+
+ # new() implementation by TAP::Object
+ sub _initialize {
+ my ( $self, @args) = @_;
+ # initialize your object
+ return $self;
+ }
+
+ # ... later ...
+ my $obj = TAP::Whatever->new(@args);
+
+=head1 DESCRIPTION
+
+C<TAP::Object> provides a default constructor and exception model for all
+C<TAP::*> classes. Exceptions are raised using L<Carp>.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new object. Any arguments passed to C<new> will be passed on to the
+L</_initialize> method. Returns a new object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->_initialize(@_);
+}
+
+=head2 Instance Methods
+
+=head3 C<_initialize>
+
+Initializes a new object. This method is a stub by default, you should override
+it as appropriate.
+
+I<Note:> L</new> expects you to return C<$self> or raise an exception. See
+L</_croak>, and L<Carp>.
+
+=cut
+
+sub _initialize {
+ return $_[0];
+}
+
+=head3 C<_croak>
+
+Raise an exception using C<croak> from L<Carp>, eg:
+
+ $self->_croak( 'why me?', 'aaarrgh!' );
+
+May also be called as a I<class> method.
+
+ $class->_croak( 'this works too' );
+
+=cut
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+ return;
+}
+
+=head3 C<_construct>
+
+Create a new instance of the specified class.
+
+=cut
+
+sub _construct {
+ my ( $self, $class, @args ) = @_;
+
+ $self->_croak("Bad module name $class")
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ unless ( $class->can('new') ) {
+ local $@;
+ eval "require $class";
+ $self->_croak("Can't load $class") if $@;
+ }
+
+ return $class->new(@args);
+}
+
+=head3 C<mk_methods>
+
+Create simple getter/setters.
+
+ __PACKAGE__->mk_methods(@method_names);
+
+=cut
+
+sub mk_methods {
+ my ( $class, @methods ) = @_;
+ foreach my $method_name (@methods) {
+ my $method = "${class}::$method_name";
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method_name} = shift if @_;
+ return $self->{$method_name};
+ };
+ }
+}
+
+1;
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Aggregator.pm perl-5.10.0/lib/TAP/Parser/Aggregator.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Aggregator.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Aggregator.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,416 @@
+package TAP::Parser::Aggregator;
+
+use strict;
+use Benchmark;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Aggregator;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+ $aggregate->add( 't/00-load.t', $load_parser );
+ $aggregate->add( 't/10-lex.t', $lex_parser );
+
+ my $summary = <<'END_SUMMARY';
+ Passed: %s
+ Failed: %s
+ Unexpectedly succeeded: %s
+ END_SUMMARY
+ printf $summary,
+ scalar $aggregate->passed,
+ scalar $aggregate->failed,
+ scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN { # install summary methods
+ %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+ failed
+ parse_errors
+ passed
+ skipped
+ todo
+ todo_passed
+ total
+ wait
+ exit
+ );
+ $SUMMARY_METHOD_FOR{total} = 'tests_run';
+ $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
+
+ foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
+ next if 'total' eq $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return wantarray
+ ? @{ $self->{"descriptions_for_$method"} }
+ : $self->{$method};
+ };
+ }
+} # end install summary methods
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.) It is used as a unique identifier (see e.g.
+L<"parsers">.) Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak( "You already have a parser for ($description)."
+ . " Perhaps you have run the same test twice." );
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+
+ # Slightly nasty. Instead we should maybe have 'cooked' accessors
+ # for results that may be masked by the parser.
+ next
+ if ( $method eq 'exit' || $method eq 'wait' )
+ && $parser->ignore_exit;
+
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method. Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->_get_parsers(@_) if @_;
+ my $descriptions = $self->{parse_order};
+ my @parsers = @{ $self->{parser_for} }{@$descriptions};
+
+ # Note: Because of the way context works, we must assign the parsers to
+ # the @parsers array or else this method does not work as documented.
+ return @parsers;
+}
+
+sub _get_parsers {
+ my ( $self, @descriptions ) = @_;
+ my @parsers;
+ foreach my $description (@descriptions) {
+ $self->_croak("A parser for ($description) could not be found")
+ unless exists $self->{parser_for}{$description};
+ push @parsers => $self->{parser_for}{$description};
+ }
+ return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to
+the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+ my $self = shift;
+ $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+ my $self = shift;
+ $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+ my $self = shift;
+
+ require Carp;
+ Carp::croak
+ q{Can't call elapsed without first calling start and then stop}
+ unless defined $self->{start_time} && defined $self->{end_time};
+ return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>. This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+ my $self = shift;
+
+ my $elapsed = $self->elapsed;
+
+ return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+ my $self = shift;
+ return
+ $self->total
+ && $self->total == $self->passed
+ && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+ my $self = shift;
+
+ my $total = $self->total;
+ my $passed = $self->passed;
+
+ return
+ ( $self->has_errors || $total != $passed ) ? 'FAIL'
+ : $total ? 'PASS'
+ : 'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * planned
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded. This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->todo_passed
+ || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+ if ( $parser->has_errors ) {
+ ...
+ }
+
+Returns true if I<any> of the parsers failed. This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse errors
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Grammar.pm perl-5.10.0/lib/TAP/Parser/Grammar.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Grammar.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Grammar.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,580 @@
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::YAMLish::Reader ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Grammar;
+ my $grammar = $self->make_grammar({
+ stream => $tap_parser_stream,
+ parser => $tap_parser,
+ version => 12,
+ });
+
+ my $result = $grammar->tokenize;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $grammar = TAP::Parser::Grammar->new({
+ stream => $stream,
+ parser => $parser,
+ version => $version,
+ });
+
+Returns L<TAP::Parser> grammar object that will parse the specified stream.
+Both C<stream> and C<parser> are required arguments. If C<version> is not set
+it defaults to C<12> (see L</set_version> for more details).
+
+=cut
+
+# new() implementation supplied by TAP::Object
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{stream} = $args->{stream}; # TODO: accessor
+ $self->{parser} = $args->{parser}; # TODO: accessor
+ $self->set_version( $args->{version} || 12 );
+ return $self;
+}
+
+my %language_for;
+
+{
+
+ # XXX the 'not' and 'ok' might be on separate lines in VMS ...
+ my $ok = qr/(?:not )?ok\b/;
+ my $num = qr/\d+/;
+
+ my %v12 = (
+ version => {
+ syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $version = $1;
+ return $self->_make_version_token( $line, $version, );
+ },
+ },
+ plan => {
+ syntax => qr/^1\.\.(\d+)\s*(.*)\z/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $tail ) = ( $1, $2 );
+ my $explanation = undef;
+ my $skip = '';
+
+ if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
+ my @todo = split /\s+/, _trim($1);
+ return $self->_make_plan_token(
+ $line, $tests_planned, 'TODO',
+ '', \@todo
+ );
+ }
+ elsif ( 0 == $tests_planned ) {
+ $skip = 'SKIP';
+
+ # If we can't match # SKIP the directive should be undef.
+ ($explanation) = $tail =~ /^#\s*SKIP\s+(.*)/i;
+ }
+ elsif ( $tail !~ /^\s*$/ ) {
+ return $self->_make_unknown_token($line);
+ }
+
+ $explanation = '' unless defined $explanation;
+
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+
+ },
+ },
+
+ # An optimization to handle the most common test lines without
+ # directives.
+ simple_test => {
+ syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+
+ return $self->_make_test_token(
+ $line, $ok, $num,
+ $desc
+ );
+ },
+ },
+ test => {
+ syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+ my ( $dir, $explanation ) = ( '', '' );
+ if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
+ \# \s* (SKIP|TODO) \b \s* (.*) $/ix
+ )
+ {
+ ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
+ }
+ return $self->_make_test_token(
+ $line, $ok, $num, $desc,
+ $dir, $explanation
+ );
+ },
+ },
+ comment => {
+ syntax => qr/^#(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $comment = $1;
+ return $self->_make_comment_token( $line, $comment );
+ },
+ },
+ bailout => {
+ syntax => qr/^Bail out!\s*(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $explanation = $1;
+ return $self->_make_bailout_token(
+ $line,
+ $explanation
+ );
+ },
+ },
+ );
+
+ my %v13 = (
+ %v12,
+ plan => {
+ syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $explanation ) = ( $1, $2 );
+ my $skip
+ = ( 0 == $tests_planned || defined $explanation )
+ ? 'SKIP'
+ : '';
+ $explanation = '' unless defined $explanation;
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+ },
+ },
+ yaml => {
+ syntax => qr/^ (\s+) (---.*) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $pad, $marker ) = ( $1, $2 );
+ return $self->_make_yaml_token( $pad, $marker );
+ },
+ },
+ pragma => {
+ syntax =>
+ qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $pragmas = $1;
+ return $self->_make_pragma_token( $line, $pragmas );
+ },
+ },
+ );
+
+ %language_for = (
+ '12' => {
+ tokens => \%v12,
+ },
+ '13' => {
+ tokens => \%v13,
+ setup => sub {
+ shift->{stream}->handle_unicode;
+ },
+ },
+ );
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<set_version>
+
+ $grammar->set_version(13);
+
+Tell the grammar which TAP syntax version to support. The lowest
+supported version is 12. Although 'TAP version' isn't valid version 12
+syntax it is accepted so that higher version numbers may be parsed.
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ my $version = shift;
+
+ if ( my $language = $language_for{$version} ) {
+ $self->{version} = $version;
+ $self->{tokens} = $language->{tokens};
+
+ if ( my $setup = $language->{setup} ) {
+ $self->$setup();
+ }
+
+ $self->_order_tokens;
+ }
+ else {
+ require Carp;
+ Carp::croak("Unsupported syntax version: $version");
+ }
+}
+
+# Optimization to put the most frequent tokens first.
+sub _order_tokens {
+ my $self = shift;
+
+ my %copy = %{ $self->{tokens} };
+ my @ordered_tokens = grep {defined}
+ map { delete $copy{$_} } qw( simple_test test comment plan );
+ push @ordered_tokens, values %copy;
+
+ $self->{ordered_tokens} = \@ordered_tokens;
+}
+
+##############################################################################
+
+=head3 C<tokenize>
+
+ my $token = $grammar->tokenize;
+
+This method will return a L<TAP::Parser::Result> object representing the
+current line of TAP.
+
+=cut
+
+sub tokenize {
+ my $self = shift;
+
+ my $line = $self->{stream}->next;
+ unless ( defined $line ) {
+ delete $self->{parser}; # break circular ref
+ return;
+ }
+
+ my $token;
+
+ foreach my $token_data ( @{ $self->{ordered_tokens} } ) {
+ if ( $line =~ $token_data->{syntax} ) {
+ my $handler = $token_data->{handler};
+ $token = $self->$handler($line);
+ last;
+ }
+ }
+
+ $token = $self->_make_unknown_token($line) unless $token;
+
+ return $self->{parser}->make_result($token);
+}
+
+##############################################################################
+
+=head3 C<token_types>
+
+ my @types = $grammar->token_types;
+
+Returns the different types of tokens which this grammar can parse.
+
+=cut
+
+sub token_types {
+ my $self = shift;
+ return keys %{ $self->{tokens} };
+}
+
+##############################################################################
+
+=head3 C<syntax_for>
+
+ my $syntax = $grammar->syntax_for($token_type);
+
+Returns a pre-compiled regular expression which will match a chunk of TAP
+corresponding to the token type. For example (not that you should really pay
+attention to this, C<< $grammar->syntax_for('comment') >> will return
+C<< qr/^#(.*)/ >>.
+
+=cut
+
+sub syntax_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{syntax};
+}
+
+##############################################################################
+
+=head3 C<handler_for>
+
+ my $handler = $grammar->handler_for($token_type);
+
+Returns a code reference which, when passed an appropriate line of TAP,
+returns the lexed token corresponding to that line. As a result, the basic
+TAP parsing loop looks similar to the following:
+
+ my @tokens;
+ my $grammar = TAP::Grammar->new;
+ LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
+ foreach my $type ( $grammar->token_types ) {
+ my $syntax = $grammar->syntax_for($type);
+ if ( $line =~ $syntax ) {
+ my $handler = $grammar->handler_for($type);
+ push @tokens => $grammar->$handler($line);
+ next LINE;
+ }
+ }
+ push @tokens => $grammar->_make_unknown_token($line);
+ }
+
+=cut
+
+sub handler_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{handler};
+}
+
+sub _make_version_token {
+ my ( $self, $line, $version ) = @_;
+ return {
+ type => 'version',
+ raw => $line,
+ version => $version,
+ };
+}
+
+sub _make_plan_token {
+ my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
+
+ if ( $directive eq 'SKIP'
+ && 0 != $tests_planned
+ && $self->{version} < 13 )
+ {
+ warn
+ "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+ }
+
+ return {
+ type => 'plan',
+ raw => $line,
+ tests_planned => $tests_planned,
+ directive => $directive,
+ explanation => _trim($explanation),
+ todo_list => $todo,
+ };
+}
+
+sub _make_test_token {
+ my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+ return {
+ ok => $ok,
+ test_num => $num,
+ description => _trim($desc),
+ directive => ( defined $dir ? uc $dir : '' ),
+ explanation => _trim($explanation),
+ raw => $line,
+ type => 'test',
+ };
+}
+
+sub _make_unknown_token {
+ my ( $self, $line ) = @_;
+ return {
+ raw => $line,
+ type => 'unknown',
+ };
+}
+
+sub _make_comment_token {
+ my ( $self, $line, $comment ) = @_;
+ return {
+ type => 'comment',
+ raw => $line,
+ comment => _trim($comment)
+ };
+}
+
+sub _make_bailout_token {
+ my ( $self, $line, $explanation ) = @_;
+ return {
+ type => 'bailout',
+ raw => $line,
+ bailout => _trim($explanation)
+ };
+}
+
+sub _make_yaml_token {
+ my ( $self, $pad, $marker ) = @_;
+
+ my $yaml = TAP::Parser::YAMLish::Reader->new;
+
+ my $stream = $self->{stream};
+
+ # Construct a reader that reads from our input stripping leading
+ # spaces from each line.
+ my $leader = length($pad);
+ my $strip = qr{ ^ (\s{$leader}) (.*) $ }x;
+ my @extra = ($marker);
+ my $reader = sub {
+ return shift @extra if @extra;
+ my $line = $stream->next;
+ return $2 if $line =~ $strip;
+ return;
+ };
+
+ my $data = $yaml->read($reader);
+
+ # Reconstitute input. This is convoluted. Maybe we should just
+ # record it on the way in...
+ chomp( my $raw = $yaml->get_raw );
+ $raw =~ s/^/$pad/mg;
+
+ return {
+ type => 'yaml',
+ raw => $raw,
+ data => $data
+ };
+}
+
+sub _make_pragma_token {
+ my ( $self, $line, $pragmas ) = @_;
+ return {
+ type => 'pragma',
+ raw => $line,
+ pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
+ };
+}
+
+sub _trim {
+ my $data = shift;
+
+ return '' unless defined $data;
+
+ $data =~ s/^\s+//;
+ $data =~ s/\s+$//;
+ return $data;
+}
+
+1;
+
+=head1 TAP GRAMMAR
+
+B<NOTE:> This grammar is slightly out of date. There's still some discussion
+about it and a new one will be provided when we have things better defined.
+
+The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
+stream-based protocol. In fact, it's quite legal to have an infinite stream.
+For the same reason that we don't apply regexes to streams, we're not using a
+formal grammar here. Instead, we parse the TAP in lines.
+
+For purposes for forward compatability, any result which does not match the
+following grammar is currently referred to as
+L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
+
+A formal grammar would look similar to the following:
+
+ (*
+ For the time being, I'm cheating on the EBNF by allowing
+ certain terms to be defined by POSIX character classes by
+ using the following syntax:
+
+ digit ::= [:digit:]
+
+ As far as I am aware, that's not valid EBNF. Sue me. I
+ didn't know how to write "char" otherwise (Unicode issues).
+ Suggestions welcome.
+ *)
+
+ tap ::= version? { comment | unknown } leading_plan lines
+ |
+ lines trailing_plan {comment}
+
+ version ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
+
+ leading_plan ::= plan skip_directive? "\n"
+
+ trailing_plan ::= plan "\n"
+
+ plan ::= '1..' nonNegativeInteger
+
+ lines ::= line {line}
+
+ line ::= (comment | test | unknown | bailout ) "\n"
+
+ test ::= status positiveInteger? description? directive?
+
+ status ::= 'not '? 'ok '
+
+ description ::= (character - (digit | '#')) {character - '#'}
+
+ directive ::= todo_directive | skip_directive
+
+ todo_directive ::= hash_mark 'TODO' ' ' {character}
+
+ skip_directive ::= hash_mark 'SKIP' ' ' {character}
+
+ comment ::= hash_mark {character}
+
+ hash_mark ::= '#' {' '}
+
+ bailout ::= 'Bail out!' {character}
+
+ unknown ::= { (character - "\n") }
+
+ (* POSIX character classes and other terminals *)
+
+ digit ::= [:digit:]
+ character ::= ([:print:] - "\n")
+ positiveInteger ::= ( digit - '0' ) {digit}
+ nonNegativeInteger ::= digit {digit}
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
+do is read through the code. There's no easy way of summarizing it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Result>,
+
+=cut
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Iterator/Array.pm perl-5.10.0/lib/TAP/Parser/Iterator/Array.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Iterator/Array.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator/Array.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,106 @@
+package TAP::Parser::Iterator::Array;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Array;
+ my @data = ('foo', 'bar', baz');
+ my $it = TAP::Parser::Iterator::Array->new(\@data);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for arrays of scalar content, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Takes one argument: an C<$array_ref>
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. For an array iterator this will always
+be zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. For an array iterator this will always
+be zero.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ chomp @$thing;
+ $self->{idx} = 0;
+ $self->{array} = $thing;
+ $self->{exit} = undef;
+ return $self;
+}
+
+sub wait { shift->exit }
+
+sub exit {
+ my $self = shift;
+ return 0 if $self->{idx} >= @{ $self->{array} };
+ return;
+}
+
+sub next_raw {
+ my $self = shift;
+ return $self->{array}->[ $self->{idx}++ ];
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Iterator/Process.pm perl-5.10.0/lib/TAP/Parser/Iterator/Process.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Iterator/Process.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator/Process.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,377 @@
+package TAP::Parser::Iterator::Process;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+use Config;
+use IO::Handle;
+
+@ISA = 'TAP::Parser::Iterator';
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Process;
+ my %args = (
+ command => ['python', 'setup.py', 'test'],
+ merge => 1,
+ setup => sub { ... },
+ teardown => sub { ... },
+ );
+ my $it = TAP::Parser::Iterator::Process->new(\%args);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for executing external processes, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a hashref of the form:
+
+ command => \@command_to_execute
+ merge => $attempt_merge_stderr_and_stdout?
+ setup => $callback_to_setup_command
+ teardown => $callback_to_teardown_command
+
+Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
+process if they are available. Falls back onto C<open()>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through the process output, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator's process.
+
+=head3 C<exit>
+
+Get the exit status for this iterator's process.
+
+=cut
+
+eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+if ($@) {
+ *_wait2exit = sub { $_[1] >> 8 };
+}
+else {
+ *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
+}
+
+sub _use_open3 {
+ my $self = shift;
+ return unless $Config{d_fork} || $IS_WIN32;
+ for my $module (qw( IPC::Open3 IO::Select )) {
+ eval "use $module";
+ return if $@;
+ }
+ return 1;
+}
+
+{
+ my $got_unicode;
+
+ sub _get_unicode {
+ return $got_unicode if defined $got_unicode;
+ eval 'use Encode qw(decode_utf8);';
+ $got_unicode = $@ ? 0 : 1;
+
+ }
+}
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+
+ my @command = @{ delete $args->{command} || [] }
+ or die "Must supply a command to execute";
+
+ # Private. Used to frig with chunk size during testing.
+ my $chunk_size = delete $args->{_chunk_size} || 65536;
+
+ my $merge = delete $args->{merge};
+ my ( $pid, $err, $sel );
+
+ if ( my $setup = delete $args->{setup} ) {
+ $setup->(@command);
+ }
+
+ my $out = IO::Handle->new;
+
+ if ( $self->_use_open3 ) {
+
+ # HOTPATCH {{{
+ my $xclose = \&IPC::Open3::xclose;
+ local $^W; # no warnings
+ local *IPC::Open3::xclose = sub {
+ my $fh = shift;
+ no strict 'refs';
+ return if ( fileno($fh) == fileno(STDIN) );
+ $xclose->($fh);
+ };
+
+ # }}}
+
+ if ($IS_WIN32) {
+ $err = $merge ? '' : '>&STDERR';
+ eval {
+ $pid = open3(
+ '<&STDIN', $out, $merge ? '' : $err,
+ @command
+ );
+ };
+ die "Could not execute (@command): $@" if $@;
+ if ( $] >= 5.006 ) {
+
+ # Kludge to avoid warning under 5.5
+ eval 'binmode($out, ":crlf")';
+ }
+ }
+ else {
+ $err = $merge ? '' : IO::Handle->new;
+ eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
+ die "Could not execute (@command): $@" if $@;
+ $sel = $merge ? undef : IO::Select->new( $out, $err );
+ }
+ }
+ else {
+ $err = '';
+ my $command
+ = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
+ open( $out, "$command|" )
+ or die "Could not execute ($command): $!";
+ }
+
+ $self->{out} = $out;
+ $self->{err} = $err;
+ $self->{sel} = $sel;
+ $self->{pid} = $pid;
+ $self->{exit} = undef;
+ $self->{chunk_size} = $chunk_size;
+
+ if ( my $teardown = delete $args->{teardown} ) {
+ $self->{teardown} = sub {
+ $teardown->(@command);
+ };
+ }
+
+ return $self;
+}
+
+=head3 C<handle_unicode>
+
+Upgrade the input stream to handle UTF8.
+
+=cut
+
+sub handle_unicode {
+ my $self = shift;
+
+ if ( $self->{sel} ) {
+ if ( _get_unicode() ) {
+
+ # Make sure our iterator has been constructed and...
+ my $next = $self->{_next} ||= $self->_next;
+
+ # ...wrap it to do UTF8 casting
+ $self->{_next} = sub {
+ my $line = $next->();
+ return decode_utf8($line) if defined $line;
+ return;
+ };
+ }
+ }
+ else {
+ if ( $] >= 5.008 ) {
+ eval 'binmode($self->{out}, ":utf8")';
+ }
+ }
+
+}
+
+##############################################################################
+
+sub wait { shift->{wait} }
+sub exit { shift->{exit} }
+
+sub _next {
+ my $self = shift;
+
+ if ( my $out = $self->{out} ) {
+ if ( my $sel = $self->{sel} ) {
+ my $err = $self->{err};
+ my @buf = ();
+ my $partial = ''; # Partial line
+ my $chunk_size = $self->{chunk_size};
+ return sub {
+ return shift @buf if @buf;
+
+ READ:
+ while ( my @ready = $sel->can_read ) {
+ for my $fh (@ready) {
+ my $got = sysread $fh, my ($chunk), $chunk_size;
+
+ if ( $got == 0 ) {
+ $sel->remove($fh);
+ }
+ elsif ( $fh == $err ) {
+ print STDERR $chunk; # echo STDERR
+ }
+ else {
+ $chunk = $partial . $chunk;
+ $partial = '';
+
+ # Make sure we have a complete line
+ unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
+ my $nl = rindex $chunk, "\n";
+ if ( $nl == -1 ) {
+ $partial = $chunk;
+ redo READ;
+ }
+ else {
+ $partial = substr( $chunk, $nl + 1 );
+ $chunk = substr( $chunk, 0, $nl );
+ }
+ }
+
+ push @buf, split /\n/, $chunk;
+ return shift @buf if @buf;
+ }
+ }
+ }
+
+ # Return partial last line
+ if ( length $partial ) {
+ my $last = $partial;
+ $partial = '';
+ return $last;
+ }
+
+ $self->_finish;
+ return;
+ };
+ }
+ else {
+ return sub {
+ if ( defined( my $line = <$out> ) ) {
+ chomp $line;
+ return $line;
+ }
+ $self->_finish;
+ return;
+ };
+ }
+ }
+ else {
+ return sub {
+ $self->_finish;
+ return;
+ };
+ }
+}
+
+sub next_raw {
+ my $self = shift;
+ return ( $self->{_next} ||= $self->_next )->();
+}
+
+sub _finish {
+ my $self = shift;
+
+ my $status = $?;
+
+ # Avoid circular refs
+ $self->{_next} = sub {return}
+ if $] >= 5.006;
+
+ # If we have a subprocess we need to wait for it to terminate
+ if ( defined $self->{pid} ) {
+ if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+ $status = $?;
+ }
+ }
+
+ ( delete $self->{out} )->close if $self->{out};
+
+ # If we have an IO::Select we also have an error handle to close.
+ if ( $self->{sel} ) {
+ ( delete $self->{err} )->close;
+ delete $self->{sel};
+ }
+ else {
+ $status = $?;
+ }
+
+ # Sometimes we get -1 on Windows. Presumably that means status not
+ # available.
+ $status = 0 if $IS_WIN32 && $status == -1;
+
+ $self->{wait} = $status;
+ $self->{exit} = $self->_wait2exit($status);
+
+ if ( my $teardown = $self->{teardown} ) {
+ $teardown->();
+ }
+
+ return $self;
+}
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {
+ my $self = shift;
+ return grep $_, ( $self->{out}, $self->{err} );
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Iterator/Stream.pm perl-5.10.0/lib/TAP/Parser/Iterator/Stream.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Iterator/Stream.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator/Stream.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,112 @@
+package TAP::Parser::Iterator::Stream;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Stream;
+ open( TEST, 'test.tap' );
+ my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for reading from filehandles, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a filehandle.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ $self->{fh} = $thing;
+ return $self;
+}
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. Always returns zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. Always returns zero.
+
+=cut
+
+sub wait { shift->exit }
+sub exit { shift->{fh} ? () : 0 }
+
+sub next_raw {
+ my $self = shift;
+ my $fh = $self->{fh};
+
+ if ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ return $line;
+ }
+ else {
+ $self->_finish;
+ return;
+ }
+}
+
+sub _finish {
+ my $self = shift;
+ close delete $self->{fh};
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Iterator.pm perl-5.10.0/lib/TAP/Parser/Iterator.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Iterator.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,165 @@
+package TAP::Parser::Iterator;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for general usage
+
+ # to subclass:
+ use vars qw(@ISA);
+ use TAP::Parser::Iterator ();
+ @ISA = qw(TAP::Parser::Iterator);
+ sub _initialize {
+ # see TAP::Object...
+ }
+
+=head1 DESCRIPTION
+
+This is a simple iterator base class that defines L<TAP::Parser>'s iterator
+API. See C<TAP::Parser::IteratorFactory> for the preferred way of creating
+iterators.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Provided by L<TAP::Object>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+B<Note:> this method is abstract and should be overridden.
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub next {
+ my $self = shift;
+ my $line = $self->next_raw;
+
+ # vms nit: When encountering 'not ok', vms often has the 'not' on a line
+ # by itself:
+ # not
+ # ok 1 - 'I hate VMS'
+ if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
+ $line .= ( $self->next_raw || '' );
+ }
+
+ return $line;
+}
+
+sub next_raw {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+=head3 C<handle_unicode>
+
+If necessary switch the input stream to handle unicode. This only has
+any effect for I/O handle based streams.
+
+The default implementation does nothing.
+
+=cut
+
+sub handle_unicode { }
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle-based should return an empty list.
+
+The default implementation does nothing.
+
+=cut
+
+sub get_select_handles {
+ return;
+}
+
+=head3 C<wait>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->wait;
+
+Return the C<wait> status for this iterator.
+
+=head3 C<exit>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->exit;
+
+Return the C<exit> status for this iterator.
+
+=cut
+
+sub wait {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+sub exit {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+You must override the abstract methods as noted above.
+
+=head2 Example
+
+L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
+There's not much point repeating it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/IteratorFactory.pm perl-5.10.0/lib/TAP/Parser/IteratorFactory.pm
--- perl-5.10.0.orig/lib/TAP/Parser/IteratorFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/IteratorFactory.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,171 @@
+package TAP::Parser::IteratorFactory;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::Iterator::Array ();
+use TAP::Parser::Iterator::Stream ();
+use TAP::Parser::Iterator::Process ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::IteratorFactory;
+ my $factory = TAP::Parser::IteratorFactory->new;
+ my $iter = $factory->make_iterator(\*TEST);
+ my $iter = $factory->make_iterator(\@array);
+ my $iter = $factory->make_iterator(\%hash);
+
+ my $line = $iter->next;
+
+=head1 DESCRIPTION
+
+This is a factory class for simple iterator wrappers for arrays, filehandles,
+and hashes. Unless you're subclassing, you probably won't need to use this
+module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_iterator>
+
+Create an iterator. The type of iterator created depends on the arguments to
+the constructor:
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $filehandle );
+
+Creates a I<stream> iterator (see L</make_stream_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $array_reference );
+
+Creates an I<array> iterator (see L</make_array_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference );
+
+Creates a I<process> iterator (see L</make_process_iterator>).
+
+=cut
+
+sub make_iterator {
+ my ( $proto, $thing ) = @_;
+
+ my $ref = ref $thing;
+ if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+ return $proto->make_stream_iterator($thing);
+ }
+ elsif ( $ref eq 'ARRAY' ) {
+ return $proto->make_array_iterator($thing);
+ }
+ elsif ( $ref eq 'HASH' ) {
+ return $proto->make_process_iterator($thing);
+ }
+ else {
+ die "Can't iterate with a $ref";
+ }
+}
+
+=head3 C<make_stream_iterator>
+
+Make a new stream iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Stream>.
+
+=head3 C<make_array_iterator>
+
+Make a new array iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Array>.
+
+=head3 C<make_process_iterator>
+
+Make a new process iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Process>.
+
+=cut
+
+sub make_stream_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Stream->new(@_);
+}
+
+sub make_array_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Array->new(@_);
+}
+
+sub make_process_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Process->new(@_);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=back
+
+=head2 Example
+
+ package MyIteratorFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyStreamIterator;
+ use TAP::Parser::IteratorFactory;
+
+ @ISA = qw( TAP::Parser::IteratorFactory );
+
+ # override stream iterator
+ sub make_stream_iterator {
+ my $proto = shift;
+ MyStreamIterator->new(@_);
+ }
+
+ 1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Multiplexer.pm perl-5.10.0/lib/TAP/Parser/Multiplexer.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Multiplexer.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Multiplexer.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,195 @@
+package TAP::Parser::Multiplexer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use IO::Select;
+use TAP::Object ();
+
+use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
+use constant IS_VMS => $^O eq 'VMS';
+use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+
+@ISA = 'TAP::Object';
+
+=head1 NAME
+
+TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Multiplexer;
+
+ my $mux = TAP::Parser::Multiplexer->new;
+ $mux->add( $parser1, $stash1 );
+ $mux->add( $parser2, $stash2 );
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+ # do stuff
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
+Internally it calls select on the input file handles for those parsers
+to wait for one or more of them to have input available.
+
+See L<TAP::Harness> for an example of its use.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $mux = TAP::Parser::Multiplexer->new;
+
+Returns a new C<TAP::Parser::Multiplexer> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ $self->{select} = IO::Select->new;
+ $self->{avid} = []; # Parsers that can't select
+ $self->{count} = 0;
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $mux->add( $parser, $stash );
+
+Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
+reference that will be returned from C<next> along with the parser and
+the next result.
+
+=cut
+
+sub add {
+ my ( $self, $parser, $stash ) = @_;
+
+ if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
+ my $sel = $self->{select};
+
+ # We have to turn handles into file numbers here because by
+ # the time we want to remove them from our IO::Select they
+ # will already have been closed by the iterator.
+ my @filenos = map { fileno $_ } @handles;
+ for my $h (@handles) {
+ $sel->add( [ $h, $parser, $stash, @filenos ] );
+ }
+
+ $self->{count}++;
+ }
+ else {
+ push @{ $self->{avid} }, [ $parser, $stash ];
+ }
+}
+
+=head3 C<parsers>
+
+ my $count = $mux->parsers;
+
+Returns the number of parsers. Parsers are removed from the multiplexer
+when their input is exhausted.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->{count} + scalar @{ $self->{avid} };
+}
+
+sub _iter {
+ my $self = shift;
+
+ my $sel = $self->{select};
+ my $avid = $self->{avid};
+ my @ready = ();
+
+ return sub {
+
+ # Drain all the non-selectable parsers first
+ if (@$avid) {
+ my ( $parser, $stash ) = @{ $avid->[0] };
+ my $result = $parser->next;
+ shift @$avid unless defined $result;
+ return ( $parser, $stash, $result );
+ }
+
+ unless (@ready) {
+ return unless $sel->count;
+ @ready = $sel->can_read;
+ }
+
+ my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
+ my $result = $parser->next;
+
+ unless ( defined $result ) {
+ $sel->remove(@handles);
+ $self->{count}--;
+
+ # Force another can_read - we may now have removed a handle
+ # thought to have been ready.
+ @ready = ();
+ }
+
+ return ( $parser, $stash, $result );
+ };
+}
+
+=head3 C<next>
+
+Return a result from the next available parser. Returns a list
+containing the parser from which the result came, the stash that
+corresponds with that parser and the result.
+
+ my ( $parser, $stash, $result ) = $mux->next;
+
+If C<$result> is undefined the corresponding parser has reached the end
+of its input (and will automatically be removed from the multiplexer).
+
+When all parsers are exhausted an empty list will be returned.
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ if ( ! defined $result ) {
+ # End of this parser
+ }
+ else {
+ # Process result
+ }
+ }
+ else {
+ # All parsers finished
+ }
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/Bailout.pm perl-5.10.0/lib/TAP/Parser/Result/Bailout.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/Bailout.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Bailout.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Bailout;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Bailout - Bailout result token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a bail out line is encountered.
+
+ 1..5
+ ok 1 - woo hooo!
+ Bail out! Well, so much for "woo hooo!"
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=cut
+
+sub explanation { shift->{bailout} }
+sub as_string { shift->{bailout} }
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/Comment.pm perl-5.10.0/lib/TAP/Parser/Result/Comment.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/Comment.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Comment.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,61 @@
+package TAP::Parser::Result::Comment;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Comment - Comment result token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a comment line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+ # this is a comment
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+Note that this method merely returns the comment preceded by a '# '.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=cut
+
+sub comment { shift->{comment} }
+sub as_string { shift->{raw} }
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/Plan.pm perl-5.10.0/lib/TAP/Parser/Result/Plan.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/Plan.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Plan.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,120 @@
+package TAP::Parser::Result::Plan;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Plan - Plan result token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a plan line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub plan { '1..' . shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<tests_planned>
+
+ my $planned = $result->tests_planned;
+
+Returns the number of tests planned. For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=cut
+
+sub tests_planned { shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $plan->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<explanation>
+
+ my $explanation = $plan->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+=head3 C<todo_list>
+
+ my $todo = $result->todo_list;
+ for ( @$todo ) {
+ ...
+ }
+
+=cut
+
+sub todo_list { shift->{todo_list} }
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/Pragma.pm perl-5.10.0/lib/TAP/Parser/Result/Pragma.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/Pragma.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Pragma.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Pragma;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Pragma - TAP pragma token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a pragma is encountered.
+
+ TAP version 13
+ pragma +strict, -foo
+
+Pragmas are only supported from TAP version 13 onwards.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<pragmas>
+
+if ( $result->is_pragma ) {
+ @pragmas = $result->pragmas;
+}
+
+=cut
+
+sub pragmas {
+ my @pragmas = @{ shift->{pragmas} };
+ return wantarray ? @pragmas : \@pragmas;
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/Test.pm perl-5.10.0/lib/TAP/Parser/Result/Test.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/Test.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Test.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,274 @@
+package TAP::Parser::Result::Test;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system. Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+ my ( $self, $number ) = @_;
+ $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false. See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+ my $self = shift;
+
+ return if $self->is_unplanned;
+
+ # TODO directives reverse the sense of a test.
+ return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+ my $self = shift;
+ return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated. Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+ warn 'actual_passed() is deprecated. Please use "is_actual_ok()"';
+ goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+ if ( $test->todo_passed ) {
+ # test unexpectedly succeeded
+ }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+ my $self = shift;
+ return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn 'todo_failed() is deprecated. Please use "todo_passed()"';
+ goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+This method prints the test as a string. It will probably be similar, but
+not necessarily identical, to the original test line. Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line. If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ my $string = $self->ok . " " . $self->number;
+ if ( my $description = $self->description ) {
+ $string .= " $description";
+ }
+ if ( my $directive = $self->directive ) {
+ my $explanation = $self->explanation;
+ $string .= " # $directive $explanation";
+ }
+ return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+ $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+ print <<'END';
+ ok 1
+ ok 2
+ 1..1
+ END
+
+=cut
+
+sub is_unplanned {
+ my $self = shift;
+ return ( $self->{unplanned} || '' ) unless @_;
+ $self->{unplanned} = !!shift;
+ return $self;
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/Unknown.pm perl-5.10.0/lib/TAP/Parser/Result/Unknown.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/Unknown.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Unknown.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,51 @@
+package TAP::Parser::Result::Unknown;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Unknown - Unknown result token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if the parser does not recognize the token line. For example:
+
+ 1..5
+ VERSION 7
+ ok 1 - woo hooo!
+ ... woo hooo! is cool!
+
+In the above "TAP", the second and fourth lines will generate "Unknown"
+tokens.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/Version.pm perl-5.10.0/lib/TAP/Parser/Result/Version.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/Version.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Version.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Version;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Version - TAP syntax version token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a version line is encountered.
+
+ TAP version 13
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 13.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<version>
+
+ if ( $result->is_version ) {
+ print $result->version;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub version { shift->{version} }
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result/YAML.pm perl-5.10.0/lib/TAP/Parser/Result/YAML.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result/YAML.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/YAML.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,62 @@
+package TAP::Parser::Result::YAML;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::YAML - YAML result token.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a YAML block is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<data>
+
+ if ( $result->is_yaml ) {
+ print $result->data;
+ }
+
+Return the parsed YAML data for this result
+
+=cut
+
+sub data { shift->{data} }
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Result.pm perl-5.10.0/lib/TAP/Parser/Result.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Result.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,300 @@
+package TAP::Parser::Result;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+
+BEGIN {
+
+ # make is_* methods
+ my @attrs = qw( plan pragma test comment bailout version unknown yaml );
+ no strict 'refs';
+ for my $token (@attrs) {
+ my $method = "is_$token";
+ *$method = sub { return $token eq shift->type };
+ }
+}
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::Result - Base class for TAP::Parser output objects
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ # abstract class - not meany to be used directly
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # directly:
+ use TAP::Parser::Result;
+ my $token = {...};
+ my $result = TAP::Parser::Result->new( $token );
+
+=head2 DESCRIPTION
+
+This is a simple base class used by L<TAP::Parser> to store objects that
+represent the current bit of test output data from TAP (usually a single
+line). Unless you're subclassing, you probably won't need to use this module
+directly.
+
+=head2 METHODS
+
+=head3 C<new>
+
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # to use directly:
+ my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+# new() implementation provided by TAP::Object
+
+sub _initialize {
+ my ( $self, $token ) = @_;
+ if ($token) {
+
+ # assign to a hash slice to make a shallow copy of the token.
+ # I guess we could assign to the hash as (by default) there are not
+ # contents, but that seems less helpful if someone wants to subclass us
+ @{$self}{ keys %$token } = values %$token;
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Boolean methods
+
+The following methods all return a boolean value and are to be overridden in
+the appropriate subclass.
+
+=over 4
+
+=item * C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+ 1..3
+
+=item * C<is_pragma>
+
+Indicates whether or not this is a pragma line.
+
+ pragma +strict
+
+=item * C<is_test>
+
+Indicates whether or not this is a test line.
+
+ ok 1 Is OK!
+
+=item * C<is_comment>
+
+Indicates whether or not this is a comment.
+
+ # this is a comment
+
+=item * C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+ Bail out! We're out of dilithium crystals.
+
+=item * C<is_version>
+
+Indicates whether or not this is a TAP version line.
+
+ TAP version 4
+
+=item * C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+ ... this line is junk ...
+
+=item * C<is_yaml>
+
+Indicates whether or not this is a YAML chunk.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head3 C<raw>
+
+ print $result->raw;
+
+Returns the original line of text which was parsed.
+
+=cut
+
+sub raw { shift->{raw} }
+
+##############################################################################
+
+=head3 C<type>
+
+ my $type = $result->type;
+
+Returns the "type" of a token, such as C<comment> or C<test>.
+
+=cut
+
+sub type { shift->{type} }
+
+##############################################################################
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=cut
+
+sub as_string { shift->{raw} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut.
+
+=cut
+
+sub is_ok {1}
+
+##############################################################################
+
+=head3 C<passed>
+
+Deprecated. Please use C<is_ok> instead.
+
+=cut
+
+sub passed {
+ warn 'passed() is deprecated. Please use "is_ok()"';
+ shift->is_ok;
+}
+
+##############################################################################
+
+=head3 C<has_directive>
+
+ if ( $result->has_directive ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO or SKIP directive.
+
+=cut
+
+sub has_directive {
+ my $self = shift;
+ return ( $self->has_todo || $self->has_skip );
+}
+
+##############################################################################
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO directive.
+
+=cut
+
+sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) {
+ ...
+ }
+
+Indicates whether or not the given result has a SKIP directive.
+
+=cut
+
+sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
+
+=head3 C<set_directive>
+
+Set the directive associated with this token. Used internally to fake
+TODO tests.
+
+=cut
+
+sub set_directive {
+ my ( $self, $dir ) = @_;
+ $self->{directive} = $dir;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+Remember: if you want your subclass to be automatically used by the parser,
+you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
+
+If you're creating a completely new result I<type>, you'll probably need to
+subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
+
+=head2 Example
+
+ package MyResult;
+
+ use strict;
+ use vars '@ISA';
+
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ sub as_string { 'My results all look the same' }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::ResultFactory>,
+L<TAP::Parser::Result::Bailout>,
+L<TAP::Parser::Result::Comment>,
+L<TAP::Parser::Result::Plan>,
+L<TAP::Parser::Result::Pragma>,
+L<TAP::Parser::Result::Test>,
+L<TAP::Parser::Result::Unknown>,
+L<TAP::Parser::Result::Version>,
+L<TAP::Parser::Result::YAML>,
+
+=cut
diff -urN perl-5.10.0.orig/lib/TAP/Parser/ResultFactory.pm perl-5.10.0/lib/TAP/Parser/ResultFactory.pm
--- perl-5.10.0.orig/lib/TAP/Parser/ResultFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/ResultFactory.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,189 @@
+package TAP::Parser::ResultFactory;
+
+use strict;
+use vars qw($VERSION @ISA %CLASS_FOR);
+
+use TAP::Object ();
+use TAP::Parser::Result::Bailout ();
+use TAP::Parser::Result::Comment ();
+use TAP::Parser::Result::Plan ();
+use TAP::Parser::Result::Pragma ();
+use TAP::Parser::Result::Test ();
+use TAP::Parser::Result::Unknown ();
+use TAP::Parser::Result::Version ();
+use TAP::Parser::Result::YAML ();
+
+@ISA = 'TAP::Object';
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::ResultFactory;
+ my $token = {...};
+ my $factory = TAP::Parser::ResultFactory->new;
+ my $result = $factory->make_result( $token );
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head2 DESCRIPTION
+
+This is a simple factory class which returns a L<TAP::Parser::Result> subclass
+representing the current bit of test data from TAP (usually a single line).
+It is used primarily by L<TAP::Parser::Grammar>. Unless you're subclassing,
+you probably won't need to use this module directly.
+
+=head2 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_result>
+
+Returns an instance the appropriate class for the test token passed in.
+
+ my $result = TAP::Parser::ResultFactory->make_result($token);
+
+Can also be called as an instance method.
+
+=cut
+
+sub make_result {
+ my ( $proto, $token ) = @_;
+ my $type = $token->{type};
+ return $proto->class_for($type)->new($token);
+}
+
+=head3 C<class_for>
+
+Takes one argument: C<$type>. Returns the class for this $type, or C<croak>s
+with an error.
+
+=head3 C<register_type>
+
+Takes two arguments: C<$type>, C<$class>
+
+This lets you override an existing type with your own custom type, or register
+a completely new type, eg:
+
+ # create a custom result type:
+ package MyResult;
+ use strict;
+ use vars qw(@ISA);
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ # use it:
+ my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
+
+Your custom type should then be picked up automatically by the L<TAP::Parser>.
+
+=cut
+
+BEGIN {
+ %CLASS_FOR = (
+ plan => 'TAP::Parser::Result::Plan',
+ pragma => 'TAP::Parser::Result::Pragma',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+ );
+}
+
+sub class_for {
+ my ( $class, $type ) = @_;
+
+ # return target class:
+ return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
+
+ # or complain:
+ require Carp;
+ Carp::croak("Could not determine class for result type '$type'");
+}
+
+sub register_type {
+ my ( $class, $type, $rclass ) = @_;
+
+ # register it blindly, assume they know what they're doing
+ $CLASS_FOR{$type} = $rclass;
+ return $class;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=item 2
+
+C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
+This I<will> change in a future version!
+
+=item 3
+
+L<TAP::Parser::Result> subclasses will register themselves with
+L<TAP::Parser::ResultFactory> directly:
+
+ package MyFooResult;
+ TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
+
+Of course, it's up to you to decide whether or not to ignore them.
+
+=back
+
+=head2 Example
+
+ package MyResultFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyResult;
+ use TAP::Parser::ResultFactory;
+
+ @ISA = qw( TAP::Parser::ResultFactory );
+
+ # force all results to be 'MyResult'
+ sub class_for {
+ return 'MyResult';
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<TAP::Parser>,
+L<TAP::Parser::Result>,
+L<TAP::Parser::Grammar>
+
+=cut
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Scheduler/Job.pm perl-5.10.0/lib/TAP/Parser/Scheduler/Job.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Scheduler/Job.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Scheduler/Job.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,107 @@
+package TAP::Parser::Scheduler::Job;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Job - A single testing job.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Job;
+
+=head1 DESCRIPTION
+
+Represents a single test 'job'.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Job->new(
+ $name, $desc
+ );
+
+Returns a new C<TAP::Parser::Scheduler::Job> object.
+
+=cut
+
+sub new {
+ my ( $class, $name, $desc, @ctx ) = @_;
+ return bless {
+ filename => $name,
+ description => $desc,
+ @ctx ? ( context => \@ctx ) : (),
+ }, $class;
+}
+
+=head3 C<on_finish>
+
+Register a closure to be called when this job is destroyed.
+
+=cut
+
+sub on_finish {
+ my ( $self, $cb ) = @_;
+ $self->{on_finish} = $cb;
+}
+
+=head3 C<finish>
+
+Called when a job is complete to unlock it.
+
+=cut
+
+sub finish {
+ my $self = shift;
+ if ( my $cb = $self->{on_finish} ) {
+ $cb->($self);
+ }
+}
+
+=head3 C<filename>
+
+=head3 C<description>
+
+=head3 C<context>
+
+=cut
+
+sub filename { shift->{filename} }
+sub description { shift->{description} }
+sub context { @{ shift->{context} || [] } }
+
+=head3 C<as_array_ref>
+
+For backwards compatibility in callbacks.
+
+=cut
+
+sub as_array_ref {
+ my $self = shift;
+ return [ $self->filename, $self->description, $self->{context} ||= [] ];
+}
+
+=head3 C<is_spinner>
+
+Returns false indicating that this is a real job rather than a
+'spinner'. Spinners are returned when the scheduler still has pending
+jobs but can't (because of locking) return one right now.
+
+=cut
+
+sub is_spinner {0}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Scheduler/Spinner.pm perl-5.10.0/lib/TAP/Parser/Scheduler/Spinner.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Scheduler/Spinner.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Scheduler/Spinner.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,53 @@
+package TAP::Parser::Scheduler::Spinner;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Spinner - A no-op job.
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Spinner;
+
+=head1 DESCRIPTION
+
+A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
+the harness to spin (keep executing tests) while the scheduler can't
+return a real job.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Spinner->new;
+
+Returns a new C<TAP::Parser::Scheduler::Spinner> object.
+
+=cut
+
+sub new { bless {}, shift }
+
+=head3 C<is_spinner>
+
+Returns true indicating that is a 'spinner' job. Spinners are returned
+when the scheduler still has pending jobs but can't (because of locking)
+return one right now.
+
+=cut
+
+sub is_spinner {1}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Scheduler.pm perl-5.10.0/lib/TAP/Parser/Scheduler.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Scheduler.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Scheduler.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,312 @@
+package TAP::Parser::Scheduler;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use TAP::Parser::Scheduler::Job;
+use TAP::Parser::Scheduler::Spinner;
+
+=head1 NAME
+
+TAP::Parser::Scheduler - Schedule tests during parallel testing
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $sched = TAP::Parser::Scheduler->new;
+
+Returns a new C<TAP::Parser::Scheduler> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ croak "Need a number of key, value pairs" if @_ % 2;
+
+ my %args = @_;
+ my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+ my $rules = delete $args{rules} || { par => '**' };
+
+ croak "Unknown arg(s): ", join ', ', sort keys %args
+ if keys %args;
+
+ # Turn any simple names into a name, description pair. TODO: Maybe
+ # construct jobs here?
+ my $self = bless {}, $class;
+
+ $self->_set_rules( $rules, $tests );
+
+ return $self;
+}
+
+# Build the scheduler data structure.
+#
+# SCHEDULER-DATA ::= JOB
+# || ARRAY OF ARRAY OF SCHEDULER-DATA
+#
+# The nested arrays are the key to scheduling. The outer array contains
+# a list of things that may be executed in parallel. Whenever an
+# eligible job is sought any element of the outer array that is ready to
+# execute can be selected. The inner arrays represent sequential
+# execution. They can only proceed when the first job is ready to run.
+
+sub _set_rules {
+ my ( $self, $rules, $tests ) = @_;
+ my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
+ map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+ my $schedule = $self->_rule_clause( $rules, \@tests );
+
+ # If any tests are left add them as a sequential block at the end of
+ # the run.
+ $schedule = [ [ $schedule, @tests ] ] if @tests;
+
+ $self->{schedule} = $schedule;
+}
+
+sub _rule_clause {
+ my ( $self, $rule, $tests ) = @_;
+ croak 'Rule clause must be a hash'
+ unless 'HASH' eq ref $rule;
+
+ my @type = keys %$rule;
+ croak 'Rule clause must have exactly one key'
+ unless @type == 1;
+
+ my %handlers = (
+ par => sub {
+ [ map { [$_] } @_ ];
+ },
+ seq => sub { [ [@_] ] },
+ );
+
+ my $handler = $handlers{ $type[0] }
+ || croak 'Unknown scheduler type: ', $type[0];
+ my $val = $rule->{ $type[0] };
+
+ return $handler->(
+ map {
+ 'HASH' eq ref $_
+ ? $self->_rule_clause( $_, $tests )
+ : $self->_expand( $_, $tests )
+ } 'ARRAY' eq ref $val ? @$val : $val
+ );
+}
+
+sub _glob_to_regexp {
+ my ( $self, $glob ) = @_;
+ my $nesting;
+ my $pattern;
+
+ while (1) {
+ if ( $glob =~ /\G\*\*/gc ) {
+
+ # ** is any number of characters, including /, within a pathname
+ $pattern .= '.*?';
+ }
+ elsif ( $glob =~ /\G\*/gc ) {
+
+ # * is zero or more characters within a filename/directory name
+ $pattern .= '[^/]*';
+ }
+ elsif ( $glob =~ /\G\?/gc ) {
+
+ # ? is exactly one character within a filename/directory name
+ $pattern .= '[^/]';
+ }
+ elsif ( $glob =~ /\G\{/gc ) {
+
+ # {foo,bar,baz} is any of foo, bar or baz.
+ $pattern .= '(?:';
+ ++$nesting;
+ }
+ elsif ( $nesting and $glob =~ /\G,/gc ) {
+
+ # , is only special inside {}
+ $pattern .= '|';
+ }
+ elsif ( $nesting and $glob =~ /\G\}/gc ) {
+
+ # } that matches { is special. But unbalanced } are not.
+ $pattern .= ')';
+ --$nesting;
+ }
+ elsif ( $glob =~ /\G(\\.)/gc ) {
+
+ # A quoted literal
+ $pattern .= $1;
+ }
+ elsif ( $glob =~ /\G([\},])/gc ) {
+
+ # Sometimes meta characters
+ $pattern .= '\\' . $1;
+ }
+ else {
+
+ # Eat everything that is not a meta character.
+ $glob =~ /\G([^{?*\\\},]*)/gc;
+ $pattern .= quotemeta $1;
+ }
+ return $pattern if pos $glob == length $glob;
+ }
+}
+
+sub _expand {
+ my ( $self, $name, $tests ) = @_;
+
+ my $pattern = $self->_glob_to_regexp($name);
+ $pattern = qr/^ $pattern $/x;
+ my @match = ();
+
+ for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+ if ( $tests->[$ti]->filename =~ $pattern ) {
+ push @match, splice @$tests, $ti, 1;
+ $ti--;
+ }
+ }
+
+ return @match;
+}
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+ my $self = shift;
+ my @all = $self->_gather( $self->{schedule} );
+ $self->{count} = @all;
+ @all;
+}
+
+sub _gather {
+ my ( $self, $rule ) = @_;
+ return unless defined $rule;
+ return $rule unless 'ARRAY' eq ref $rule;
+ return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job or C<undef> if none are available. Returns
+a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
+jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+ my $self = shift;
+ $self->{count} ||= $self->get_all;
+ my @jobs = $self->_find_next_job( $self->{schedule} );
+ if (@jobs) {
+ --$self->{count};
+ return $jobs[0];
+ }
+
+ return TAP::Parser::Scheduler::Spinner->new
+ if $self->{count};
+
+ return;
+}
+
+sub _not_empty {
+ my $ar = shift;
+ return 1 unless 'ARRAY' eq ref $ar;
+ foreach (@$ar) {
+ return 1 if _not_empty($_);
+ }
+ return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+ my ( $self, $rule ) = @_;
+
+ my @queue = ();
+ my $index = 0;
+ while ( $index < @$rule ) {
+ my $seq = $rule->[$index];
+
+ # Prune any exhausted items.
+ shift @$seq while @$seq && _is_empty( $seq->[0] );
+ if (@$seq) {
+ if ( defined $seq->[0] ) {
+ if ( 'ARRAY' eq ref $seq->[0] ) {
+ push @queue, $seq;
+ }
+ else {
+ my $job = splice @$seq, 0, 1, undef;
+ $job->on_finish( sub { shift @$seq } );
+ return $job;
+ }
+ }
+ ++$index;
+ }
+ else {
+
+ # Remove the empty sub-array from the array
+ splice @$rule, $index, 1;
+ }
+ }
+
+ for my $seq (@queue) {
+ if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
+ return @jobs;
+ }
+ }
+
+ return;
+}
+
+=head3 C<as_string>
+
+Return a human readable representation of the scheduling tree.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ return $self->_as_string( $self->{schedule} );
+}
+
+sub _as_string {
+ my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
+ my $pad = ' ' x 2;
+ my $indent = $pad x $depth;
+ if ( !defined $rule ) {
+ return "$indent(undef)\n";
+ }
+ elsif ( 'ARRAY' eq ref $rule ) {
+ return unless @$rule;
+ my $type = ( 'par', 'seq' )[ $depth % 2 ];
+ return join(
+ '', "$indent$type:\n",
+ map { $self->_as_string( $_, $depth + 1 ) } @$rule
+ );
+ }
+ else {
+ return "$indent'" . $rule->filename . "'\n";
+ }
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Source/Perl.pm perl-5.10.0/lib/TAP/Parser/Source/Perl.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Source/Perl.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Source/Perl.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,326 @@
+package TAP::Parser::Source::Perl;
+
+use strict;
+use Config;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::Source;
+use TAP::Parser::Utils qw( split_shell );
+
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new;
+ my $stream = $perl->source( [ $filename, @args ] )->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a filename and hopefully returns a stream from it. The filename should
+be the name of a Perl program.
+
+Note that this is a subclass of L<TAP::Parser::Source>. See that module for
+more methods.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+Returns a new C<TAP::Parser::Source::Perl> object.
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+Getter/setter the name of the test program and any arguments it requires.
+
+ my ($filename, @args) = @{ $perl->source };
+ $perl->source( [ $filename, @args ] );
+
+C<croak>s if C<$filename> could not be found.
+
+=cut
+
+sub source {
+ my $self = shift;
+ $self->_croak("Cannot find ($_[0][0])")
+ if @_ && !-f $_[0][0];
+ return $self->SUPER::source(@_);
+}
+
+=head3 C<switches>
+
+ my $switches = $perl->switches;
+ my @switches = $perl->switches;
+ $perl->switches( \@switches );
+
+Getter/setter for the additional switches to pass to the perl executable. One
+common switch would be to set an include directory:
+
+ $perl->switches( ['-Ilib'] );
+
+=cut
+
+sub switches {
+ my $self = shift;
+ unless (@_) {
+ return wantarray ? @{ $self->{switches} } : $self->{switches};
+ }
+ my $switches = shift;
+ $self->{switches} = [@$switches]; # force a copy
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream($parser);
+
+Returns a stream of the output generated by executing C<source>. Must be
+passed an object that implements a C<make_iterator> method. Typically
+this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+
+ my @switches = $self->_switches;
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+
+ # Filter out any -I switches to be handled as libs later.
+ #
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ #
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ my @filtered_switches;
+ for (@switches) {
+ if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+ push @libs, $1;
+ }
+ else {
+ push @filtered_switches, $_;
+ }
+ }
+ @switches = @filtered_switches;
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB}
+ = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $previous = $ENV{PERL5LIB};
+ my $teardown = sub {
+ if ( defined $previous ) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ # Taint mode ignores environment variables so we must retranslate
+ # PERL5LIB as -I switches and place PERL5OPT on the command line
+ # in order that it be seen.
+ if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
+ push @switches, $self->_libs2switches(@libs);
+ push @switches, split_shell( $ENV{PERL5OPT} );
+ }
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my $self = shift;
+ my @switches = @_;
+ my ( $file, @args ) = @{ $self->source };
+ my $command = $self->_get_perl;
+
+# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
+#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file, @args );
+ return @command;
+}
+
+sub _get_command {
+ my $self = shift;
+ return $self->_get_command_for_switches( $self->_switches );
+}
+
+sub _libs2switches {
+ my $self = shift;
+ return map {"-I$_"} grep {$_} @_;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my $file = shift;
+ local *TEST;
+ my $shebang;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ close(TEST) or print "Can't close $file. $!\n";
+ }
+ else {
+ print "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ unless ( exists $shebang_for{$file} ) {
+ $shebang_for{$file} = _read_shebang($file);
+ }
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
+sub _switches {
+ my $self = shift;
+ my ( $file, @args ) = @{ $self->source };
+ my @switches = (
+ $self->switches,
+ );
+
+ my $shebang = $self->shebang($file);
+ return unless defined $shebang;
+
+ my $taint = $self->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
+
+ # Quote the argument if we're VMS, since VMS will downcase anything
+ # not quoted.
+ if (IS_VMS) {
+ for (@switches) {
+ $_ = qq["$_"];
+ }
+ }
+
+ return @switches;
+}
+
+sub _get_perl {
+ my $self = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyPerlSource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source::Perl;
+
+ @ISA = qw( TAP::Parser::Source::Perl );
+
+ sub source {
+ my ($self, $args) = @_;
+ if ($args) {
+ $self->{file} = $args->[0];
+ return $self->SUPER::source($args);
+ }
+ return $self->SUPER::source;
+ }
+
+ # use the version of perl from the shebang line in the test file
+ sub _get_perl {
+ my $self = shift;
+ if (my $shebang = $self->shebang( $self->{file} )) {
+ $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+ return $1 if $1;
+ }
+ return $self->SUPER::_get_perl(@_);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+
+=cut
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Source.pm perl-5.10.0/lib/TAP/Parser/Source.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Source.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Source.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,173 @@
+package TAP::Parser::Source;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::IteratorFactory ();
+
+@ISA = qw(TAP::Object);
+
+# Causes problem on MacOS and shouldn't be necessary anyway
+#$SIG{CHLD} = sub { wait };
+
+=head1 NAME
+
+TAP::Parser::Source - Stream output from some source
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new;
+ my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a command and hopefully returns a stream from it.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{switches} = [];
+ _autoflush( \*STDOUT );
+ _autoflush( \*STDERR );
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+ my $source = $source->source;
+ $source->source(['./some_prog some_test_file']);
+
+ # or
+ $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
+
+Getter/setter for the source. The source should generally consist of an array
+reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>,
+should return a filehandle which returns successive rows of TAP. C<croaks> if
+it doesn't get an arrayref.
+
+=cut
+
+sub source {
+ my $self = shift;
+ return $self->{source} unless @_;
+ unless ( 'ARRAY' eq ref $_[0] ) {
+ $self->_croak('Argument to &source must be an array reference');
+ }
+ $self->{source} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream;
+
+Returns a L<TAP::Parser::Iterator> stream of the output generated by executing
+C<source>. C<croak>s if there was no command found.
+
+Must be passed an object that implements a C<make_iterator> method.
+Typically this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+ my @command = $self->_get_command
+ or $self->_croak('No command found!');
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge
+ }
+ );
+}
+
+sub _get_command { return @{ shift->source || [] } }
+
+##############################################################################
+
+=head3 C<merge>
+
+ my $merge = $source->merge;
+
+Sets or returns the flag that dictates whether STDOUT and STDERR are merged.
+
+=cut
+
+sub merge {
+ my $self = shift;
+ return $self->{merge} unless @_;
+ $self->{merge} = shift;
+ return $self;
+}
+
+# Turns on autoflush for the handle passed
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyRubySource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source;
+
+ @ISA = qw( TAP::Parser::Source );
+
+ # expect $source->(['mytest.rb', 'cmdline', 'args']);
+ sub source {
+ my ($self, $args) = @_;
+ my ($rb_file) = @$args;
+ croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+ return $self->SUPER::source(['/usr/bin/ruby', @$args]);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source::Perl>,
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/Utils.pm perl-5.10.0/lib/TAP/Parser/Utils.pm
--- perl-5.10.0.orig/lib/TAP/Parser/Utils.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Utils.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,72 @@
+package TAP::Parser::Utils;
+
+use strict;
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( split_shell );
+
+=head1 NAME
+
+TAP::Parser::Utils - Internal TAP::Parser utilities
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Utils qw( split_shell )
+ my @switches = split_shell( $arg );
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+=head2 INTERFACE
+
+=head3 C<split_shell>
+
+Shell style argument parsing. Handles backslash escaping, single and
+double quoted strings but not shell substitutions.
+
+Pass one or more strings containing shell escaped arguments. The return
+value is an array of arguments parsed from the input strings according
+to (approximate) shell parsing rules. It's legal to pass C<undef> in
+which case an empty array will be returned. That makes it possible to
+
+ my @args = split_shell( $ENV{SOME_ENV_VAR} );
+
+without worrying about whether the environment variable exists.
+
+This is used to split HARNESS_PERL_ARGS into individual switches.
+
+=cut
+
+sub split_shell {
+ my @parts = ();
+
+ for my $switch ( grep defined && length, @_ ) {
+ push @parts, $1 while $switch =~ /
+ (
+ (?: [^\\"'\s]+
+ | \\.
+ | " (?: \\. | [^"] )* "
+ | ' (?: \\. | [^'] )* '
+ )+
+ ) /xg;
+ }
+
+ for (@parts) {
+ s/ \\(.) | ['"] /defined $1 ? $1 : ''/exg;
+ }
+
+ return @parts;
+}
+
+1;
diff -urN perl-5.10.0.orig/lib/TAP/Parser/YAMLish/Reader.pm perl-5.10.0/lib/TAP/Parser/YAMLish/Reader.pm
--- perl-5.10.0.orig/lib/TAP/Parser/YAMLish/Reader.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/YAMLish/Reader.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,333 @@
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.16';
+
+# TODO:
+# Handle blessed object syntax
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
+my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
+my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
+my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
+my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
+
+# new() implementation supplied by TAP::Object
+
+sub read {
+ my $self = shift;
+ my $obj = shift;
+
+ die "Must have a code reference to read input from"
+ unless ref $obj eq 'CODE';
+
+ $self->{reader} = $obj;
+ $self->{capture} = [];
+
+ # Prime the reader
+ $self->_next;
+ return unless $self->{next};
+
+ my $doc = $self->_read;
+
+ # The terminator is mandatory otherwise we'd consume a line from the
+ # iterator that doesn't belong to us. If we want to remove this
+ # restriction we'll have to implement look-ahead in the iterators.
+ # Which might not be a bad idea.
+ my $dots = $self->_peek;
+ die "Missing '...' at end of YAMLish"
+ unless defined $dots
+ and $dots =~ $IS_END_YAML;
+
+ delete $self->{reader};
+ delete $self->{next};
+
+ return $doc;
+}
+
+sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
+
+sub _peek {
+ my $self = shift;
+ return $self->{next} unless wantarray;
+ my $line = $self->{next};
+ $line =~ /^ (\s*) (.*) $ /x;
+ return ( $2, length $1 );
+}
+
+sub _next {
+ my $self = shift;
+ die "_next called with no reader"
+ unless $self->{reader};
+ my $line = $self->{reader}->();
+ $self->{next} = $line;
+ push @{ $self->{capture} }, $line;
+}
+
+sub _read {
+ my $self = shift;
+
+ my $line = $self->_peek;
+
+ # Do we have a document header?
+ if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) {
+ $self->_next;
+
+ return $self->_read_scalar($1) if defined $1; # Inline?
+
+ my ( $next, $indent ) = $self->_peek;
+
+ if ( $next =~ /^ - /x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $next =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $next, $indent );
+ }
+ elsif ( $next =~ $IS_END_YAML ) {
+ die "Premature end of YAMLish";
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$next'";
+ }
+ }
+ else {
+ die "YAMLish document header not found";
+ }
+}
+
+# Parse a double quoted string
+sub _read_qq {
+ my $self = shift;
+ my $str = shift;
+
+ unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
+ die "Internal: not a quoted string";
+ }
+
+ $str =~ s/\\"/"/gx;
+ $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
+ / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
+ return $str;
+}
+
+# Parse a scalar string to the actual scalar
+sub _read_scalar {
+ my $self = shift;
+ my $string = shift;
+
+ return undef if $string eq '~';
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ if ( $string eq '>' || $string eq '|' ) {
+
+ my ( $line, $indent ) = $self->_peek;
+ die "Multi-line scalar content missing" unless defined $line;
+
+ my @multiline = ($line);
+
+ while (1) {
+ $self->_next;
+ my ( $next, $ind ) = $self->_peek;
+ last if $ind < $indent;
+
+ my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
+ push @multiline, $pad . $next;
+ }
+
+ return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
+ }
+
+ if ( $string =~ /^ ' (.*) ' $/x ) {
+ ( my $rv = $1 ) =~ s/''/'/g;
+ return $rv;
+ }
+
+ if ( $string =~ $IS_QQ_STRING ) {
+ return $self->_read_qq($string);
+ }
+
+ if ( $string =~ /^['"]/ ) {
+
+ # A quote with folding... we don't support that
+ die __PACKAGE__ . " does not support multi-line quoted scalars";
+ }
+
+ # Regular unquoted string
+ return $string;
+}
+
+sub _read_nested {
+ my $self = shift;
+
+ my ( $line, $indent ) = $self->_peek;
+
+ if ( $line =~ /^ -/x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $line, $indent );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+}
+
+# Parse an array
+sub _read_array {
+ my ( $self, $limit ) = @_;
+
+ my $ar = [];
+
+ while (1) {
+ my ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+
+ if ( $indent > $limit ) {
+ die "Array line over-indented";
+ }
+
+ if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
+ $indent += length $1;
+ $line =~ s/-\s+//;
+ push @$ar, $self->_read_hash( $line, $indent );
+ }
+ elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
+ die "Unexpected start of YAMLish" if $line =~ /^---/;
+ $self->_next;
+ push @$ar, $self->_read_scalar($1);
+ }
+ elsif ( $line =~ /^ - \s* $/x ) {
+ $self->_next;
+ push @$ar, $self->_read_nested;
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ $self->_next;
+ push @$ar, $self->_read_hash( $line, $indent, );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+ }
+
+ return $ar;
+}
+
+sub _read_hash {
+ my ( $self, $line, $limit ) = @_;
+
+ my $indent;
+ my $hash = {};
+
+ while (1) {
+ die "Badly formed hash line: '$line'"
+ unless $line =~ $HASH_LINE;
+
+ my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
+ $self->_next;
+
+ if ( defined $value ) {
+ $hash->{$key} = $self->_read_scalar($value);
+ }
+ else {
+ $hash->{$key} = $self->_read_nested;
+ }
+
+ ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+ }
+
+ return $hash;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
+
+=head1 VERSION
+
+Version 3.16
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Note that parts of this code were derived from L<YAML::Tiny> with the
+permission of Adam Kennedy.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Reader> object.
+
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+
+=head2 Instance Methods
+
+=head3 C<read>
+
+ my $got = $reader->read($stream);
+
+Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
+represents.
+
+=head3 C<get_raw>
+
+ my $source = $reader->get_source;
+
+Return the raw YAMLish source from the most recent C<read>.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
+the YAML matching regular expressions for this module.
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+Portions copyright 2006-2008 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser/YAMLish/Writer.pm perl-5.10.0/lib/TAP/Parser/YAMLish/Writer.pm
--- perl-5.10.0.orig/lib/TAP/Parser/YAMLish/Writer.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/YAMLish/Writer.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,255 @@
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.16';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
+my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
+
+my @UNPRINTABLE = qw(
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1a e x1c x1d x1e x1f
+);
+
+# new() implementation supplied by TAP::Object
+
+sub write {
+ my $self = shift;
+
+ die "Need something to write"
+ unless @_;
+
+ my $obj = shift;
+ my $out = shift || \*STDOUT;
+
+ die "Need a reference to something I can write to"
+ unless ref $out;
+
+ $self->{writer} = $self->_make_writer($out);
+
+ $self->_write_obj( '---', $obj );
+ $self->_put('...');
+
+ delete $self->{writer};
+}
+
+sub _make_writer {
+ my $self = shift;
+ my $out = shift;
+
+ my $ref = ref $out;
+
+ if ( 'CODE' eq $ref ) {
+ return $out;
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ return sub { push @$out, shift };
+ }
+ elsif ( 'SCALAR' eq $ref ) {
+ return sub { $$out .= shift() . "\n" };
+ }
+ elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
+ return sub { print $out shift(), "\n" };
+ }
+
+ die "Can't write to $out";
+}
+
+sub _put {
+ my $self = shift;
+ $self->{writer}->( join '', @_ );
+}
+
+sub _enc_scalar {
+ my $self = shift;
+ my $val = shift;
+ my $rule = shift;
+
+ return '~' unless defined $val;
+
+ if ( $val =~ /$rule/ ) {
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/"/\\"/g;
+ $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
+ return qq{"$val"};
+ }
+
+ if ( length($val) == 0 or $val =~ /\s/ ) {
+ $val =~ s/'/''/;
+ return "'$val'";
+ }
+
+ return $val;
+}
+
+sub _write_obj {
+ my $self = shift;
+ my $prefix = shift;
+ my $obj = shift;
+ my $indent = shift || 0;
+
+ if ( my $ref = ref $obj ) {
+ my $pad = ' ' x $indent;
+ if ( 'HASH' eq $ref ) {
+ if ( keys %$obj ) {
+ $self->_put($prefix);
+ for my $key ( sort keys %$obj ) {
+ my $value = $obj->{$key};
+ $self->_write_obj(
+ $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
+ $value, $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' {}' );
+ }
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ if (@$obj) {
+ $self->_put($prefix);
+ for my $value (@$obj) {
+ $self->_write_obj(
+ $pad . '-', $value,
+ $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' []' );
+ }
+ }
+ else {
+ die "Don't know how to encode $ref";
+ }
+ }
+ else {
+ $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 3.16
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::YAMLish::Writer;
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+
+ # Write to an array...
+ $yw->write( $data, \@some_array );
+
+ # ...an open file handle...
+ $yw->write( $data, $some_file_handle );
+
+ # ...a string ...
+ $yw->write( $data, \$some_string );
+
+ # ...or a closure
+ $yw->write( $data, sub {
+ my $line = shift;
+ print "$line\n";
+ } );
+
+=head1 DESCRIPTION
+
+Encodes a scalar, hash reference or array reference as YAMLish.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Writer> object.
+
+=head2 Instance Methods
+
+=head3 C<write>
+
+ $writer->write($obj, $output );
+
+Encode a scalar, hash reference or array reference as YAML.
+
+ my $writer = sub {
+ my $line = shift;
+ print SOMEFILE "$line\n";
+ };
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+ $yw->write( $data, $writer );
+
+
+The C< $output > argument may be:
+
+=over
+
+=item * a reference to a scalar to append YAML to
+
+=item * the handle of an open file
+
+=item * a reference to an array into which YAML will be pushed
+
+=item * a code reference
+
+=back
+
+If you supply a code reference the subroutine will be called once for
+each line of output with the line as its only argument. Passed lines
+will have no trailing newline.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
diff -urN perl-5.10.0.orig/lib/TAP/Parser.pm perl-5.10.0/lib/TAP/Parser.pm
--- perl-5.10.0.orig/lib/TAP/Parser.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser.pm 2009-03-10 17:39:08.000000000 +0100
@@ -0,0 +1,1869 @@
+package TAP::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Base ();
+use TAP::Parser::Grammar ();
+use TAP::Parser::Result ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::Source ();
+use TAP::Parser::Source::Perl ();
+use TAP::Parser::Iterator ();
+use TAP::Parser::IteratorFactory ();
+
+use Carp qw( confess );
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 3.16
+
+=cut
+
+$VERSION = '3.16';
+
+my $DEFAULT_TAP_VERSION = 12;
+my $MAX_TAP_VERSION = 13;
+
+$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{TAP_VERSION};
+}
+
+BEGIN { # making accessors
+ @ISA = qw(TAP::Base);
+
+ __PACKAGE__->mk_methods(
+ qw(
+ _stream
+ _spool
+ exec
+ exit
+ is_good_plan
+ plan
+ tests_planned
+ tests_run
+ wait
+ version
+ in_todo
+ start_time
+ end_time
+ skip_all
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ )
+ );
+} # done making accessors
+
+=head1 SYNOPSIS
+
+ use TAP::Parser;
+
+ my $parser = TAP::Parser->new( { source => $source } );
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser> is designed to produce a proper parse of TAP output. For
+an example of how to run tests through this module, see the simple
+harnesses C<examples/>.
+
+There's a wiki dedicated to the Test Anything Protocol:
+
+L<http://testanything.org>
+
+It includes the TAP::Parser Cookbook:
+
+L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $parser = TAP::Parser->new(\%args);
+
+Returns a new C<TAP::Parser> object.
+
+The arguments should be a hashref with I<one> of the following keys:
+
+=over 4
+
+=item * C<source>
+
+This is the preferred method of passing arguments to the constructor. To
+determine how to handle the source, the following steps are taken.
+
+If the source contains a newline, it's assumed to be a string of raw TAP
+output.
+
+If the source is a reference, it's assumed to be something to pass to
+the L<TAP::Parser::Iterator::Stream> constructor. This is used
+internally and you should not use it.
+
+Otherwise, the parser does a C<-e> check to see if the source exists. If so,
+it attempts to execute the source and read the output as a stream. This is by
+far the preferred method of using the parser.
+
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new( { source => $file } );
+ # do stuff with the parser
+ }
+
+=item * C<tap>
+
+The value should be the complete TAP output.
+
+=item * C<exec>
+
+If passed an array reference, will attempt to create the iterator by
+passing a L<TAP::Parser::Source> object to
+L<TAP::Parser::Iterator::Source>, using the array reference strings as
+the command arguments to L<IPC::Open3::open3|IPC::Open3>:
+
+ exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
+
+Note that C<source> and C<exec> are mutually exclusive.
+
+=back
+
+The following keys are optional.
+
+=over 4
+
+=item * C<callback>
+
+If present, each callback corresponding to a given result type will be called
+with the result as the argument if the C<run> method is used:
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+=item * C<switches>
+
+If using a Perl file as a source, optional switches may be passed which will
+be used when invoking the perl executable.
+
+ my $parser = TAP::Parser->new( {
+ source => $test_file,
+ switches => '-Ilib',
+ } );
+
+=item * C<test_args>
+
+Used in conjunction with the C<source> option to supply a reference to
+an C<@ARGV> style array of arguments to pass to the test program.
+
+=item * C<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+If false, STDERR is not captured (though it is 'relayed' to keep it
+somewhat synchronized with STDOUT.)
+
+If true, STDERR and STDOUT are the same filehandle. This may cause
+breakage if STDERR contains anything resembling TAP format, but does
+allow exact synchronization.
+
+Subtleties of this behavior may be platform-dependent and may change in
+the future.
+
+=item * C<source_class>
+
+This option was introduced to let you easily customize which I<source> class
+the parser should use. It defaults to L<TAP::Parser::Source>.
+
+See also L</make_source>.
+
+=item * C<perl_source_class>
+
+This option was introduced to let you easily customize which I<perl source>
+class the parser should use. It defaults to L<TAP::Parser::Source::Perl>.
+
+See also L</make_perl_source>.
+
+=item * C<grammar_class>
+
+This option was introduced to let you easily customize which I<grammar> class
+the parser should use. It defaults to L<TAP::Parser::Grammar>.
+
+See also L</make_grammar>.
+
+=item * C<iterator_factory_class>
+
+This option was introduced to let you easily customize which I<iterator>
+factory class the parser should use. It defaults to
+L<TAP::Parser::IteratorFactory>.
+
+See also L</make_iterator>.
+
+=item * C<result_factory_class>
+
+This option was introduced to let you easily customize which I<result>
+factory class the parser should use. It defaults to
+L<TAP::Parser::ResultFactory>.
+
+See also L</make_result>.
+
+=back
+
+=cut
+
+# new() implementation supplied by TAP::Base
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub _default_source_class {'TAP::Parser::Source'}
+sub _default_perl_source_class {'TAP::Parser::Source::Perl'}
+sub _default_grammar_class {'TAP::Parser::Grammar'}
+sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
+sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ my $parser = TAP::Parser->new( { source => $file } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This method returns the results of the parsing, one result at a time. Note
+that it is destructive. You can't rewind and examine previous results.
+
+If callbacks are used, they will be issued before this call returns.
+
+Each result returned is a subclass of L<TAP::Parser::Result>. See that
+module and related classes for more information on how to use them.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+##############################################################################
+
+=head3 C<run>
+
+ $parser->run;
+
+This method merely runs the parser and parses all of the TAP.
+
+=cut
+
+sub run {
+ my $self = shift;
+ while ( defined( my $result = $self->next ) ) {
+
+ # do nothing
+ }
+}
+
+##############################################################################
+
+=head3 C<make_source>
+
+Make a new L<TAP::Parser::Source> object and return it. Passes through any
+arguments given.
+
+The C<source_class> can be customized, as described in L</new>.
+
+=head3 C<make_perl_source>
+
+Make a new L<TAP::Parser::Source::Perl> object and return it. Passes through
+any arguments given.
+
+The C<perl_source_class> can be customized, as described in L</new>.
+
+=head3 C<make_grammar>
+
+Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
+arguments given.
+
+The C<grammar_class> can be customized, as described in L</new>.
+
+=head3 C<make_iterator>
+
+Make a new L<TAP::Parser::Iterator> object using the parser's
+L<TAP::Parser::IteratorFactory>, and return it. Passes through any arguments
+given.
+
+The C<iterator_factory_class> can be customized, as described in L</new>.
+
+=head3 C<make_result>
+
+Make a new L<TAP::Parser::Result> object using the parser's
+L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments
+given.
+
+The C<result_factory_class> can be customized, as described in L</new>.
+
+=cut
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub make_source { shift->source_class->new(@_); }
+sub make_perl_source { shift->perl_source_class->new(@_); }
+sub make_grammar { shift->grammar_class->new(@_); }
+sub make_iterator { shift->iterator_factory_class->make_iterator(@_); }
+sub make_result { shift->result_factory_class->make_result(@_); }
+
+sub _iterator_for_source {
+ my ( $self, $source ) = @_;
+
+ # If the source has a get_stream method then use it. This makes it
+ # possible to pass a pre-existing source object to the parser's
+ # constructor.
+ if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) {
+ return $source->get_stream($self);
+ }
+ else {
+ return $self->iterator_factory_class->make_iterator($source);
+ }
+}
+
+{
+
+ # of the following, anything beginning with an underscore is strictly
+ # internal and should not be exposed.
+ my %initialize = (
+ version => $DEFAULT_TAP_VERSION,
+ plan => '', # the test plan (e.g., 1..3)
+ tap => '', # the TAP
+ tests_run => 0, # actual current test numbers
+ results => [], # TAP parser results
+ skipped => [], #
+ todo => [], #
+ passed => [], #
+ failed => [], #
+ actual_failed => [], # how many tests really failed
+ actual_passed => [], # how many tests really passed
+ todo_passed => [], # tests which unexpectedly succeed
+ parse_errors => [], # perfect TAP should have none
+ );
+
+ # We seem to have this list hanging around all over the place. We could
+ # probably get it from somewhere else to avoid the repetition.
+ my @legal_callback = qw(
+ test
+ version
+ plan
+ comment
+ bailout
+ unknown
+ yaml
+ ALL
+ ELSE
+ EOF
+ );
+
+ my @class_overrides = qw(
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ # everything here is basically designed to convert any TAP source to a
+ # stream.
+
+ # Shallow copy
+ my %args = %{ $arg_for || {} };
+
+ $self->SUPER::_initialize( \%args, \@legal_callback );
+
+ # get any class overrides out first:
+ for my $key (@class_overrides) {
+ my $default_method = "_default_$key";
+ my $val = delete $args{$key} || $self->$default_method();
+ $self->$key($val);
+ }
+
+ my $stream = delete $args{stream};
+ my $tap = delete $args{tap};
+ my $source = delete $args{source};
+ my $exec = delete $args{exec};
+ my $merge = delete $args{merge};
+ my $spool = delete $args{spool};
+ my $switches = delete $args{switches};
+ my $ignore_exit = delete $args{ignore_exit};
+ my @test_args = @{ delete $args{test_args} || [] };
+
+ if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
+ $self->_croak(
+ "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
+ );
+ }
+
+ if ( my @excess = sort keys %args ) {
+ $self->_croak("Unknown options: @excess");
+ }
+
+ if ($tap) {
+ $stream = $self->_iterator_for_source( [ split "\n" => $tap ] );
+ }
+ elsif ($exec) {
+ my $source = $self->make_source;
+ $source->source( [ @$exec, @test_args ] );
+ $source->merge($merge); # XXX should just be arguments?
+ $stream = $source->get_stream($self);
+ }
+ elsif ($source) {
+ if ( ref $source ) {
+ $stream = $self->_iterator_for_source($source);
+ }
+ elsif ( -e $source ) {
+ my $perl = $self->make_perl_source;
+
+ $perl->switches($switches)
+ if $switches;
+
+ $perl->merge($merge); # XXX args to new()?
+ $perl->source( [ $source, @test_args ] );
+ $stream = $perl->get_stream($self);
+ }
+ else {
+ $self->_croak("Cannot determine source for $source");
+ }
+ }
+
+ unless ($stream) {
+ $self->_croak('PANIC: could not determine stream');
+ }
+
+ while ( my ( $k, $v ) = each %initialize ) {
+ $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
+ }
+
+ $self->_stream($stream);
+ $self->_spool($spool);
+ $self->ignore_exit($ignore_exit);
+
+ return $self;
+ }
+}
+
+=head1 INDIVIDUAL RESULTS
+
+If you've read this far in the docs, you've seen this:
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+Each result returned is a L<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=head2 Result types
+
+Basically, you fetch individual results from the TAP. The six types, with
+examples of each, are as follows:
+
+=over 4
+
+=item * Version
+
+ TAP version 12
+
+=item * Plan
+
+ 1..42
+
+=item * Pragma
+
+ pragma +strict
+
+=item * Test
+
+ ok 3 - We should start with some foobar!
+
+=item * Comment
+
+ # Hope we don't use up the foobar.
+
+=item * Bailout
+
+ Bail out! We ran out of foobar!
+
+=item * Unknown
+
+ ... yo, this ain't TAP! ...
+
+=back
+
+Each result fetched is a result object of a different type. There are common
+methods to each result object and different types may have methods unique to
+their type. Sometimes a type method may be overridden in a subclass, but its
+use is guaranteed to be identical.
+
+=head2 Common type methods
+
+=head3 C<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+Indicates whether or not this is a comment. Comments will generally only
+appear in the TAP stream if STDERR is merged to STDOUT. See the
+C<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut
+which allows you to do this:
+
+ my $parser = TAP::Parser->new( { source => $source } );
+ while ( my $result = $parser->next ) {
+ # only print failing results
+ print $result->as_string unless $result->is_ok;
+ }
+
+=head2 C<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<pragma> methods
+
+ if ( $result->is_pragma ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<pragmas>
+
+Returns a list of pragmas each of which is a + or - followed by the
+pragma name.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=head2 C<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+B<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ if ( $parser->in_todo ) { ... }
+
+True while the most recent result was a TODO. Becomes true before the
+TODO result is returned and stays true until just before the next non-
+TODO test is returned.
+
+=head1 TOTAL RESULTS
+
+After parsing the TAP, there are many methods available to let you dig through
+the results and determine what is meaningful to you.
+
+=head2 Individual Results
+
+These results refer to individual tests which are run.
+
+=head3 C<passed>
+
+ my @passed = $parser->passed; # the test numbers which passed
+ my $passed = $parser->passed; # the number of tests which passed
+
+This method lets you know which (or how many) tests passed. If a test failed
+but had a TODO directive, it will be counted as a passed test.
+
+=cut
+
+sub passed { @{ shift->{passed} } }
+
+=head3 C<failed>
+
+ my @failed = $parser->failed; # the test numbers which failed
+ my $failed = $parser->failed; # the number of tests which failed
+
+This method lets you know which (or how many) tests failed. If a test passed
+but had a TODO directive, it will B<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # the test numbers which actually passed
+ my @actual_passed = $parser->actual_passed;
+
+ # the number of tests which actually passed
+ my $actual_passed = $parser->actual_passed;
+
+This method lets you know which (or how many) tests actually passed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_passed { @{ shift->{actual_passed} } }
+*actual_ok = \&actual_passed;
+
+=head3 C<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # the test numbers which actually failed
+ my @actual_failed = $parser->actual_failed;
+
+ # the number of tests which actually failed
+ my $actual_failed = $parser->actual_failed;
+
+This method lets you know which (or how many) tests actually failed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_failed { @{ shift->{actual_failed} } }
+
+##############################################################################
+
+=head3 C<todo>
+
+ my @todo = $parser->todo; # the test numbers with todo directives
+ my $todo = $parser->todo; # the number of tests with todo directives
+
+This method lets you know which (or how many) tests had TODO directives.
+
+=cut
+
+sub todo { @{ shift->{todo} } }
+
+=head3 C<todo_passed>
+
+ # the test numbers which unexpectedly succeeded
+ my @todo_passed = $parser->todo_passed;
+
+ # the number of tests which unexpectedly succeeded
+ my $todo_passed = $parser->todo_passed;
+
+This method lets you know which (or how many) tests actually passed but were
+declared as "TODO" tests.
+
+=cut
+
+sub todo_passed { @{ shift->{todo_passed} } }
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ my @skipped = $parser->skipped; # the test numbers with SKIP directives
+ my $skipped = $parser->skipped; # the number of tests with SKIP directives
+
+This method lets you know which (or how many) tests had SKIP directives.
+
+=cut
+
+sub skipped { @{ shift->{skipped} } }
+
+=head2 Pragmas
+
+=head3 C<pragma>
+
+Get or set a pragma. To get the state of a pragma:
+
+ if ( $p->pragma('strict') ) {
+ # be strict
+ }
+
+To set the state of a pragma:
+
+ $p->pragma('strict', 1); # enable strict mode
+
+=cut
+
+sub pragma {
+ my ( $self, $pragma ) = splice @_, 0, 2;
+
+ return $self->{pragma}->{$pragma} unless @_;
+
+ if ( my $state = shift ) {
+ $self->{pragma}->{$pragma} = 1;
+ }
+ else {
+ delete $self->{pragma}->{$pragma};
+ }
+
+ return;
+}
+
+=head3 C<pragmas>
+
+Get a list of all the currently enabled pragmas:
+
+ my @pragmas_enabled = $p->pragmas;
+
+=cut
+
+sub pragmas { sort keys %{ shift->{pragma} || {} } }
+
+=head2 Summary Results
+
+These results are "meta" information about the total results of an individual
+test program.
+
+=head3 C<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ if ( $parser->is_good_plan ) { ... }
+
+Returns a boolean value indicating whether or not the number of tests planned
+matches the number of tests run.
+
+B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ print $parser->tests_planned;
+
+Returns the number of tests planned, according to the plan. For example, a
+plan of '1..17' will mean that 17 tests were planned.
+
+=head3 C<tests_run>
+
+ print $parser->tests_run;
+
+Returns the number of tests which actually were run. Hopefully this will
+match the number of C<< $parser->tests_planned >>.
+
+=head3 C<skip_all>
+
+Returns a true value (actually the reason for skipping) if all tests
+were skipped.
+
+=head3 C<start_time>
+
+Returns the time when the Parser was created.
+
+=head3 C<end_time>
+
+Returns the time when the end of TAP input was seen.
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+This is a 'catch-all' method which returns true if any tests have currently
+failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
+}
+
+=head3 C<version>
+
+ $parser->version;
+
+Once the parser is done, this will return the version number for the
+parsed TAP. Version numbers were introduced with TAP version 13 so if no
+version number is found version 12 is assumed.
+
+=head3 C<exit>
+
+ $parser->exit;
+
+Once the parser is done, this will return the exit status. If the parser ran
+an executable, it returns the exit status of the executable.
+
+=head3 C<wait>
+
+ $parser->wait;
+
+Once the parser is done, this will return the wait status. If the parser ran
+an executable, it returns the wait status of the executable. Otherwise, this
+mererely returns the C<exit> status.
+
+=head2 C<ignore_exit>
+
+ $parser->ignore_exit(1);
+
+Tell the parser to ignore the exit status from the test when determining
+whether the test passed. Normally tests with non-zero exit status are
+considered to have failed even if all individual tests passed. In cases
+where it is not possible to control the exit value of the test script
+use this option to ignore it.
+
+=cut
+
+sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
+
+=head3 C<parse_errors>
+
+ my @errors = $parser->parse_errors; # the parser errors
+ my $errors = $parser->parse_errors; # the number of parser_errors
+
+Fortunately, all TAP output is perfect. In the event that it is not, this
+method will return parser errors. Note that a junk line which the parser does
+not recognize is C<not> an error. This allows this parser to handle future
+versions of TAP. The following are all TAP errors reported by the parser:
+
+=over 4
+
+=item * Misplaced plan
+
+The plan (for example, '1..5'), must only come at the beginning or end of the
+TAP output.
+
+=item * No plan
+
+Gotta have a plan!
+
+=item * More than one plan
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+ 1..3
+
+Right. Very funny. Don't do that.
+
+=item * Test numbers out of sequence
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+That last test line above should have the number '3' instead of '2'.
+
+Note that it's perfectly acceptable for some lines to have test numbers and
+others to not have them. However, when a test number is found, it must be in
+sequence. The following is also an error:
+
+ 1..3
+ ok 1 - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+But this is not:
+
+ 1..3
+ ok - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+
+=back
+
+=cut
+
+sub parse_errors { @{ shift->{parse_errors} } }
+
+sub _add_error {
+ my ( $self, $error ) = @_;
+ push @{ $self->{parse_errors} } => $error;
+ return $self;
+}
+
+sub _make_state_table {
+ my $self = shift;
+ my %states;
+ my %planned_todo = ();
+
+ # These transitions are defaults for all states
+ my %state_globals = (
+ comment => {},
+ bailout => {},
+ yaml => {},
+ version => {
+ act => sub {
+ $self->_add_error(
+ 'If TAP version is present it must be the first line of output'
+ );
+ },
+ },
+ unknown => {
+ act => sub {
+ my $unk = shift;
+ if ( $self->pragma('strict') ) {
+ $self->_add_error(
+ 'Unknown TAP token: "' . $unk->raw . '"' );
+ }
+ },
+ },
+ pragma => {
+ act => sub {
+ my ($pragma) = @_;
+ for my $pr ( $pragma->pragmas ) {
+ if ( $pr =~ /^ ([-+])(\w+) $/x ) {
+ $self->pragma( $2, $1 eq '+' );
+ }
+ }
+ },
+ },
+ );
+
+ # Provides default elements for transitions
+ my %state_defaults = (
+ plan => {
+ act => sub {
+ my ($plan) = @_;
+ $self->tests_planned( $plan->tests_planned );
+ $self->plan( $plan->plan );
+ if ( $plan->has_skip ) {
+ $self->skip_all( $plan->explanation
+ || '(no reason given)' );
+ }
+
+ $planned_todo{$_}++ for @{ $plan->todo_list };
+ },
+ },
+ test => {
+ act => sub {
+ my ($test) = @_;
+
+ my ( $number, $tests_run )
+ = ( $test->number, ++$self->{tests_run} );
+
+ # Fake TODO state
+ if ( defined $number && delete $planned_todo{$number} ) {
+ $test->set_directive('TODO');
+ }
+
+ my $has_todo = $test->has_todo;
+
+ $self->in_todo($has_todo);
+ if ( defined( my $tests_planned = $self->tests_planned ) ) {
+ if ( $tests_run > $tests_planned ) {
+ $test->is_unplanned(1);
+ }
+ }
+
+ if ($number) {
+ if ( $number != $tests_run ) {
+ my $count = $tests_run;
+ $self->_add_error( "Tests out of sequence. Found "
+ . "($number) but expected ($count)" );
+ }
+ }
+ else {
+ $test->_number( $number = $tests_run );
+ }
+
+ push @{ $self->{todo} } => $number if $has_todo;
+ push @{ $self->{todo_passed} } => $number
+ if $test->todo_passed;
+ push @{ $self->{skipped} } => $number
+ if $test->has_skip;
+
+ push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
+ $number;
+ push @{
+ $self->{
+ $test->is_actual_ok
+ ? 'actual_passed'
+ : 'actual_failed'
+ }
+ } => $number;
+ },
+ },
+ yaml => { act => sub { }, },
+ );
+
+ # Each state contains a hash the keys of which match a token type. For
+ # each token
+ # type there may be:
+ # act A coderef to run
+ # goto The new state to move to. Stay in this state if
+ # missing
+ # continue Goto the new state and run the new state for the
+ # current token
+ %states = (
+ INIT => {
+ version => {
+ act => sub {
+ my ($version) = @_;
+ my $ver_num = $version->version;
+ if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
+ my $ver_min = $DEFAULT_TAP_VERSION + 1;
+ $self->_add_error(
+ "Explicit TAP version must be at least "
+ . "$ver_min. Got version $ver_num" );
+ $ver_num = $DEFAULT_TAP_VERSION;
+ }
+ if ( $ver_num > $MAX_TAP_VERSION ) {
+ $self->_add_error(
+ "TAP specified version $ver_num but "
+ . "we don't know about versions later "
+ . "than $MAX_TAP_VERSION" );
+ $ver_num = $MAX_TAP_VERSION;
+ }
+ $self->version($ver_num);
+ $self->_grammar->set_version($ver_num);
+ },
+ goto => 'PLAN'
+ },
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLAN => {
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLANNED => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => {
+ act => sub {
+ my ($version) = @_;
+ $self->_add_error(
+ 'More than one plan found in TAP output');
+ },
+ },
+ },
+ PLANNED_AFTER_TEST => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => { act => sub { }, continue => 'PLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ GOT_PLAN => {
+ test => {
+ act => sub {
+ my ($plan) = @_;
+ my $line = $self->plan;
+ $self->_add_error(
+ "Plan ($line) must be at the beginning "
+ . "or end of the TAP output" );
+ $self->is_good_plan(0);
+ },
+ continue => 'PLANNED'
+ },
+ plan => { continue => 'PLANNED' },
+ },
+ UNPLANNED => {
+ test => { goto => 'UNPLANNED_AFTER_TEST' },
+ plan => { goto => 'GOT_PLAN' },
+ },
+ UNPLANNED_AFTER_TEST => {
+ test => { act => sub { }, continue => 'UNPLANNED' },
+ plan => { act => sub { }, continue => 'UNPLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ );
+
+ # Apply globals and defaults to state table
+ for my $name ( keys %states ) {
+
+ # Merge with globals
+ my $st = { %state_globals, %{ $states{$name} } };
+
+ # Add defaults
+ for my $next ( sort keys %{$st} ) {
+ if ( my $default = $state_defaults{$next} ) {
+ for my $def ( sort keys %{$default} ) {
+ $st->{$next}->{$def} ||= $default->{$def};
+ }
+ }
+ }
+
+ # Stuff back in table
+ $states{$name} = $st;
+ }
+
+ return \%states;
+}
+
+=head3 C<get_select_handles>
+
+Get an a list of file handles which can be passed to C<select> to
+determine the readiness of this parser.
+
+=cut
+
+sub get_select_handles { shift->_stream->get_select_handles }
+
+sub _grammar {
+ my $self = shift;
+ return $self->{_grammar} = shift if @_;
+
+ return $self->{_grammar} ||= $self->make_grammar(
+ { stream => $self->_stream,
+ parser => $self,
+ version => $self->version
+ }
+ );
+}
+
+sub _iter {
+ my $self = shift;
+ my $stream = $self->_stream;
+ my $grammar = $self->_grammar;
+ my $spool = $self->_spool;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ $self->start_time( $self->get_time );
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ TRANS: {
+ my $state_spec = $state_table->{$state}
+ or die "Illegal state: $state";
+
+ if ( my $next = $state_spec->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $act->($token);
+ }
+ if ( my $cont = $next->{continue} ) {
+ $state = $cont;
+ redo TRANS;
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $state = $goto;
+ }
+ }
+ else {
+ confess("Unhandled token type: $type\n");
+ }
+ }
+ return $token;
+ };
+
+ # Handle end of stream - which means either pop a block or finish
+ my $end_handler = sub {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ return;
+ };
+
+ # Finally make the closure that we return. For performance reasons
+ # there are two versions of the returned function: one that handles
+ # callbacks and one that does not.
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $_->($result) for @{$code};
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ $self->_make_callback( 'EOF', $result )
+ unless defined $result;
+ }
+
+ return $result;
+ };
+ } # _has_callbacks
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ }
+
+ return $result;
+ };
+ } # no callbacks
+}
+
+sub _finish {
+ my $self = shift;
+
+ $self->end_time( $self->get_time );
+
+ # Avoid leaks
+ $self->_stream(undef);
+ $self->_grammar(undef);
+
+ # If we just delete the iter we won't get a fault if it's recreated.
+ # Instead we set it to a sub that returns an infinite
+ # stream of undef. This segfaults on 5.5.4, presumably because
+ # we're still executing the closure that gets replaced and it hasn't
+ # been protected with a refcount.
+ $self->{_iter} = sub {return}
+ if $] >= 5.006;
+
+ # sanity checks
+ if ( !$self->plan ) {
+ $self->_add_error('No plan found in TAP output');
+ }
+ else {
+ $self->is_good_plan(1) unless defined $self->is_good_plan;
+ }
+ if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
+ $self->is_good_plan(0);
+ if ( defined( my $planned = $self->tests_planned ) ) {
+ my $ran = $self->tests_run;
+ $self->_add_error(
+ "Bad plan. You planned $planned tests but ran $ran.");
+ }
+ }
+ if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
+
+ # this should never happen
+ my $actual = $self->tests_run;
+ my $passed = $self->passed;
+ my $failed = $self->failed;
+ $self->_croak( "Panic: planned test count ($actual) did not equal "
+ . "sum of passed ($passed) and failed ($failed) tests!" );
+ }
+
+ $self->is_good_plan(0) unless defined $self->is_good_plan;
+ return $self;
+}
+
+=head3 C<delete_spool>
+
+Delete and return the spool.
+
+ my $fh = $parser->delete_spool;
+
+=cut
+
+sub delete_spool {
+ my $self = shift;
+
+ return delete $self->{_spool};
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will
+be invoked. Thus, if all of the previous result types are specified as
+callbacks, this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is no
+accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO
+lists in the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was
+listed as a TODO test on the plan line. However, we are not aware of
+anyone actually using this feature and hard-coding test numbers is
+discouraged because it's very easy to add a test and break the test
+number sequence. This makes test suites very fragile. Instead, the
+following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter
+'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've
+never run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 SUBCLASSING
+
+If you find you need to provide custom functionality (as you would have using
+L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
+designed to be easily subclassed.
+
+Before you start, it's important to know a few things:
+
+=over 2
+
+=item 1
+
+All C<TAP::*> objects inherit from L<TAP::Object>.
+
+=item 2
+
+Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
+
+=item 3
+
+Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
+responsible for creating new objects in the C<TAP::Parser::*> namespace.
+
+This makes it possible for you to have a single point of configuring what
+subclasses should be used, which in turn means that in many cases you'll find
+you only need to sub-class one of the parser's components.
+
+=item 4
+
+By subclassing, you may end up overriding undocumented methods. That's not
+a bad thing per se, but be forewarned that undocumented methods may change
+without warning from one release to the next - we cannot guarantee backwards
+compatability. If any I<documented> method needs changing, it will be
+deprecated first, and changed in a later release.
+
+=back
+
+=head2 Parser Components
+
+=head3 Sources
+
+A TAP parser consumes input from a I<source>. There are currently two types
+of sources: L<TAP::Parser::Source> for general non-perl commands, and
+L<TAP::Parser::Source::Perl>. You can subclass both of them. You'll need to
+customize your parser by setting the C<source_class> & C<perl_source_class>
+parameters. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_source> or L</make_perl_source>.
+
+=head3 Iterators
+
+A TAP parser uses I<iterators> to loop through the I<stream> provided by the
+parser's I<source>. There are quite a few types of Iterators available.
+Choosing which class to use is the responsibility of the I<iterator factory>.
+
+To create your own iterators you'll have to subclass
+L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>. Then you'll
+need to customize the class used by your parser by setting the
+C<iterator_factory_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_iterator>.
+
+=head3 Results
+
+A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
+input I<stream>. There are quite a few result types available; choosing
+which class to use is the responsibility of the I<result factory>.
+
+To create your own result types you have two options:
+
+=over 2
+
+=item option 1
+
+Subclass L<TAP::Parser::Result> and register your new result type/class with
+the default L<TAP::Parser::ResultFactory>.
+
+=item option 2
+
+Subclass L<TAP::Parser::ResultFactory> itself and implement your own
+L<TAP::Parser::Result> creation logic. Then you'll need to customize the
+class used by your parser by setting the C<result_factory_class> parameter.
+See L</new> for more details.
+
+=back
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_result>.
+
+=head3 Grammar
+
+L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
+input I<stream> and produces results. If you need to customize its behaviour
+you should probably familiarize yourself with the source first. Enough
+lecturing.
+
+Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
+C<grammar_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_grammar>
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral
+support, or just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=item * David Wheeler
+
+=item * Alex Vandiver
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid@cpan.org>
+
+Andy Armstong <andy@hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+Michael Peters <mpeters at plusthree dot com>
+
+Leif Eriksen <leif dot eriksen at bigpond dot com>
+
+Steve Purkis <spurkis@cpan.org>
+
+Nicholas Clark <nick@ccl4.org>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
+We will be notified, and then you'll automatically be notified of
+progress on your bug as we make changes.
+
+Obviously, bugs which include patches are best. If you prefer, you can
+patch against bleed by via anonymous checkout of the latest version:
+
+ svn checkout http://svn.hexten.net/tapx
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff -urN perl-5.10.0.orig/lib/Test/Harness/Assert.pm perl-5.10.0/lib/Test/Harness/Assert.pm
--- perl-5.10.0.orig/lib/Test/Harness/Assert.pm 2009-02-20 11:39:19.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<For internal use by Test::Harness ONLY!>
-
-=head1 FUNCTIONS
-
-=head2 C<assert()>
-
- 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<< <schwern at pobox.com> >>
-
-=head1 SEE ALSO
-
-L<Carp::Assert>
-
-=cut
-
-1;
diff -urN perl-5.10.0.orig/lib/Test/Harness/Changes perl-5.10.0/lib/Test/Harness/Changes
--- perl-5.10.0.orig/lib/Test/Harness/Changes 2009-02-20 11:39:19.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/Changes 2009-03-10 17:37:05.000000000 +0100
@@ -1,5 +1,682 @@
+Revision history for Test-Harness
+
+3.16 2009-02-19
+ - Fix path splicing on platforms where the path separator
+ is not ':'.
+ - Fixes/skips for failing Win32 tests.
+ - Don't break with older CPAN::Reporter versions.
+
+3.15 2009-02-17
+ - Refactor getter/setter generation into TAP::Object.
+ - The App::Prove::State::Result::Test now stores the parser object.
+ - After discussion with Andy, agreed to clean up the test output
+ somewhat. t/foo.....ok becomes t/foo.t ... ok
+ - Make Bail out! die instead of exiting. Dies with the same
+ message as 2.64 for (belated) backwards compatibility.
+ - Alex Vaniver's patch to refactor TAP::Formatter::Console into
+ a new class, TAP::Formatter::File and a common base class:
+ TAP::Formatter::Base.
+ - Fix a bug where PERL5LIB might be put in the wrong spot in @INC.
+ #40257
+ - Steve Purkis implemented a plugin mechanism for App::Prove.
+
+3.14 2008-09-13
+ - Created a proper (ha!) API for prove state results and tests.
+ - Added --count and --nocount options to prove to control X/Y display
+ while running tests.
+ - Added 'fresh' state option to run test scripts that have been
+ touched since the test run.
+ - fixed bug where PERL5OPT was not properly split
+ - fixed regex in _filtered_inc. Fixes #39248. Thanks Slaven.
+
+3.13 2008-07-27
+ - fixed various closure related leaks
+ - made prove honour HARNESS_TIMER
+ - Applied patches supplied by Alex Vandiver
+ - add 'rules' switch to prove: allows parallel execution rules
+ to be specified on the command line.
+ - allow '**' (any path) wildcard in parallel rules
+ - fix bug report address
+ - make tprove_gtk example work again.
+
+3.12 2008-06-22
+ - applied Steve Purkis' huge refactoring patch which adds
+ configurable factories for most of the major internal classes.
+ - applied David Wheeler's patch to allow exec to be a code
+ reference.
+ - made tests more robust in the presence of -MFoo in PERL5OPT.
+
+3.11 2008-06-09
+ - applied Jim Keenan's patch that makes App::Prove::run return a
+ rather than exit (#33609)
+ - prove -r now recurses cwd rather than 't' by default (#33007)
+ - restored --ext switch to prove (#33848)
+ - added ignore_exit option to TAP::Parser and corresponding
+ interfaces to TAP::Harness and Test::Harness. Requested for
+ Parrot.
+ - Implemented rule based parallel scheduler.
+ - Moved filename -> display name mapping out of formatter. This
+ prevents the formatter's strip-extensions logic from stripping
+ extensions from supplied descriptions.
+ - Only strip extensions from test names if all tests have the
+ same extension. Previously we stripped extensions if all names
+ had /any/ extension making it impossible to distinguish tests
+ whose name differed only in the extension.
+ - Removed privacy test that made it impossible to subclass
+ TAP::Parser.
+ - Delayed initialisation of grammar making it easier to replace
+ the TAP::Parser stream after instantiation.
+ - Make it possible to supply import parameters to a replacement
+ harness with prove.
+ - Make it possible to replace either _grammar /or/ _stream
+ before reading from a TAP::Parser.
+
+3.10 2008-02-26
+ - fix undefined value warnings with bleadperl.
+ - added pragma support.
+ - fault unknown TAP tokens under strict pragma.
+
+3.09 2008-02-10
+ - support for HARNESS_PERL_SWITCHES containing things like
+ '-e "system(shift)"'.
+ - set HARNESS_IS_VERBOSE during verbose testing.
+ - documentation fixes.
+
+3.08 2008-02-08
+ - added support for 'out' option to
+ Test::Harness::execute_tests. See #32476. Thanks RENEEB.
+ - Fixed YAMLish handling of non-alphanumeric hash keys.
+ - Added --dry option to prove for 2.64 compatibility.
+
+3.07 2008-01-13
+ - prove now supports HARNESS_PERL_SWITCHES.
+ - restored TEST_VERBOSE to prove.
+
+3.06 2008-01-01
+ - Skip t/unicode.t if PERL_UNICODE set. Fixes #31731.
+ Thanks Lukas.
+ - App::Prove::State no longer complains about tests that
+ are deleted.
+ - --state=new and --state=old now consider the modification time
+ of test scripts.
+ - Made test suite core-compatible.
+
+3.05 2007-12-09
+ - Skip unicode.t if Encode unavailable
+ - Support for .proverc files.
+ - Clarified prove documentation.
+
+3.04 2007-12-02
+ - Fixed output leakage with really_quiet set.
+ - Progress reports for tests without plans now show
+ "143/?" instead of "143/0".
+ - Made TAP::Harness::runtests support aliases for test names.
+ - Made it possible to pass command line args to test programs
+ from prove, TAP::Harness, TAP::Parser.
+ - Added --state switch to prove.
+
+3.03 2007-11-17
+ - Fixed some little bugs-waiting-to-happen inside
+ TAP::Parser::Grammar.
+ - Added parser_args callback to TAP::Harness.
+ - Made @INC propagation even more compatible with 2.64 so that
+ parrot still works *and* #30796 is fixed.
+
+3.02 2007-11-15
+ - Process I/O now unbuffered, uses sysread, plays better with
+ select. Fixes #30740.
+ - Made Test::Harness @INC propagation more compatible with 2.64.
+ Was breaking Parrot's test suite.
+ - Added HARNESS_OPTIONS (#30676)
+
+3.01 2007-11-12
+ - Fix for RHEL incpush.patch related failure.
+ - Output real time of test completion with --timer
+ - prove -b adds blib/auto to @INC
+ - made SKIP plan parsing even more liberal for pre-v13 TAP
+
+3.00 2007-11-06
+ - Non-dev release. No changes since 2.99_09.
+
+2.99_09 2007-11-05
+ - Implemented TODO-in-PLAN syntax for TAP version 12 and earlier.
+
+2.99_08 2007-11-04
+ - Tiny changes. New version pushed to get some smoke coverage.
+
+2.99_07 2007-11-01
+ - Fix for #21938: Unable to handle circular links
+ - Fix for #24926: prove -b and -l should use absolute paths
+ - Fixed prove switches. Big oops. How the hell did we miss that?
+ - Consolidated quiet, really_quiet, verbose into verbosity.
+ - Various VMS related fixes to tests
+
+2.99_06 2007-10-30
+ - Added skip_all method to TAP::Parser.
+ - Display reason for skipped tests.
+ - make test now self tests.
+
+2.99_05 2007-10-30
+ - Fix for occasional rogue -1 exit code on Windows.
+ - Fix for @INC handling under CPANPLUS.
+ - Added real time to prove --timer output
+ - Improved prove error message in case where 't' not found and
+ no tests named.
+
+2.99_04 2007-10-11
+ - Fixed bug where 'All tests successful' would not be printed if bonus
+ tests are seen.
+ - Fixed bug where 'Result: FAIL' would be printed at the end of a test
+ run if there were unexpectedly succeeding tests.
+ - Added -M, -P switches to allow arbitrary modules to be loaded
+ by prove. We haven't yet defined what they'll do once they
+ load but it's a start...
+ - Added testing under simulated non-forking platforms.
+
+2.99_03 2007-10-06
+ - Refactored all display specific code out of TAP::Harness.
+ - Relaxed strict parsing of skip plan for pre v13 TAP.
+ - Elapsed hi-res time is now displayed in integer milliseconds
+ instead of fractional seconds.
+ - prove stops running if any command-line switches are invalid.
+ - prove -v would try to print an undef.
+ - Added support for multiplexed and forked parallel tests. Use
+ prove -j 9 to run tests in parallel and prove -j 9 --fork to
+ fork. These features are experimental and currently
+ unavailable on Windows.
+ - Rationalized the management of the environment that we give to
+ test scripts (PERL5LIB, PERL5OPT, switches).
+ - Fixed handling of STDIN (we no longer close it) for test
+ scripts.
+ - Performance enhancements. Parser is now 30% - 40% faster.
+
+2.99_02 2007-09-07
+ - Ensure prove (and App::Prove) sort any recursively
+ discovered tests
+ - It is now possible to register multiple callback handlers for
+ a particular event.
+ - Added before_runtests, after_runtests callbacks to
+ TAP::Harness.
+ - Moved logic of prove program into App::Prove.
+ - Added simple machine readable summary.
+ - Performance improvement: The processing pipeline within
+ TAP::Parser is now a closure which speeds up access to the
+ various attribtes it needs.
+ - Performance improvement: Test count spinner now updates
+ exponentially less frequently as the count increases which
+ saves a lot of I/O on big tests.
+ - More improvements in test coverage from Leif.
+ - Fixes to TAP spooling - now captures YAML blocks correctly.
+ - Fix YAMLish handling of empty arrays, hashes.
+ - Renamed TAP::Harness::Compatible to Test::Harness,
+ runtests to prove.
+ - Fixes to @INC handling. We didn't always pass the correct path
+ to subprocesses.
+ - We now observe any switches in HARNESS_PERL_SWITCHES.
+ - Changes to output formatting for greater compatibility with
+ Test::Harness 2.64.
+ - Added unicode test coverage and fixed a couple of
+ unicode issues.
+ - Additions to documentation.
+ - Added support for non-forking Perls. If forking isn't
+ available we fall back to open and disable stream merging.
+ - Added support for simulating non-forking Perls to improve our
+ test coverage.
+
+========================================================================
+Version numbers below this point relate to TAP::Parser - which was the
+name of this version of Test::Harness during its development.
+========================================================================
+
+0.54
+ - Optimized I/O for common case of 'runtests -l'
+ - Croak if supplied an empty (0 lines) Perl script.
+ - Made T::P::Result::YAML return literal input YAML correctly.
+ - Merged speed-ups from speedy branch.
+
+0.53 18 August 2007
+ - Fixed a few docs nits.
+ - Added -V (--version) switch to runtests. Suggested by markjugg on
+ Perlmonks.
+ - Fixed failing t/030-grammer.t under 5.9.5. Exact cause still
+ unknown; something to do with localisation of $1 et all I think.
+ - Fixed use of three arg open in t/compat/test-harness-compat; was
+ failing on 5.6.2.
+ - Fixed runtests --exec option. T::H wasn't passing the exec option
+ to T::P.
+ - Merged Leif Eriksen's coverage enhancing changes to
+ t/080-aggregator.t, t/030-grammar.t
+ - Made various changes so that we test cleanly on 5.0.5.
+ - Many more coverage enhancements by Leif.
+ - Applied Michael Peters' patch to add an EOF callback to
+ TAP::Parser.
+ - Added --reverse option to runtests to run tests in reverse order.
+ - Made runtests exit with non-zero status if the test run had
+ problems.
+ - Stopped TAP::Parser::Iterator::Process from trampling on STDIN.
+
+0.52 14 July 2007
+ - Incorporate Schwern's investigations into TAP versions.
+ Unversioned TAP is now TAP v12. The lowest explicit version number
+ that can be specified is 13.
+ - Renumbered tests to eliminate gaps.
+ - Killed execrc. The '--exec' switch to runtests handles all of this for
+ us.
+ - Refactored T::P::Iterator into
+ T::P::Iterator::(Array|Process|Stream) so that we have a
+ process specific iterator with which to experiment with
+ STDOUT/STDERR merging.
+ - Removed vestigial exit status handling from T::P::I::Stream.
+ - Removed unused pid interface from T::P::I::Process.
+ - Fixed infinite recursion in T::P::I::Stream and added regression
+ coverage for same.
+ - Added tests for T::P::I::Process.
+ - TAP::Harness now displays the first five TAP syntax errors and
+ explains how to pass the -p flag to runtests to see them all.
+ - Added merge option to TAP::Parser::Iterator::Process,
+ TAP::Parser::Source, TAP::Parser and TAP::Harness.
+ - Added --merge option to runtests to enable STDOUT/STDERR merging.
+ This behaviour used to be the default.
+ - Made T::P::I::Process use open3 for both merged and non-merged
+ streams so that it works on Windows.
+ - Implemented Eric Wilhelm's IO::Select based multiple stream
+ handler so that STDERR is piped to us even if stream merging is
+ turned off. This tends to reduce the temporal skew between the
+ two streams so that error messages appear closer to their
+ correct location.
+ - Altered the T::P::Grammar interface so that it gets a stream
+ rather than the next line from the stream in preparation for
+ making it handle YAML diagnostics.
+ - Implemented YAML syntax. Currently YAML may only follow a
+ test result. The first line of YAML is '---' and the last
+ line is '...'.
+ - Made grammar version-aware. Different grammars may now be selected
+ depending on the TAP version being parsed.
+ - Added formatter delegate mechanism for test results.
+ - Added prototype stream based YAML(ish) parser.
+ - Added more tests for T::P::YAMLish
+ - Altered T::P::Grammar to use T::P::YAMLish
+ - Removed T::P::YAML
+ - Added raw source capture to T::P::YAMLish
+ - Added support for double quoted hash keys
+ - Added TAP::Parser::YAMLish::Writer and renamed T::P::YAMLish as
+ T::P::YAMLish::Reader.
+ - Added extra TAP::Parser::YAMLish::Writer output options
+ - Inline YAML documents must now be indented by at least one space
+ - Fixed broken dependencies in bin/prove
+ - Make library paths absolute before running tests in case tests
+ chdir before loading modules.
+ - Added libs and switches handling to T::H::Compatible. This and the
+ previous change fix [24926]
+ - Added PERLLIB to libraries stripped in _default_inc [12030]
+ - Our version of prove now handles directories containing circular
+ links correctly [21938]
+ - Set TAP_VERSION env var in Parser [11595]
+ - Added setup, teardown hooks to T::P::I::Process to facilitate the
+ setup and cleanup of the test script's environment
+ - Any additional libs added to the command line are also added to
+ PERL5LIB for the duration of a test run so that any Perl children
+ of the test script inherit the same library paths.
+ - Fixed handling of single quoted hash keys in T::P::Y::Reader
+ - Made runtests return the TAP::Parser::Aggregator
+ - Fixed t/120-harness.t has failures if TAP::Harness::Color cannot
+ load optional modules [27125] - thanks DROLSKY
+ - Fixed parsing of \# in test description
+0.51 12 March 2007
+ - 'execrc' file now allows 'regex' matches for tests.
+ - rename 'TAPx' --> 'TAP'
+ - Reimplemented the parse logic of TAP::Parser as a state machine.
+ - Removed various ad-hoc state variables from TAP::Parser and moved
+ their logic into the state machine.
+ - Removed now-unused is_first / is_last methods from Iterator and
+ simplified remaining logic to suit.
+ - Removed now-redundant t/140-varsource.t.
+ - Implemented TAP version syntax.
+ - Tidied TAP::Harness::Compatible documentation
+ - Removed redundant modules below TAP::Harness::Compatible
+ - Removed unused compatibility tests
+
+0.50_07 5 March 2007
+ - Fixed bug where we erroneously checked the test number instead of number
+ of tests run to determine if we've run more tests than we planned.
+ - Add a --directives switch to 'runtests' which only shows test results
+ with directives (such as 'TODO' or 'SKIP').
+ - Removed some dead code from TAPx::Parser.
+ - Added color support for Windows using Win32::Console.
+ - Made Color::failure_output reset colors before printing
+ the trailing newline.
+ - Corrected some issues with the 'runtests' docs and removed some
+ performance notes which no longer seem accurate.
+ - Fixed bug whereby if tests without file extensions were included then
+ the spacing of the result leaders would be off.
+ - execrc file is now a YAML file.
+ - Removed white background on the test failures. It was too garish for
+ me. Just more proof that we need better ways of overriding color
+ support.
+ - Started work on TAPx::Harness::Compatible. Right now it's mainly just
+ a direct lift of Test::Harness to make sure the tests work.
+ - Commented out use Data::Dumper::Simple in T::Harness.pm - it's not
+ a core module.
+ - Added next_raw to TAPx::Parser::Iterator which skips any fixes for
+ quirky TAP that are implemented by next. Used to support
+ TAPx::Harness::Compatible::Iterator
+ - Applied our version number to all T::H::Compatible modules
+ - Removed T::H::C::Assert. It's documented as being private to
+ Test::Harness and we're not going to need it.
+ - Refactored runtests to call aggregate_tests to expose the
+ interface we need for the compatibility layer.
+ - Make it possible to pass an end time to summary so that it needn't
+ be called immediately after the tests complete.
+ - Moved callback handling into TAPx::Base and altered TAPx::Parser
+ to use it.
+ - Made TAPx::Harness into a subclass of TAPx::Base and implemented
+ made_parser callback.
+ - Moved the dispatch of callbacks out of run and into next so that
+ they're called when TAPx::Harness iterates through the results.
+ - Implemented PERL_TEST_HARNESS_DUMP_TAP which names a directory
+ into which the raw TAP of any tests run via TAPx::Harness will
+ be written.
+ - Rewrote the TAPx::Grammar->tokenize method to return a
+ TAPx::Parser::Result object. Code is much cleaner now.
+ - Moved the official grammar from TAPx::Parser to TAPx::Parser::Grammar,
+ provided a link and updated the grammar.
+ - Fixed bug where a properly escaped '# TODO' line in a test description
+ would still be reported as a TODO test.
+ - Added patches/ExtUtils-MakeMaker-6.31.patch - a patch against EUMM
+ that makes test_harness use TAPx::Harness instead of Test::Harness
+ if PERL_EUMM_USE_TAPX is true and TAPx::Harness is installed. In
+ other words cause 'make test' for EUMM based models to use
+ TAPx::Harness.
+ - Added support for timer option to TAPx::Harness which causes the
+ elapsed time for each test to be displayed.
+ - Setup tapx-dev@hexten.net mailing list.
+ - Fixed accumulating @$exec bug in TAPx::Harness.
+ - Made runtests pass '--exec' option as an array.
+ - (#24679) TAPx::Harness now reports failure for tests that die
+ after completing all subtests.
+ - Added in_todo attribute on TAPx::Parser which is true while the
+ most recently seen test was a TODO.
+ - (#24728) TAPx::Harness now supresses diagnostics from failed
+ TODOs. Not sure if the semantics of this are correct yet.
+
+0.50_06 18 January 2007
+ - Fixed doc typo in examples/README [rt.cpan.org #24409]
+ - Colored test output is now the default for 'runtests' unless
+ you're running under windows or -t STDOUT is false.
+ [rt.cpan.org #24310]
+ - Removed the .t extension from t/source_tests/*.t since those are
+ 'test tests' which caused false negatives when running recursive
+ tests. [Adrian Howard]
+ - Somewhere along the way, the exit status started working again.
+ Go figure.
+ - Factored color output so that disabling it under Windows is
+ cleaner.
+ - Added explicit switch to :crlf layer after open3 under Windows.
+ open3 defaults to raw mode resulting in spurious \r characters input
+ parsed input.
+ - Made Iterator do an explicit wait for subprocess termination.
+ Needed to get process status correctly on Windows.
+ - Fixed bug which didn't allow t/010-regression.t to be run directly
+ via Perl unless you specified Perl's full path.
+ - Removed SIG{CHLD} handler (which we shouldn't need I think because
+ we explicitly waitpid) and made binmode ':crlf' conditional on
+ IS_WIN32. On Mac OS these two things combined to expose a problem
+ which meant that output from test scripts was sometimes lost.
+ - Made t/110-source.t use File::Spec->catfile to build path to
+ test script.
+ - Made Iterator::FH init is_first, is_last to 0 rather than undef
+ for consistency with array iterator.
+ - Added t/120-varsource.t to test is_first and is_last semantics
+ over files with small numbers of lines.
+ - Added check for valid callback keys.
+ - Added t/130-results.t for Result classes.
+
+0.50_05 15 January 2007
+ - Removed debugging code accidentally left in bin/runtests.
+ - Removed 'local $/ = ...' from the iterator. Hopefully that will fix the
+ line ending bug, but I don't know about the wstat problem.
+
+0.50_04 14 January 2007
+ - BACKWARDS IMCOMPATIBLE: Renamed all '::Results' classes to '::Result'
+ because they represent a single result.
+ - Fixed bug where piping would break verbose output.
+ - IPC::Open3::open3 now takes a @command list rather than a $command
+ string. This should make it work under Windows.
+ - Added 'stdout_sterr' sample test back to regression tests. IPC::Open3
+ appears to make it work.
+ - Bug fix: don't print 'All tests successful' if no tests are run.
+ - Refactored 'runtests' to make it a bit easier to follow.
+ - Bug fix: Junk and comments now allowed before a leading plan.
+ - HARNESS_ACTIVE and HARNESS_VERSION environment variables now set.
+ - Renamed 'problems' in TAPx::Parser and TAPx::Aggregator to
+ 'has_problems'.
+
+0.50_03 08 January 2007
+
+ - Fixed bug where '-q' or '-Q' with colored tests weren't suppressing all
+ information.
+ - Fixed an annoying MANIFEST nit.
+ - Made '-h' for runtests now report help. Using a new harness requires
+ the full --harness switch.
+ - Added 'problems' method to TAPx::Parser and TAPx::Parser::Aggregator.
+ - Deprecatd 'todo_failed' in favor of 'todo_passed'
+ - Add -I switch to runtests.
+ - Fixed runtests doc nit (smylers)
+ - Removed TAPx::Parser::Builder.
+ - A few more POD nits taken care of.
+ - Completely removed all traces of C<--merge> as IPC::Open3 seems to be
+ working.
+ - Moved the tprove* examples to examples/bin in hopes of them no longer
+ showing up in CPAN's docs.
+ - Made the 'unexpectedly succeeded' message clearer (Adam Kennedy)
+
+0.50_02 06 January 2007
+ - Added some files I left out of the manifest (reported by Florian
+ Ragwitz).
+ - Added strict to Makefile.PL and changed @PROGRAM to @program (reported
+ Florian Ragwitz).
+
+0.50_01 06 January 2007
+ - Added a new example which shows to how test Perl, Ruby, and URLs all at
+ the same time using 'execrc' files.
+ - Fixed the diagnostic format mangling bug.
+ - We no longer override Test::Builder to merge streams. Instead, we go
+ ahead and use IPC::Open3. It remains to be seen whether or not this is
+ a good idea.
+ - Fixed vms nit: for failing tests, vms often has the 'not' on a line by
+ itself.
+ - Fixed bugs where unplanned tests were not reporting as a failure (test
+ number greater than tests planned).
+ - TAPx::Parser constructor can now take an 'exec' option to tell it what
+ to execute to create the stream (huge performance boost).
+ - Added TAPx::Parser::Source. This allows us to run tests in just about
+ any programming language.
+ - Renamed the filename() method to source() in TAPx::Parser::Source::Perl.
+ - We now cache the @INC values found for TAPx::Parser::Source::Perl.
+ - Added two test harnesses, TAPx::Harness and TAPx::Harness::Color.
+ - Removed references to manual stream construction from TAPx::Parser
+ documentation. Users should not (usually) need to worry about streams.
+ - Added bin/runtests utility. This is very similar to 'prove'.
+ - Renumbered tests to make it easier to add new ones.
+ - Corrected some minor documentation nits.
+ - Makefile.PL is no longer auto-generated (it's built by hand).
+ - Fixed regression test bug where driving tests through the harness I'm
+ testing caused things to break.
+ - BUG: exit() values are now broken. I don't know how to capture them
+ with IPC::Open3. However, since no one appears to be using them, this
+ might not be an issue.
+
+0.41 12 December 2006
+ - Fixed (?) 10-regression.t test which failed on Windows. Removed the
+ segfault test as it has no meaning on Windows. Reported by PSINNOTT
+ <link@redbrick.dcu.ie> and fix recommended by Schwern based on his
+ Test::Harness experience.
+ http://rt.cpan.org/Ticket/Display.html?id=21624
+
+0.40 05 December 2006
+ - Removed TAPx::Parser::Streamed and folded its functionality into
+ TAPx::Parser.
+ - Fixed bug where sometimes is_good_plan() would return a false positive
+ (exposed by refactoring).
+ - A number of tiny performance enhancements.
+
+0.33 22 September 2006
+ - OK, I'm getting ticked off by some of the comments on Perl-QA so I
+ rushed this out the door and broke it :( I'm backing out one test and
+ slowing down a bit.
+
+0.32 22 September 2006
+ - Applied patch from Schwern which fixed the Builder package name (TAPx::
+ instead of TAPX:: -- stupid case-insensitive package names!).
+ [rt.cpan.org #21605]
+
+0.31 21 September 2006
+ - Fixed bug where Carp::croak without parens could cause Perl to fail to
+ compile on some platforms. [Andreas J. Koenig]
+ - Eliminated the non-portable redirect of STDERR to STDOUT (2>&1) and
+ fixed the synchronization issue. This involves overridding
+ Test::Builder::failure_output() in a very sneaky way. I may have to
+ back this out.
+ - Renamed boolean methods to begin with 'is_'. The methods they replace
+ are documented, deprecated, and will not be removed prior to version
+ 1.00.
+
+0.30 17 September 2006
+ - Fixed bug where no output would still claim to have a good plan.
+ - Fixed bug where no output would cause parser to die.
+ - Fixed bug where failing to specify a plan would be two parse errors
+ instead of one.
+ - Fixed bug where a correct plan count in an incorrect place would still
+ report as a 'good_plan'.
+ - Fixed bug where comments could accidently be misparsed as directives.
+ - Eliminated testing of internal structure of result objects. The other
+ tests cover this.
+ - Allow hash marks in descriptions. This was causing a problem because
+ many test suites (Regexp::Common and Perl core) allowed them to exist.
+ - Added support for SKIP directives in plans.
+ - Did some work simplifying &TAPx::Parser::_initialize. It's not great,
+ but it's better than it was.
+ - TODO tests now always pass, regardless of actual_passed status.
+ - Removed 'use warnings' and now use -w
+ - 'switches' may now be passed to the TAPx::Parser constructor.
+ - Added 'exit' status.
+ - Added 'wait' status.
+ - Eliminated 'use base'. This is part of the plan to make TAPx::Parser
+ compatible with older versions of Perl.
+ - Added 'source' key to the TAPx::Parser constructor. Making new parsers
+ is now much easier.
+ - Renamed iterator first() and last() methods to is_first() and is_last().
+ Credit: Aristotle.
+ - Planned tests != tests run is now a parse error. It was really stupid
+ of me not to do that in the first place.
+ - Added massive regression test suite in t/100-regression.t
+ - Updated the grammar to show that comments are allowed.
+ - Comments are now permitted after an ending plan.
+
+0.22 13 September 2006
+ - Removed buggy support for multi-line chunks from streams. If your
+ streams or iterators return anything but single lines, this is a bug.
+ - Fixed bug whereby blank lines in TAP would confuse the parser. Reported
+ by Torsten Schoenfeld.
+ - Added first() and last() methods to the iterator.
+ - TAPx::Parser::Source::Perl now has a 'switches' method which allows
+ switches to be passed to the perl executable running the test file.
+ This allows tprove to accept a '-l' argument to force lib/ to be
+ included in Perl's @INC.
+
+0.21 8 September 2006
+ - Included experimental GTK interface written by Torsten Schoenfeld.
+ - Fixed bad docs in examples/tprove_color
+ - Applied patch from Shlomi Fish fixing bug where runs from one stream
+ could leak into another when bailing out. [rt.cpan.org #21379]
+ - Fixed some typos in the POD.
+ - Corrected the grammar to allow for a plan of "1..0" (infinite stream).
+ - Started to add proper acknowledgements.
+
+0.20 2 September 2006
+ - Fixed bug reported by GEOFFR. When no tap output was found, an
+ "Unitialized value" warning occurred. [rt.cpan.org #21205]
+ - Updated tprove to now report a test failure when no tap output found.
+ - Removed examples/tprove_color2 as tprove_color now works.
+ - Vastly improved callback system and updated the docs for how to use
+ them.
+ - Changed TAPx::Parser::Source::Perl to use Symbol::gensym() instead of a
+ hard-to-guess filehandle name.
+
+0.12 30 July 2006
+ - Added a test colorization script
+ - Callback support added.
+ - Added TAPx::Parser::Source::Perl.
+ - Added TAPx::Parser::Aggregator.
+ - Added version numbers to all classes.
+ - Added 'todo_failed' test result and parser.
+ - 00-load.t now loads all classes instead of having individual tests load
+ their supporting classes.
+ - Changed $parser->results to $parser->next
+
+0.11 25 July, 2006
+ - Renamed is_skip and is_todo to has_skip and has_todo. Much less
+ confusing since a result responding true to those also responded true to
+ is_test.
+ - Added simplistic bin/tprove to run tests. Much harder than I thought
+ and much code stolen from Test::Harness.
+ - Modified stolen iterator to fix a bug with stream handling when extra
+ newlines were encountered.
+ - Added TAPx::Parser::Iterator (stolen from Test::Harness::Iterator)
+ - Normalized internal structure of result objects.
+ - All tokens now have a 'type' key. This greatly simplifies internals.
+ - Copied much result POD info into the main docs.
+ - Corrected the bug report URLs.
+ - Minor updates to the grammar listed in the POD.
+
+0.10 23 July, 2006
+ - Oh my Larry, we gots docs!
+ - _parse and _tap are now private methods.
+ - Stream support has been added.
+ - Moved the grammar into its own class.
+ - Pulled remaining parser functionality out of lexer.
+ - Added type() method to Results().
+ - Parse errors no longer croak(). Instead, they are available through the
+ parse_errors() method.
+ - Added good_plan() method.
+ - tests_planned != tests_run is no longer a parse error.
+ - Renamed test_count() to tests_run().
+ - Renamed num_tests() to tests_planned().
+
+0.03 17 July, 2006
+ - 'Bail out!' is now handled.
+ - The parser is now data driven, thus skipping a huge if/else chain
+ - We now track all TODOs, SKIPs, passes and fails by test number.
+ - Removed all non-core modules.
+ - Store original line for each TAP line. Available through
+ $result->raw().
+ - Renamed test is_ok() to passed() and added actual_passed(). The former
+ method takes into account TODO tests and the latter returns the actual
+ pass/fail status.
+ - Fixed a bug where SKIP tests would not be identified correctly.
+
+0.02 8 July, 2006
+ - Moved some lexer responsibility to the parser. This will allow us to
+ eventually parse streams.
+ - Properly track passed/failed tests, even accounting for TODO.
+ - Added support for comments and unknown lines.
+ - Allow explicit and inferred test numbers to be mixed.
+ - Allow escaped hashes in the test description.
+ - Renamed to TAPx::Parser. Will probably rename it again.
+
+0.01 Date/time
+ - First version, unreleased on an unsuspecting world.
+ - No, you'll never know when ...
+
+========================================================================
+Changes-2.64:
+
Revision history for Perl extension Test::Harness
+This is the revision history for the previous version of Test::Harness
+up to 2.64. The current version of test harness is a complete rewrite of
+this code.
+
NEXT
[FIXES]
* prove's --perl=/path/to/file wasn't taking a value.
diff -urN perl-5.10.0.orig/lib/Test/Harness/Iterator.pm perl-5.10.0/lib/Test/Harness/Iterator.pm
--- perl-5.10.0.orig/lib/Test/Harness/Iterator.pm 2009-02-20 11:39:19.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<FOR INTERNAL USE ONLY!>
-
-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 perl-5.10.0.orig/lib/Test/Harness/Point.pm perl-5.10.0/lib/Test/Harness/Point.pm
--- perl-5.10.0.orig/lib/Test/Harness/Point.pm 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/Results.pm perl-5.10.0/lib/Test/Harness/Results.pm
--- perl-5.10.0.orig/lib/Test/Harness/Results.pm 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/Straps.pm perl-5.10.0/lib/Test/Harness/Straps.pm
--- perl-5.10.0.orig/lib/Test/Harness/Straps.pm 2009-02-20 11:39:19.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<THIS IS ALPHA SOFTWARE> 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<Please> 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<Results>.
-
-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<analyze>, 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<analyze>, 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 = <TEST>;
- 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<PERL5LIB>.
-
-=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<PERL5LIB> 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<examples/mini_harness.plx> for an example of use.
-
-=head1 AUTHOR
-
-Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by
-Andy Lester C<< <andy at petdance.com> >>.
-
-=head1 SEE ALSO
-
-L<Test::Harness>
-
-=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 perl-5.10.0.orig/lib/Test/Harness/TAP.pod perl-5.10.0/lib/Test/Harness/TAP.pod
--- perl-5.10.0.orig/lib/Test/Harness/TAP.pod 2009-02-20 11:39:19.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<prove> program, or the underlying
-C<Test::Harness::runtests> subroutine.
-
-A harness must only read TAP output from standard output and not
-from standard error. Lines written to standard output matching
-C</^(not )?ok\b/> 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<ok> or C<not ok>
-
-This tells whether the test point passed or failed. It must be
-at the beginning of the line. C</^not ok/> indicates a failed test
-point. C</^ok/> is a successful test point. This is the only mandatory
-part of the line.
-
-Note that unlike the Directives below, C<ok> and C<not ok> are
-case-sensitive.
-
-=item * Test number
-
-TAP expects the C<ok> or C<not ok> 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<TODO> and
-C<SKIP>. 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<TODO> and C<SKIP>. 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<TODO> 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<TODO> 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<not> 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<TAP.StringDiff>, 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<< <schwern@pobox.com> >>,
-Andy Lester C<< <andy@petdance.com> >>.
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>.
-
-=cut
diff -urN perl-5.10.0.orig/lib/Test/Harness/Util.pm perl-5.10.0/lib/Test/Harness/Util.pm
--- perl-5.10.0.orig/lib/Test/Harness/Util.pm 2009-02-20 11:39:19.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<CVS>
-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 perl-5.10.0.orig/lib/Test/Harness/bin/prove perl-5.10.0/lib/Test/Harness/bin/prove
--- perl-5.10.0.orig/lib/Test/Harness/bin/prove 2009-02-20 11:39:19.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/bin/prove 2009-03-10 17:20:32.000000000 +0100
@@ -1,292 +1,290 @@
#!/usr/bin/perl -w
use strict;
+use App::Prove;
-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 );
-}
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+exit( $app->run ? 0 : 1 );
__END__
=head1 NAME
-prove -- A command-line tool for running tests against Test::Harness
+prove - Run tests through a TAP harness.
-=head1 SYNOPSIS
+=head1 USAGE
-prove [options] [files/directories]
+ prove [options] [files or 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
+Boolean options:
-Single-character options may be stacked. Default options may be set by
-specifying the PROVE_SWITCHES environment variable.
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' and 'blib/arch' to the path for your tests
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ --count Show the X/Y test count when not verbose (default)
+ --nocount Disable the X/Y test count.
+ -D --dry Dry run. Show test that would have run.
+ --ext Set the extension for tests (default '.t')
+ -f, --failures Only show failed tests.
+ --fork Fork to run harness in multiple processes.
+ --ignore-exit Ignore exit status from test scripts.
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+ --norc Don't process default .proverc
-=head1 OVERVIEW
+Options that take arguments:
-F<prove> is a command-line interface to the test-running functionality
-of C<Test::Harness>. With no arguments, it will run all tests in the
-current directory.
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See TAP::Harness.
+ -a, --archive Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+ --state=opts Control prove's persistent state.
+ --rc=rcfile Process options from rcfile
-Shell metacharacters may be used with command lines options and will be exanded
-via C<File::Glob::bsd_glob>.
+=head1 NOTES
-=head1 PROVE VS. "MAKE TEST"
+=head2 .proverc
-F<prove> has a number of advantages over C<make test> when doing development.
+If F<~/.proverc> or F<./.proverc> exist they will be read and any
+options they contain processed before the command line options. Options
+in F<.proverc> are specified in the same way as command line options:
-=over 4
+ # .proverc
+ --state=hot,fast,save
+ -j9 --fork
-=item * F<prove> is designed as a development tool
+Additional option files may be specified with the C<--rc> option.
+Default option file processing is disabled by the C<--norc> option.
-Perl users typically run the test harness through a makefile via
-C<make test>. That's fine for module distributions, but it's
-suboptimal for a test/code/debug development cycle.
+Under Windows and VMS the option file is named F<_proverc> rather than
+F<.proverc> and is sought only in the current directory.
-=item * F<prove> is granular
+=head2 Reading from C<STDIN>
-F<prove> lets your run against only the files you want to check.
-Running C<prove t/live/ t/master.t> checks every F<*.t> in F<t/live>,
-plus F<t/master.t>.
+If you have a list of tests (or URLs, or anything else you want to test) in a
+file, you can add them to your tests by using a '-':
-=item * F<prove> has an easy verbose mode
+ prove - < my_list_of_things_to_test.txt
-F<prove> has a C<-v> option to see the raw output from the tests.
-To do this with C<make test>, you must set C<HARNESS_VERBOSE=1> in
-the environment.
+See the C<README> in the C<examples> directory of this distribution.
-=item * F<prove> can run under taint mode
+=head2 Default Test Directory
-F<prove>'s C<-T> runs your tests under C<perl -T>, and C<-t> runs them
-under C<perl -t>.
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
-=item * F<prove> can shuffle tests
+=head2 Colored Test Output
-You can use F<prove>'s C<--shuffle> option to try to excite problems
-that don't show up when tests are run in the same order every time.
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
-=item * F<prove> doesn't rely on a make tool
+Color support requires L<Term::ANSIColor> on Unix-like platforms and
+L<Win32::Console> windows. If the necessary module is not installed
+colored output will not be available.
-Not everyone wants to write a makefile, or use L<ExtUtils::MakeMaker>
-to do so. F<prove> has no external dependencies.
+=head2 Arguments to Tests
-=item * Not everything is a module
+It is possible to supply arguments to tests. To do so separate them from
+prove's own arguments with the arisdottle, '::'. For example
-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 -v t/mytest.t :: --url http://example.com
+
+would run F<t/mytest.t> with the options '--url http://example.com'.
+When running multiple tests they will each receive the same arguments.
-=back
+=head2 C<--exec>
+
+Normally you can just pass a list of Perl tests and the harness will know how
+to execute them. However, if your tests are not written in Perl or if you
+want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
+switch:
+
+ prove --exec '/usr/bin/ruby -w' t/
+ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
+ prove --exec '/path/to/my/customer/exec'
+
+=head2 C<--merge>
+
+If you need to make sure your diagnostics are displayed in the correct
+order relative to test results you can use the C<--merge> option to
+merge the test scripts' STDERR into their STDOUT.
+
+This guarantees that STDOUT (where the test results appear) and STDOUT
+(where the diagnostics appear) will stay in sync. The harness will
+display any diagnostics your tests emit on STDERR.
+
+Caveat: this is a bit of a kludge. In particular note that if anything
+that appears on STDERR looks like a test result the test harness will
+get confused. Use this option only if you understand the consequences
+and can live with the risk.
+
+=head2 C<--state>
+
+You can ask C<prove> to remember the state of previous test runs and
+select and/or order the tests to be run based on that saved state.
+
+The C<--state> switch requires an argument which must be a comma
+separated list of one or more of the following options.
+
+=over
+
+=item C<last>
-=head1 COMMAND LINE OPTIONS
+Run the same tests as the last time the state was saved. This makes it
+possible, for example, to recreate the ordering of a shuffled test.
-=head2 -b, --blib
+ # Run all tests in random order
+ $ prove -b --state=save --shuffle
-Adds blib/lib to the path for your tests, a la "use blib".
+ # Run them again in the same order
+ $ prove -b --state=last
-=head2 -d, --debug
+=item C<failed>
-Include debug information about how F<prove> is being run. This
-option doesn't show the output from the test scripts. That's handled
-by -v,--verbose.
+Run only the tests that failed on the last run.
-=head2 -D, --dry
+ # Run all tests
+ $ prove -b --state=save
+
+ # Run failures
+ $ prove -b --state=failed
-Dry run: Show the tests to run, but don't run them.
+If you also specify the C<save> option newly passing tests will be
+excluded from subsequent runs.
-=head2 -I
+ # Repeat until no more failures
+ $ prove -b --state=failed,save
-Add libraries to @INC, as Perl's -I.
+=item C<passed>
-=head2 -l, --lib
+Run only the passed tests from last time. Useful to make sure that no
+new problems have been introduced.
-Add C<lib> to @INC. Equivalent to C<-Ilib>.
+=item C<all>
-=head2 --perl
+Run all tests in normal order. Multple options may be specified, so to
+run all tests with the failures from last time first:
-Sets the C<HARNESS_PERL> environment variable, which controls what
-Perl executable will run the tests.
+ $ prove -b --state=failed,all,save
-=head2 -r, --recurse
+=item C<hot>
-Descends into subdirectories of any directories specified, looking for tests.
+Run the tests that most recently failed first. The last failure time of
+each test is stored. The C<hot> option causes tests to be run in most-recent-
+failure order.
-=head2 -s, --shuffle
+ $ prove -b --state=hot,save
-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.
+Tests that have never failed will not be selected. To run all tests with
+the most recently failed first use
-=head2 --strap
+ $ prove -b --state=hot,all,save
-Sets the HARNESS_STRAP_CLASS variable to set which Test::Harness::Straps
-variable to use in running the tests.
+This combination of options may also be specified thus
-=head2 -t
+ $ prove -b --state=adrian
-Runs test programs under perl's -t taint warning mode.
+=item C<todo>
-=head2 -T
+Run any tests with todos.
-Runs test programs under perl's -T taint mode.
+=item C<slow>
-=head2 --timer
+Run the tests in slowest to fastest order. This is useful in conjunction
+with the C<-j> parallel testing switch to ensure that your slowest tests
+start running first.
-Print elapsed time after each test file
+ $ prove -b --state=slow -j9
-=head2 -v, --verbose
+=item C<fast>
-Display standard output of test scripts while running them. Also sets
-TEST_VERBOSE in case your tests rely on them.
+Run test tests in fastest to slowest order.
-=head2 -V, --version
+=item C<new>
-Display version info.
+Run the tests in newest to oldest order based on the modification times
+of the test scripts.
-=head1 BUGS
+=item C<old>
-Please use the CPAN bug ticketing system at L<http://rt.cpan.org/>.
-You can also mail bugs, fixes and enhancements to
-C<< <bug-test-harness@rt.cpan.org> >>.
+Run the tests in oldest to newest order.
-=head1 TODO
+=item C<fresh>
-=over 4
+Run those test scripts that have been modified since the last test run.
-=item *
+=item C<save>
-Shuffled tests must be recreatable
+Save the state on exit. The state is stored in a file called F<.prove>
+(F<_prove> on Windows and VMS) in the current directory.
=back
-=head1 AUTHORS
+The C<--state> switch may be used more than once.
-Andy Lester C<< <andy at petdance.com> >>
+ $ prove -b --state=hot --state=all,save
-=head1 COPYRIGHT
+=head2 Taint Mode
-Copyright 2004-2006 by Andy Lester C<< <andy at petdance.com> >>.
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+Because C<PERL5LIB> is often used during testing to add build directories
+to C<@INC> prove (actually L<TAP::Parser::Source::Perl>) passes the
+names of any directories found in C<PERL5LIB> as -I switches. The net
+effect of this is that C<PERL5LIB> is honoured even when prove is run in
+taint mode.
-See L<http://www.perl.com/perl/misc/Artistic.html>.
+=head1 PLUGINS
+
+Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
+plugin name:
+
+ prove -PMyPlugin=fou,du,fafa
+
+Please check individual plugin documentation for more details.
+
+=head2 Available Plugins
+
+For an up-to-date list of plugins available, please check CPAN:
+
+L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
+
+=head2 Writing Plugins
+
+Please see L<App::Prove/PLUGINS>.
=cut
+
+# vim:ts=4:sw=4:et:sta
diff -urN perl-5.10.0.orig/lib/Test/Harness/t/00compile.t perl-5.10.0/lib/Test/Harness/t/00compile.t
--- perl-5.10.0.orig/lib/Test/Harness/t/00compile.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/assert.t perl-5.10.0/lib/Test/Harness/t/assert.t
--- perl-5.10.0.orig/lib/Test/Harness/t/assert.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/base.t perl-5.10.0/lib/Test/Harness/t/base.t
--- perl-5.10.0.orig/lib/Test/Harness/t/base.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/callback.t perl-5.10.0/lib/Test/Harness/t/callback.t
--- perl-5.10.0.orig/lib/Test/Harness/t/callback.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/failure.t perl-5.10.0/lib/Test/Harness/t/failure.t
--- perl-5.10.0.orig/lib/Test/Harness/t/failure.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/from_line.t perl-5.10.0/lib/Test/Harness/t/from_line.t
--- perl-5.10.0.orig/lib/Test/Harness/t/from_line.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/harness.t perl-5.10.0/lib/Test/Harness/t/harness.t
--- perl-5.10.0.orig/lib/Test/Harness/t/harness.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/inc_taint.t perl-5.10.0/lib/Test/Harness/t/inc_taint.t
--- perl-5.10.0.orig/lib/Test/Harness/t/inc_taint.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/nonumbers.t perl-5.10.0/lib/Test/Harness/t/nonumbers.t
--- perl-5.10.0.orig/lib/Test/Harness/t/nonumbers.t 2009-02-20 11:39:19.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 <<END;
-1..6
-ok
-ok
-ok
-ok
-ok
-ok
-END
diff -urN perl-5.10.0.orig/lib/Test/Harness/t/ok.t perl-5.10.0/lib/Test/Harness/t/ok.t
--- perl-5.10.0.orig/lib/Test/Harness/t/ok.t 2009-02-20 11:39:19.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/ok.t 1970-01-01 01:00:00.000000000 +0100
@@ -1,8 +0,0 @@
--f "core" and unlink "core";
-print <<END;
-1..4
-ok 1
-ok 2
-ok 3
-ok 4
-END
diff -urN perl-5.10.0.orig/lib/Test/Harness/t/point-parse.t perl-5.10.0/lib/Test/Harness/t/point-parse.t
--- perl-5.10.0.orig/lib/Test/Harness/t/point-parse.t 2009-02-20 11:39:19.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/point-parse.t 1970-01-01 01:00:00.000000000 +0100
@@ -1,106 +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 => 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 perl-5.10.0.orig/lib/Test/Harness/t/point.t perl-5.10.0/lib/Test/Harness/t/point.t
--- perl-5.10.0.orig/lib/Test/Harness/t/point.t 2009-02-20 11:39:19.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 = <<EOF;
-# Line 1
-# Line two
-# Third line
-EOF
-
-chomp $diagstr;
-my $string_diagnostics = $point->diagnostics;
-is( $string_diagnostics, $diagstr, "Diagnostics in scalar context" );
diff -urN perl-5.10.0.orig/lib/Test/Harness/t/prove-globbing.t perl-5.10.0/lib/Test/Harness/t/prove-globbing.t
--- perl-5.10.0.orig/lib/Test/Harness/t/prove-globbing.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/prove-switches.t perl-5.10.0/lib/Test/Harness/t/prove-switches.t
--- perl-5.10.0.orig/lib/Test/Harness/t/prove-switches.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/strap-analyze.t perl-5.10.0/lib/Test/Harness/t/strap-analyze.t
--- perl-5.10.0.orig/lib/Test/Harness/t/strap-analyze.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/strap.t perl-5.10.0/lib/Test/Harness/t/strap.t
--- perl-5.10.0.orig/lib/Test/Harness/t/strap.t 2009-02-20 11:39:19.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 perl-5.10.0.orig/lib/Test/Harness/t/test-harness.t perl-5.10.0/lib/Test/Harness/t/test-harness.t
--- perl-5.10.0.orig/lib/Test/Harness/t/test-harness.t 2009-02-20 11:39:19.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 = <<WARN;
-Enormous test number seen [test 136211425]
-Can't detailize, too big.
-WARN
- }
- elsif ( $test eq 'bignum_many' ) {
- $expected_warnings = <<WARN;
-Enormous test number seen [test 100001]
-Can't detailize, too big.
-WARN
- }
- my $desc = $expected_warnings ? 'Got proper warnings' : 'No warnings';
- is( $warning, $expected_warnings, "$test - $desc" );
-} # taint SKIP block
-} # for tests
diff -urN perl-5.10.0.orig/lib/Test/Harness/t/version.t perl-5.10.0/lib/Test/Harness/t/version.t
--- perl-5.10.0.orig/lib/Test/Harness/t/version.t 2009-02-20 11:39:19.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/version.t 1970-01-01 01:00:00.000000000 +0100
@@ -1,23 +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 => 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 perl-5.10.0.orig/lib/Test/Harness.pm perl-5.10.0/lib/Test/Harness.pm
--- perl-5.10.0.orig/lib/Test/Harness.pm 2009-02-20 11:39:19.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness.pm 2009-03-10 17:39:08.000000000 +0100
@@ -1,28 +1,38 @@
-# -*- 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 constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source::Perl ();
+use TAP::Parser::Utils qw( split_shell );
+
+use Config;
+use Exporter;
+
+# TODO: Emulate at least some of these
use vars qw(
- $VERSION
- @ISA @EXPORT @EXPORT_OK
- $Verbose $Switches $Debug
- $verbose $switches $debug
- $Columns
- $Timer
- $ML $Last_ML_Print
- $Strap
- $has_time_hires
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Color
+ $Directives
+ $Timer
+ $Strap
+ $has_time_hires
+ $IgnoreExit
);
+# $ML $Last_ML_Print
+
BEGIN {
eval q{use Time::HiRes 'time'};
$has_time_hires = !$@;
@@ -34,72 +44,39 @@
=head1 VERSION
-Version 2.64
+Version 3.16
=cut
-$VERSION = '2.64';
+$VERSION = '3.16';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
*switches = *Switches;
*debug = *Debug;
-$ENV{HARNESS_ACTIVE} = 1;
+$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');
+@ISA = ('Exporter');
@EXPORT = qw(&runtests);
@EXPORT_OK = qw(&execute_tests $verbose $switches);
-$Verbose = $ENV{HARNESS_VERBOSE} || 0;
-$Debug = $ENV{HARNESS_DEBUG} || 0;
+$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;
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Columns--; # Some shells have trouble with a full line of text.
+$Timer = $ENV{HARNESS_TIMER} || 0;
+$Color = $ENV{HARNESS_COLOR} || 0;
+$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
=head1 SYNOPSIS
@@ -109,169 +86,353 @@
=head1 DESCRIPTION
-B<STOP!> 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.
+Although, for historical reasons, the L<Test::Harness> distribution
+takes its name from this module it now exists only to provide
+L<TAP::Harness> with an interface that is somewhat backwards compatible
+with L<Test::Harness> 2.xx. If you're writing new code consider using
+L<TAP::Harness> directly instead.
+
+Emulation is provided for C<runtests> and C<execute_tests> but the
+pluggable 'Straps' interface that previous versions of L<Test::Harness>
+supported is not reproduced here. Straps is now available as a stand
+alone module: L<Test::Harness::Straps>.
-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<Test::Harness::TAP>.
+See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
+distribution.
-C<Test::Harness::runtests(@tests)> runs all the testscripts named
-as arguments and checks standard output for the expected strings
-in TAP format.
+=head1 FUNCTIONS
-The F<prove> utility is a thin wrapper around Test::Harness.
+The following functions are available.
-=head2 Taint mode
+=head2 runtests( @test_files )
-Test::Harness will honor the C<-T> or C<-t> in the #! line on your
-test files. So if you begin a test with:
+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.
- #!perl -T
+It returns true if everything was ok. Otherwise it will C<die()> with
+one of the messages in the DIAGNOSTICS section.
-the test will be run with taint mode on.
+=cut
-=head2 Configuration variables.
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
+}
-These variables can be used to configure the behavior of
-Test::Harness. They are exported on request.
+sub _aggregate {
+ my ( $harness, $aggregate, @tests ) = @_;
-=over 4
+ # Don't propagate to our children
+ local $ENV{HARNESS_OPTIONS};
-=item C<$Test::Harness::Verbose>
+ _apply_extra_INC($harness);
+ _aggregate_tests( $harness, $aggregate, @tests );
+}
-The package variable C<$Test::Harness::Verbose> is exportable and can be
-used to let C<runtests()> display the standard output of the script
-without altering the behavior otherwise. The F<prove> utility's C<-v>
-flag will set this.
+# Make sure the child seens all the extra junk in @INC
+sub _apply_extra_INC {
+ my $harness = shift;
-=item C<$Test::Harness::switches>
+ $harness->callback(
+ parser_args => sub {
+ my ( $args, $test ) = @_;
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
+ );
+}
-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<HARNESS_PERL_SWITCHES>.
+sub _aggregate_tests {
+ my ( $harness, $aggregate, @tests ) = @_;
+ $aggregate->start();
+ $harness->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop();
-=item C<$Test::Harness::Timer>
+}
-If set to true, and C<Time::HiRes> is available, print elapsed seconds
-after each test file.
+sub runtests {
+ my @tests = @_;
-=back
+ # shield against -l
+ local ( $\, $, );
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
-=head2 Failure
+ _aggregate( $harness, $aggregate, @tests );
-When tests fail, analyze the summary report:
+ $harness->formatter->summary($aggregate);
- 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.
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+ my $failed = $aggregate->failed;
-Everything passed but F<t/waterloo.t>. It failed 10 of 20 tests and
-exited with non-zero status indicating something dubious happened.
+ my @parsers = $aggregate->parsers;
-The columns in the summary report mean:
+ my $num_bad = 0;
+ for my $parser (@parsers) {
+ $num_bad++ if $parser->has_problems;
+ }
-=over 4
+ die(sprintf(
+ "Failed %d/%d test programs. %d/%d subtests failed.\n",
+ $num_bad, scalar @parsers, $failed, $total
+ )
+ ) if $num_bad;
-=item B<Failed Test>
+ return $total && $total == $passed;
+}
-The test file which failed.
+sub _canon {
+ my @list = sort { $a <=> $b } @_;
+ my @ranges = ();
+ my $count = scalar @list;
+ my $pos = 0;
-=item B<Stat>
+ while ( $pos < $count ) {
+ my $end = $pos + 1;
+ $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
+ push @ranges, ( $end == $pos + 1 )
+ ? $list[$pos]
+ : join( '-', $list[$pos], $list[ $end - 1 ] );
+ $pos = $end;
+ }
-If the test exited with non-zero, this is its exit status.
+ return join( ' ', @ranges );
+}
-=item B<Wstat>
+sub _new_harness {
+ my $sub_args = shift || {};
-The wait status of the test.
+ my ( @lib, @switches );
+ for my $opt ( split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ) ) {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, $1;
+ }
+ else {
+ push @switches, $opt;
+ }
+ }
-=item B<Total>
+ # Do things the old way on VMS...
+ push @lib, _filtered_inc() if IS_VMS;
-Total number of tests expected to run.
+ # If $Verbose isn't numeric default to 1. This helps core.
+ my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
-=item B<Fail>
+ my $args = {
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ color => $Color,
+ verbosity => $verbosity,
+ ignore_exit => $IgnoreExit,
+ };
-Number which failed, either from "not ok" or because they never ran.
+ $args->{stdout} = $sub_args->{out}
+ if exists $sub_args->{out};
-=item B<List of Failed>
+ if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
+ for my $opt ( split /:/, $env_opt ) {
+ if ( $opt =~ /^j(\d*)$/ ) {
+ $args->{jobs} = $1 || 9;
+ }
+ elsif ( $opt eq 'f' ) {
+ $args->{fork} = 1;
+ }
+ elsif ( $opt eq 'c' ) {
+ $args->{color} = 1;
+ }
+ else {
+ die "Unknown HARNESS_OPTIONS item: $opt\n";
+ }
+ }
+ }
-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).
+ return TAP::Harness->new($args);
+}
-=back
+# Get the parts of @INC which are changed from the stock list AND
+# preserve reordering of stock directories.
+sub _filtered_inc {
+ my @inc = grep { !ref } @INC; #28567
+ if (IS_VMS) {
-=head1 FUNCTIONS
+ # 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;
-The following functions are available.
+ }
+ elsif (IS_WIN32) {
-=head2 runtests( @test_files )
+ # Lose any trailing backslashes in the Win32 paths
+ s/[\\\/]+$// foreach @inc;
+ }
-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.
+ my @default_inc = _default_inc();
-It returns true if everything was ok. Otherwise it will C<die()> with
-one of the messages in the DIAGNOSTICS section.
+ my @new_inc;
+ my %seen;
+ for my $dir (@inc) {
+ next if $seen{$dir}++;
-=cut
+ if ( $dir eq ( $default_inc[0] || '' ) ) {
+ shift @default_inc;
+ }
+ else {
+ push @new_inc, $dir;
+ }
-sub runtests {
- my(@tests) = @_;
+ shift @default_inc while @default_inc and $seen{ $default_inc[0] };
+ }
+
+ return @new_inc;
+}
- local ($\, $,);
+{
- my ($tot, $failedtests,$todo_passed) = execute_tests(tests => \@tests);
- print get_results($tot, $failedtests,$todo_passed);
+ # Cache this to avoid repeatedly shelling out to Perl.
+ my @inc;
- my $ok = _all_ok($tot);
+ sub _default_inc {
+ return @inc if @inc;
- assert(($ok xor keys %$failedtests),
- q{ok status jives with $failedtests});
+ local $ENV{PERL5LIB};
+ local $ENV{PERLLIB};
- if (! $ok) {
- die("Failed $tot->{bad}/$tot->{tests} test programs. " .
- "@{[$tot->{max} - $tot->{ok}]}/$tot->{max} subtests failed.\n");
+ my $perl = $ENV{HARNESS_PERL} || $^X;
+
+ # Avoid using -l for the benefit of Perl 6
+ chomp( @inc = `$perl -e "print join qq[\\n], \@INC, q[]"` );
+ return @inc;
}
+}
- return $ok;
+sub _check_sequence {
+ my @list = @_;
+ my $prev;
+ while ( my $next = shift @list ) {
+ return if defined $prev && $next <= $prev;
+ $prev = $next;
+ }
+
+ return 1;
}
-# my $ok = _all_ok(\%tot);
-# Tells you if this test run is overall successful or not.
+sub execute_tests {
+ my %args = @_;
+
+ my $harness = _new_harness( \%args );
+ my $aggregate = TAP::Parser::Aggregator->new();
-sub _all_ok {
- my($tot) = shift;
+ my %tot = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ bad => 0,
+ good => 0,
+ files => 0,
+ tests => 0,
+ sub_skipped => 0,
+ todo => 0,
+ skipped => 0,
+ bench => undef,
+ );
+
+ # Install a callback so we get to see any plans the
+ # harness executes.
+ $harness->callback(
+ made_parser => sub {
+ my $parser = shift;
+ $parser->callback(
+ plan => sub {
+ my $plan = shift;
+ if ( $plan->directive eq 'SKIP' ) {
+ $tot{skipped}++;
+ }
+ }
+ );
+ }
+ );
- return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0;
-}
+ _aggregate( $harness, $aggregate, @{ $args{tests} } );
-# Returns all the files in a directory. This is shorthand for backwards
-# compatibility on systems where C<glob()> doesn't work right.
+ $tot{bench} = $aggregate->elapsed;
+ my @tests = $aggregate->descriptions;
-sub _globdir {
- local *DIRH;
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = scalar @tests;
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test (@tests) {
+ my ($parser) = $aggregate->parsers($test);
+
+ my @failed = $parser->failed;
+
+ my $wstat = $parser->wait;
+ my $estat = $parser->exit;
+ my $planned = $parser->tests_planned;
+ my @errors = $parser->parse_errors;
+ my $passed = $parser->passed;
+ my $actual_passed = $parser->actual_passed;
+
+ my $ok_seq = _check_sequence( $parser->actual_passed );
+
+ # Duplicate exit, wait status semantics of old version
+ $estat ||= '' unless $wstat;
+ $wstat ||= '';
+
+ $tot{max} += ( $planned || 0 );
+ $tot{bonus} += $parser->todo_passed;
+ $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
+ $tot{sub_skipped} += $parser->skipped;
+ $tot{todo} += $parser->todo;
+
+ if ( @failed || $estat || @errors ) {
+ $tot{bad}++;
+
+ my $huh_planned = $planned ? undef : '??';
+ my $huh_errors = $ok_seq ? undef : '??';
+
+ $failedtests{$test} = {
+ 'canon' => $huh_planned
+ || $huh_errors
+ || _canon(@failed)
+ || '??',
+ 'estat' => $estat,
+ 'failed' => $huh_planned
+ || $huh_errors
+ || scalar @failed,
+ 'max' => $huh_planned || $planned,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ else {
+ $tot{good}++;
+ }
- opendir DIRH, shift;
- my @f = readdir DIRH;
- closedir DIRH;
+ my @todo = $parser->todo_passed;
+ if (@todo) {
+ $todo_passed{$test} = {
+ 'canon' => _canon(@todo),
+ 'estat' => $estat,
+ 'failed' => scalar @todo,
+ 'max' => scalar $parser->todo,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ }
- return @f;
+ return ( \%tot, \%failedtests, \%todo_passed );
}
=head2 execute_tests( tests => \@test_files, out => \*FH )
@@ -316,624 +477,19 @@
=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<&runtests> is exported by C<Test::Harness> by default.
C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
exported upon request.
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
-
-If all tests are successful some statistics about the performance are
-printed.
-
-=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
-
-For any single script that has failing subtests statistics like the
-above are printed.
-
-=item C<Test returned status %d (wstat %d)>
-
-Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
-and C<$?> are printed in a message similar to the above.
+=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
-=item C<Failed 1 test, %.2f%% okay. %s>
-
-=item C<Failed %d/%d tests, %.2f%% okay. %s>
-
-If not all tests were successful, the script dies with one of the
-above messages.
-
-=item C<FAILED--Further testing stopped: %s>
-
-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.
+C<Test::Harness> sets these before executing the individual tests.
=over 4
@@ -944,7 +500,7 @@
=item C<HARNESS_VERSION>
-This is the version of Test::Harness.
+This is the version of C<Test::Harness>.
=back
@@ -952,61 +508,6 @@
=over 4
-=item C<HARNESS_COLUMNS>
-
-This value will be used for the width of the terminal. If it is not
-set then it will default to C<COLUMNS>. If this is not set, it will
-default to 80. Note that users of Bourne-sh based shells will need to
-C<export COLUMNS> for this module to use that variable.
-
-=item C<HARNESS_COMPILE_TEST>
-
-When true it will make harness attempt to compile the test using
-C<perlcc> before running it.
-
-B<NOTE> This currently only works when sitting in the perl source
-directory!
-
-=item C<HARNESS_DEBUG>
-
-If true, Test::Harness will print debugging information about itself as
-it runs the tests. This is different from C<HARNESS_VERBOSE>, 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<prove> utility.
-
-=item C<HARNESS_FILELEAK_IN_DIR>
-
-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<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
-
-=item C<HARNESS_NOTTY>
-
-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<HARNESS_PERL>
-
-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<prove> utility, you can use the C<--perl> switch.
-
-=item C<HARNESS_PERL_SWITCHES>
-
-Its value will be prepended to the switches used to invoke perl on
-each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
-run all tests with all warnings enabled.
-
=item C<HARNESS_TIMER>
Setting this to true will make the harness display the number of
@@ -1015,155 +516,72 @@
=item C<HARNESS_VERBOSE>
-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<prove> utility.
-
-If true, Test::Harness will output the verbose results of running
+If true, C<Test::Harness> will output the verbose results of running
its tests. Setting C<$Test::Harness::verbose> will override this,
or you can use the C<-v> switch in the F<prove> utility.
-=item C<HARNESS_STRAP_CLASS>
+=item C<HARNESS_OPTIONS>
-Defines the Test::Harness::Straps subclass to use. The value may either
-be a filename or a class name.
+Provide additional options to the harness. Currently supported options are:
-If HARNESS_STRAP_CLASS is a class name, the class must be in C<@INC>
-like any other class.
+=over
-If HARNESS_STRAP_CLASS is a filename, the .pm file must return the name
-of the class, instead of the canonical "1".
+=item C<< j<n> >>
-=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<prove> utility for running test scripts from the command line,
-L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
-the underlying timing routines, and L<Devel::Cover> 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.
+Run <n> (default 9) parallel jobs.
-Fix HARNESS_COMPILE_TEST without breaking its core usage.
+=item C<< f >>
-Figure a way to report test names in the failure summary.
+Use forked parallelism.
-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.
+=back
-Straps->analyze_file() not taint clean, don't know if it can be
+Multiple options may be separated by colons:
-Fix that damned VMS nit.
+ HARNESS_OPTIONS=j9:f make test
-Add a test for verbose.
+=back
-Change internal list of test results to a hash.
+=head1 Taint Mode
-Fix stats display when there's an overrun.
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
-Fix so perls with spaces in the filename work.
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> C<Test::Harness> (actually
+L<TAP::Parser::Source::Perl>) passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even in taint mode.
-Keeping whittling away at _run_all_tests()
+=head1 SEE ALSO
-Clean up how the summary is printed. Get rid of those damned formats.
+L<TAP::Harness>
=head1 BUGS
Please report any bugs or feature requests to
C<bug-test-harness at rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
-I will be notified, and then you'll automatically be notified of progress on
-your bug as I make changes.
-
-=head1 SUPPORT
-
-You can find documentation for this module with the F<perldoc> command.
-
- perldoc Test::Harness
-
-You can get docs for F<prove> with
-
- prove --man
-
-You can also look for information at:
-
-=over 4
-
-=item * AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/Test-Harness>
-
-=item * CPAN Ratings
-
-L<http://cpanratings.perl.org/d/Test-Harness>
-
-=item * RT: CPAN's request tracker
-
-L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Harness>
-
-=item * Search CPAN
-
-L<http://search.cpan.org/dist/Test-Harness>
-
-=back
-
-=head1 SOURCE CODE
-
-The source code repository for Test::Harness is at
-L<http://svn.perl.org/modules/Test-Harness>.
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
+notified, and then you'll automatically be notified of progress on your bug
+as I make changes.
=head1 AUTHORS
-Either Tim Bunce or Andreas Koenig, we don't know. What we know for
-sure is, that it was inspired by Larry Wall's F<TEST> script that came
-with perl distributions for ages. Numerous anonymous contributors
-exist. Andreas Koenig held the torch for many years, and then
-Michael G Schwern.
+Andy Armstrong C<< <andy@hexten.net> >>
-Current maintainer is Andy Lester C<< <andy at petdance.com> >>.
+L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
+module is based) has this attribution:
-=head1 COPYRIGHT
+ Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+ sure is, that it was inspired by Larry Wall's F<TEST> script that came
+ with perl distributions for ages. Numerous anonymous contributors
+ exist. Andreas Koenig held the torch for many years, and then
+ Michael G Schwern.
-Copyright 2002-2006
-by Michael G Schwern C<< <schwern at pobox.com> >>,
-Andy Lester C<< <andy at petdance.com> >>.
+=head1 LICENCE AND COPYRIGHT
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
-See L<http://www.perl.com/perl/misc/Artistic.html>.
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
-=cut
Reference in New Issue View Git Blame Copy Permalink