rpms/perl
7
0
Fork 0
Code Issues Pull Requests Releases Activity
4df0a8b86c
perl/perl-5.10.0-TestHarness3.12.patch
Marcela Mašláňová 325b0b7652 - 451078 update Test::Harness to 3.12 for more testing. Removed verbose 
test, new Test::Harness has possibly verbose output, but updated
    package has a lot of features f.e. TAP::Harness. Carefully watched all
    new bugs related to tests!
2008-07-02 14:02:55 +00:00

29417 lines
815 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.

diff -urN perl-5.10.0/t.ble/lib/App/Prove/Plugin/Dummy.pm perl-5.10.0/t/lib/App/Prove/Plugin/Dummy.pm
--- perl-5.10.0/t.ble/lib/App/Prove/Plugin/Dummy.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/App/Prove/Plugin/Dummy.pm 2008-06-18 01:26:47.000000000 +0200
@@ -0,0 +1,7 @@
+package App::Prove::Plugin::Dummy;
+
+sub import {
+ main::test_log_import(@_);
+}
+
+1;
diff -urN perl-5.10.0/t.ble/lib/compat/env.t perl-5.10.0/t/lib/compat/env.t
--- perl-5.10.0/t.ble/lib/compat/env.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/env.t 2008-06-18 01:26:17.000000000 +0200
@@ -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/t.ble/lib/compat/failure.t perl-5.10.0/t/lib/compat/failure.t
--- perl-5.10.0/t.ble/lib/compat/failure.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/failure.t 2008-06-18 01:26:12.000000000 +0200
@@ -0,0 +1,59 @@
+#!/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 $curdir = File::Spec->curdir;
+ my $sample_tests
+ = $ENV{PERL_CORE}
+ ? File::Spec->catdir( $curdir, 'lib', '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/t.ble/lib/compat/inc-propagation.t perl-5.10.0/t/lib/compat/inc-propagation.t
--- perl-5.10.0/t.ble/lib/compat/inc-propagation.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/inc-propagation.t 2008-06-22 03:29:51.000000000 +0200
@@ -0,0 +1,54 @@
+#!/usr/bin/perl -w
+
+# Test that @INC is propogated from the harness process to the test
+# process.
+
+use strict;
+use lib 't/lib';
+
+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;
+
+# Make sure we did something sensible with PERL5LIB
+like $ENV{PERL5LIB}, qr{wibble};
+ok grep { $_ eq 'wibble' } @INC;
+
+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/t.ble/lib/compat/inc_taint.t perl-5.10.0/t/lib/compat/inc_taint.t
--- perl-5.10.0/t.ble/lib/compat/inc_taint.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/inc_taint.t 2008-06-18 01:26:19.000000000 +0200
@@ -0,0 +1,45 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '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}
+ ? 'lib/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/t.ble/lib/compat/nonumbers.t perl-5.10.0/t/lib/compat/nonumbers.t
--- perl-5.10.0/t.ble/lib/compat/nonumbers.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/nonumbers.t 2008-06-18 01:26:46.000000000 +0200
@@ -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/t.ble/lib/compat/regression.t perl-5.10.0/t/lib/compat/regression.t
--- perl-5.10.0/t.ble/lib/compat/regression.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/regression.t 2008-06-18 01:27:21.000000000 +0200
@@ -0,0 +1,17 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 1;
+use Test::Harness;
+
+{
+
+ #28567
+ unshift @INC, 'wibble';
+ my @before = Test::Harness::_filtered_inc();
+ unshift @INC, sub {die};
+ my @after = Test::Harness::_filtered_inc();
+ is_deeply \@after, \@before, 'subref removed from @INC';
+}
diff -urN perl-5.10.0/t.ble/lib/compat/test-harness-compat.t perl-5.10.0/t/lib/compat/test-harness-compat.t
--- perl-5.10.0/t.ble/lib/compat/test-harness-compat.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/test-harness-compat.t 2008-06-22 03:19:58.000000000 +0200
@@ -0,0 +1,857 @@
+#!/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} ? 'lib/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/t.ble/lib/compat/version.t perl-5.10.0/t/lib/compat/version.t
--- perl-5.10.0/t.ble/lib/compat/version.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/compat/version.t 2008-06-18 01:27:04.000000000 +0200
@@ -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/t.ble/lib/data/catme.1 perl-5.10.0/t/lib/data/catme.1
--- perl-5.10.0/t.ble/lib/data/catme.1 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/data/catme.1 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,2 @@
+1..1
+ok 1
diff -urN perl-5.10.0/t.ble/lib/data/proverc perl-5.10.0/t/lib/data/proverc
--- perl-5.10.0/t.ble/lib/data/proverc 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/data/proverc 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/data/sample.yml perl-5.10.0/t/lib/data/sample.yml
--- perl-5.10.0/t.ble/lib/data/sample.yml 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/data/sample.yml 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/EmptyParser.pm perl-5.10.0/t/lib/EmptyParser.pm
--- perl-5.10.0/t.ble/lib/EmptyParser.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/EmptyParser.pm 2008-06-18 01:26:57.000000000 +0200
@@ -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/t.ble/lib/if.pm perl-5.10.0/t/lib/if.pm
--- perl-5.10.0/t.ble/lib/if.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/if.pm 2008-06-18 01:26:47.000000000 +0200
@@ -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/t.ble/lib/IO/c55Capture.pm perl-5.10.0/t/lib/IO/c55Capture.pm
--- perl-5.10.0/t.ble/lib/IO/c55Capture.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/IO/c55Capture.pm 2008-06-18 01:26:16.000000000 +0200
@@ -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/t.ble/lib/MyCustom.pm perl-5.10.0/t/lib/MyCustom.pm
--- perl-5.10.0/t.ble/lib/MyCustom.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MyCustom.pm 2008-06-18 01:27:08.000000000 +0200
@@ -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/t.ble/lib/MyGrammar.pm perl-5.10.0/t/lib/MyGrammar.pm
--- perl-5.10.0/t.ble/lib/MyGrammar.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MyGrammar.pm 2008-06-18 01:27:00.000000000 +0200
@@ -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/t.ble/lib/MyIteratorFactory.pm perl-5.10.0/t/lib/MyIteratorFactory.pm
--- perl-5.10.0/t.ble/lib/MyIteratorFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MyIteratorFactory.pm 2008-06-22 03:03:03.000000000 +0200
@@ -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/t.ble/lib/MyIterator.pm perl-5.10.0/t/lib/MyIterator.pm
--- perl-5.10.0/t.ble/lib/MyIterator.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MyIterator.pm 2008-06-18 01:27:19.000000000 +0200
@@ -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/t.ble/lib/MyPerlSource.pm perl-5.10.0/t/lib/MyPerlSource.pm
--- perl-5.10.0/t.ble/lib/MyPerlSource.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MyPerlSource.pm 2008-06-18 01:26:58.000000000 +0200
@@ -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/t.ble/lib/MyResultFactory.pm perl-5.10.0/t/lib/MyResultFactory.pm
--- perl-5.10.0/t.ble/lib/MyResultFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MyResultFactory.pm 2008-06-22 03:03:03.000000000 +0200
@@ -0,0 +1,22 @@
+# 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/t.ble/lib/MyResult.pm perl-5.10.0/t/lib/MyResult.pm
--- perl-5.10.0/t.ble/lib/MyResult.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MyResult.pm 2008-06-18 01:27:21.000000000 +0200
@@ -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/t.ble/lib/MySource.pm perl-5.10.0/t/lib/MySource.pm
--- perl-5.10.0/t.ble/lib/MySource.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/MySource.pm 2008-06-18 01:26:27.000000000 +0200
@@ -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/t.ble/lib/NoFork.pm perl-5.10.0/t/lib/NoFork.pm
--- perl-5.10.0/t.ble/lib/NoFork.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/NoFork.pm 2008-06-18 01:27:32.000000000 +0200
@@ -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/t.ble/lib/sample-tests/bailout perl-5.10.0/t/lib/sample-tests/bailout
--- perl-5.10.0/t.ble/lib/sample-tests/bailout 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/bailout 2008-06-09 02:41:01.000000000 +0200
@@ -1,3 +1,5 @@
+# Sleep makes Mac OS open3 race problem more repeatable
+sleep 1;
print <<DUMMY_TEST;
1..5
ok 1
diff -urN perl-5.10.0/t.ble/lib/sample-tests/combined perl-5.10.0/t/lib/sample-tests/combined
--- perl-5.10.0/t.ble/lib/sample-tests/combined 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/combined 2008-06-09 02:41:01.000000000 +0200
@@ -1,13 +1,13 @@
print <<DUMMY_TEST;
-1..10 todo 4 10
+1..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 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/t.ble/lib/sample-tests/combined_compat perl-5.10.0/t/lib/sample-tests/combined_compat
--- perl-5.10.0/t.ble/lib/sample-tests/combined_compat 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/combined_compat 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/delayed perl-5.10.0/t/lib/sample-tests/delayed
--- perl-5.10.0/t.ble/lib/sample-tests/delayed 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/delayed 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,33 @@
+# Used to test Process.pm
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ unshift @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/t.ble/lib/sample-tests/descriptive_trailing perl-5.10.0/t/lib/sample-tests/descriptive_trailing
--- perl-5.10.0/t.ble/lib/sample-tests/descriptive_trailing 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/descriptive_trailing 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/die perl-5.10.0/t/lib/sample-tests/die
--- perl-5.10.0/t.ble/lib/sample-tests/die 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/die 2008-06-09 02:41:01.000000000 +0200
@@ -1,2 +1,2 @@
-use if ($^O eq 'VMS'), vmsish => 'hushed';
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
exit 1; # exit because die() can be noisy
diff -urN perl-5.10.0/t.ble/lib/sample-tests/die_head_end perl-5.10.0/t/lib/sample-tests/die_head_end
--- perl-5.10.0/t.ble/lib/sample-tests/die_head_end 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/die_head_end 2008-06-09 02:41:01.000000000 +0200
@@ -5,5 +5,5 @@
ok 4
DUMMY_TEST
-use if $^O eq 'VMS', vmsish => 'hushed';
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
exit 1;
diff -urN perl-5.10.0/t.ble/lib/sample-tests/die_last_minute perl-5.10.0/t/lib/sample-tests/die_last_minute
--- perl-5.10.0/t.ble/lib/sample-tests/die_last_minute 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/die_last_minute 2008-06-09 02:41:01.000000000 +0200
@@ -6,5 +6,5 @@
1..4
DUMMY_TEST
-use if $^O eq 'VMS', vmsish => 'hushed';
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
exit 1;
diff -urN perl-5.10.0/t.ble/lib/sample-tests/die_unfinished perl-5.10.0/t/lib/sample-tests/die_unfinished
--- perl-5.10.0/t.ble/lib/sample-tests/die_unfinished 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/die_unfinished 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/echo perl-5.10.0/t/lib/sample-tests/echo
--- perl-5.10.0/t.ble/lib/sample-tests/echo 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/echo 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,2 @@
+print '1..', scalar(@ARGV), "\n";
+print "ok $_ ", $ARGV[ $_ - 1 ], "\n" for 1 .. @ARGV;
diff -urN perl-5.10.0/t.ble/lib/sample-tests/empty perl-5.10.0/t/lib/sample-tests/empty
--- perl-5.10.0/t.ble/lib/sample-tests/empty 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/empty 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,2 @@
+__END__
+Used to exercise the "empty test" case.
diff -urN perl-5.10.0/t.ble/lib/sample-tests/escape_eol perl-5.10.0/t/lib/sample-tests/escape_eol
--- perl-5.10.0/t.ble/lib/sample-tests/escape_eol 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/escape_eol 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/escape_hash perl-5.10.0/t/lib/sample-tests/escape_hash
--- perl-5.10.0/t.ble/lib/sample-tests/escape_hash 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/escape_hash 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/inc_taint perl-5.10.0/t/lib/sample-tests/inc_taint
--- perl-5.10.0/t.ble/lib/sample-tests/inc_taint 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/inc_taint 2008-06-09 02:41:01.000000000 +0200
@@ -1,7 +1,15 @@
#!/usr/bin/perl -Tw
-use lib qw(t/lib);
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ unshift @INC, '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
use Test::More tests => 1;
-ok( grep(/we_added_this_lib/, @INC) );
+ok( grep( /examples/, @INC ) );
diff -urN perl-5.10.0/t.ble/lib/sample-tests/junk_before_plan perl-5.10.0/t/lib/sample-tests/junk_before_plan
--- perl-5.10.0/t.ble/lib/sample-tests/junk_before_plan 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/junk_before_plan 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/out_err_mix perl-5.10.0/t/lib/sample-tests/out_err_mix
--- perl-5.10.0/t.ble/lib/sample-tests/out_err_mix 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/out_err_mix 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/schwern perl-5.10.0/t/lib/sample-tests/schwern
--- perl-5.10.0/t.ble/lib/sample-tests/schwern 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/schwern 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,3 @@
+use Test::More;
+plan tests => 1;
+ok 23, 42;
diff -urN perl-5.10.0/t.ble/lib/sample-tests/schwern-todo-quiet perl-5.10.0/t/lib/sample-tests/schwern-todo-quiet
--- perl-5.10.0/t.ble/lib/sample-tests/schwern-todo-quiet 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/schwern-todo-quiet 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/sequence_misparse perl-5.10.0/t/lib/sample-tests/sequence_misparse
--- perl-5.10.0/t.ble/lib/sample-tests/sequence_misparse 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/sequence_misparse 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/shbang_misparse perl-5.10.0/t/lib/sample-tests/shbang_misparse
--- perl-5.10.0/t.ble/lib/sample-tests/shbang_misparse 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/shbang_misparse 2008-06-09 02:41:01.000000000 +0200
@@ -8,5 +8,5 @@
print "ok 1\n";
my $warning = '';
$SIG{__WARN__} = sub { $warning .= $_[0] };
-eval("#" . substr($0, 0, 0));
+eval( "#" . substr( $0, 0, 0 ) );
print $warning ? "not ok 2\n" : "ok 2\n";
diff -urN perl-5.10.0/t.ble/lib/sample-tests/simple_yaml perl-5.10.0/t/lib/sample-tests/simple_yaml
--- perl-5.10.0/t.ble/lib/sample-tests/simple_yaml 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/simple_yaml 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/skipall perl-5.10.0/t/lib/sample-tests/skipall
--- perl-5.10.0/t.ble/lib/sample-tests/skipall 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/skipall 2008-06-09 02:41:01.000000000 +0200
@@ -1,3 +1,3 @@
print <<DUMMY_TEST;
-1..0 # skip: rope
+1..0 # skipping: rope
DUMMY_TEST
diff -urN perl-5.10.0/t.ble/lib/sample-tests/skipall_v13 perl-5.10.0/t/lib/sample-tests/skipall_v13
--- perl-5.10.0/t.ble/lib/sample-tests/skipall_v13 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/skipall_v13 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,4 @@
+print <<DUMMY_TEST;
+TAP version 13
+1..0 # skipping: rope
+DUMMY_TEST
diff -urN perl-5.10.0/t.ble/lib/sample-tests/space_after_plan perl-5.10.0/t/lib/sample-tests/space_after_plan
--- perl-5.10.0/t.ble/lib/sample-tests/space_after_plan 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/space_after_plan 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/stdout_stderr perl-5.10.0/t/lib/sample-tests/stdout_stderr
--- perl-5.10.0/t.ble/lib/sample-tests/stdout_stderr 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/stdout_stderr 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,14 @@
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ unshift @INC, '../lib';
+ }
+}
+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/t.ble/lib/sample-tests/strict perl-5.10.0/t/lib/sample-tests/strict
--- perl-5.10.0/t.ble/lib/sample-tests/strict 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/strict 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/taint perl-5.10.0/t/lib/sample-tests/taint
--- perl-5.10.0/t.ble/lib/sample-tests/taint 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/taint 2008-06-09 02:41:01.000000000 +0200
@@ -4,4 +4,4 @@
use Test::More tests => 1;
eval { kill 0, $^X };
-like( $@, '/^Insecure dependency/', '-T honored' );
+like( $@, '/^Insecure dependency/', '-T honored' );
diff -urN perl-5.10.0/t.ble/lib/sample-tests/taint_warn perl-5.10.0/t/lib/sample-tests/taint_warn
--- perl-5.10.0/t.ble/lib/sample-tests/taint_warn 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/taint_warn 2008-06-09 02:41:01.000000000 +0200
@@ -8,4 +8,4 @@
local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
kill 0, $^X;
}
-like( $warnings, '/^Insecure dependency/', '-t honored' );
+like( $warnings, '/^Insecure dependency/', '-t honored' );
diff -urN perl-5.10.0/t.ble/lib/sample-tests/todo perl-5.10.0/t/lib/sample-tests/todo
--- perl-5.10.0/t.ble/lib/sample-tests/todo 2007-12-18 11:47:08.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/todo 2008-06-09 02:41:01.000000000 +0200
@@ -1,5 +1,5 @@
print <<DUMMY_TEST;
-1..5 todo 3 2;
+1..5 todo 3 2;
ok 1
ok 2
not ok 3
diff -urN perl-5.10.0/t.ble/lib/sample-tests/todo_misparse perl-5.10.0/t/lib/sample-tests/todo_misparse
--- perl-5.10.0/t.ble/lib/sample-tests/todo_misparse 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/todo_misparse 2008-06-09 02:41:01.000000000 +0200
@@ -0,0 +1,5 @@
+print <<'END';
+1..1
+not ok 1 Hamlette # TODOORNOTTODO
+END
+
diff -urN perl-5.10.0/t.ble/lib/sample-tests/version_good perl-5.10.0/t/lib/sample-tests/version_good
--- perl-5.10.0/t.ble/lib/sample-tests/version_good 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/version_good 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/version_late perl-5.10.0/t/lib/sample-tests/version_late
--- perl-5.10.0/t.ble/lib/sample-tests/version_late 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/version_late 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/sample-tests/version_old perl-5.10.0/t/lib/sample-tests/version_old
--- perl-5.10.0/t.ble/lib/sample-tests/version_old 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/sample-tests/version_old 2008-06-09 02:41:01.000000000 +0200
@@ -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/t.ble/lib/source_tests/harness perl-5.10.0/t/lib/source_tests/harness
--- perl-5.10.0/t.ble/lib/source_tests/harness 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/source_tests/harness 2008-06-09 02:41:00.000000000 +0200
@@ -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/t.ble/lib/source_tests/harness_badtap perl-5.10.0/t/lib/source_tests/harness_badtap
--- perl-5.10.0/t.ble/lib/source_tests/harness_badtap 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/source_tests/harness_badtap 2008-06-09 02:41:00.000000000 +0200
@@ -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/t.ble/lib/source_tests/harness_complain perl-5.10.0/t/lib/source_tests/harness_complain
--- perl-5.10.0/t.ble/lib/source_tests/harness_complain 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/source_tests/harness_complain 2008-06-09 02:41:00.000000000 +0200
@@ -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/t.ble/lib/source_tests/harness_directives perl-5.10.0/t/lib/source_tests/harness_directives
--- perl-5.10.0/t.ble/lib/source_tests/harness_directives 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/source_tests/harness_directives 2008-06-09 02:41:00.000000000 +0200
@@ -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/t.ble/lib/source_tests/harness_failure perl-5.10.0/t/lib/source_tests/harness_failure
--- perl-5.10.0/t.ble/lib/source_tests/harness_failure 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/source_tests/harness_failure 2008-06-09 02:41:00.000000000 +0200
@@ -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/t.ble/lib/source_tests/source perl-5.10.0/t/lib/source_tests/source
--- perl-5.10.0/t.ble/lib/source_tests/source 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/source_tests/source 2008-06-09 02:41:00.000000000 +0200
@@ -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/t.ble/lib/subclass_tests/non_perl_source perl-5.10.0/t/lib/subclass_tests/non_perl_source
--- perl-5.10.0/t.ble/lib/subclass_tests/non_perl_source 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/subclass_tests/non_perl_source 2008-06-10 00:31:18.000000000 +0200
@@ -0,0 +1,3 @@
+#!/bin/sh
+echo "1..1"
+echo "ok 1 - this is a test"
diff -urN perl-5.10.0/t.ble/lib/subclass_tests/perl_source perl-5.10.0/t/lib/subclass_tests/perl_source
--- perl-5.10.0/t.ble/lib/subclass_tests/perl_source 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/subclass_tests/perl_source 2008-06-10 00:31:18.000000000 +0200
@@ -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/t.ble/lib/TAP/Parser/SubclassTest.pm perl-5.10.0/t/lib/TAP/Parser/SubclassTest.pm
--- perl-5.10.0/t.ble/lib/TAP/Parser/SubclassTest.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/TAP/Parser/SubclassTest.pm 2008-06-18 01:26:56.000000000 +0200
@@ -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/t.ble/lib/Test/Builder/Module.pm perl-5.10.0/t/lib/Test/Builder/Module.pm
--- perl-5.10.0/t.ble/lib/Test/Builder/Module.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/Test/Builder/Module.pm 2008-06-18 01:26:53.000000000 +0200
@@ -0,0 +1,177 @@
+package Test::Builder::Module;
+
+use Test::Builder;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = '0.72';
+
+use strict;
+
+# 5.004's Exporter doesn't have export_to_level.
+my $_export_to_level = sub {
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # redundant arg
+ my $callpkg = caller($level);
+ $pkg->export( $callpkg, @_ );
+};
+
+=head1 NAME
+
+Test::Builder::Module - Base class for test modules
+
+=head1 SYNOPSIS
+
+ # Emulates Test::Simple
+ package Your::Module;
+
+ my $CLASS = __PACKAGE__;
+
+ use base 'Test::Builder::Module';
+ @EXPORT = qw(ok);
+
+ sub ok ($;$) {
+ my $tb = $CLASS->builder;
+ return $tb->ok(@_);
+ }
+
+ 1;
+
+
+=head1 DESCRIPTION
+
+This is a superclass for Test::Builder-based modules. It provides a
+handful of common functionality and a method of getting at the underlying
+Test::Builder object.
+
+
+=head2 Importing
+
+Test::Builder::Module is a subclass of Exporter which means your
+module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
+all act normally.
+
+A few methods are provided to do the C<use Your::Module tests => 23> part
+for you.
+
+=head3 import
+
+Test::Builder::Module provides an import() method which acts in the
+same basic way as Test::More's, setting the plan and controling
+exporting of functions and variables. This allows your module to set
+the plan independent of Test::More.
+
+All arguments passed to import() are passed onto
+C<< Your::Module->builder->plan() >> with the exception of
+C<import =>[qw(things to import)]>.
+
+ use Your::Module import => [qw(this that)], tests => 23;
+
+says to import the functions this() and that() as well as set the plan
+to be 23 tests.
+
+import() also sets the exported_to() attribute of your builder to be
+the caller of the import() function.
+
+Additional behaviors can be added to your import() method by overriding
+import_extra().
+
+=cut
+
+sub import {
+ my ($class) = shift;
+
+ my $test = $class->builder;
+
+ my $caller = caller;
+
+ $test->exported_to($caller);
+
+ $class->import_extra( \@_ );
+ my (@imports) = $class->_strip_imports( \@_ );
+
+ $test->plan(@_);
+
+ $class->$_export_to_level( 1, $class, @imports );
+}
+
+sub _strip_imports {
+ my $class = shift;
+ my $list = shift;
+
+ my @imports = ();
+ my @other = ();
+ my $idx = 0;
+ while ( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if ( defined $item and $item eq 'import' ) {
+ push @imports, @{ $list->[ $idx + 1 ] };
+ $idx++;
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return @imports;
+}
+
+=head3 import_extra
+
+ Your::Module->import_extra(\@import_args);
+
+import_extra() is called by import(). It provides an opportunity for you
+to add behaviors to your module based on its import list.
+
+Any extra arguments which shouldn't be passed on to plan() should be
+stripped off by this method.
+
+See Test::More for an example of its use.
+
+B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
+feels like a bit of an ugly hack in its current form.
+
+=cut
+
+sub import_extra { }
+
+=head2 Builder
+
+Test::Builder::Module provides some methods of getting at the underlying
+Test::Builder object.
+
+=head3 builder
+
+ my $builder = Your::Class->builder;
+
+This method returns the Test::Builder object associated with Your::Class.
+It is not a constructor so you can call it as often as you like.
+
+This is the preferred way to get the Test::Builder object. You should
+I<not> get it via C<< Test::Builder->new >> as was previously
+recommended.
+
+The object returned by builder() may change at runtime so you should
+call builder() inside each function rather than store it in a global.
+
+ sub ok {
+ my $builder = Your::Class->builder;
+
+ return $builder->ok(@_);
+ }
+
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
+
+1;
diff -urN perl-5.10.0/t.ble/lib/Test/Builder.pm perl-5.10.0/t/lib/Test/Builder.pm
--- perl-5.10.0/t.ble/lib/Test/Builder.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/Test/Builder.pm 2008-06-18 01:27:12.000000000 +0200
@@ -0,0 +1,1850 @@
+package Test::Builder;
+
+use 5.004;
+
+# $^C was only introduced in 5.005-ish. We do this to prevent
+# use of uninitialized value warnings in older perls.
+$^C ||= 0;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.72';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+# Make Test::Builder thread-safe for ithreads.
+BEGIN {
+ use Config;
+
+ # Load threads::shared when threads are turned on.
+ # 5.8.0's threads are so busted we no longer support them.
+ if ( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
+ require threads::shared;
+
+ # Hack around YET ANOTHER threads::shared bug. It would
+ # occassionally forget the contents of the variable when sharing it.
+ # So we first copy the data, then share, then put our copy back.
+ *share = sub (\[$@%]) {
+ my $type = ref $_[0];
+ my $data;
+
+ if ( $type eq 'HASH' ) {
+ %$data = %{ $_[0] };
+ }
+ elsif ( $type eq 'ARRAY' ) {
+ @$data = @{ $_[0] };
+ }
+ elsif ( $type eq 'SCALAR' ) {
+ $$data = ${ $_[0] };
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ $_[0] = &threads::shared::share( $_[0] );
+
+ if ( $type eq 'HASH' ) {
+ %{ $_[0] } = %$data;
+ }
+ elsif ( $type eq 'ARRAY' ) {
+ @{ $_[0] } = @$data;
+ }
+ elsif ( $type eq 'SCALAR' ) {
+ ${ $_[0] } = $$data;
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ return $_[0];
+ };
+ }
+
+ # 5.8.0's threads::shared is busted when threads are off
+ # and earlier Perls just don't have that module at all.
+ else {
+ *share = sub { return $_[0] };
+ *lock = sub {0};
+ }
+}
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use Test::Builder;
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(ok);
+
+ my $Test = Test::Builder->new;
+ $Test->output('my_logfile');
+
+ sub import {
+ my($self) = shift;
+ my $pack = caller;
+
+ $Test->exported_to($pack);
+ $Test->plan(@_);
+
+ $self->export_to_level(1, $self, 'ok');
+ }
+
+ sub ok {
+ my($test, $name) = @_;
+
+ $Test->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+Test::Simple and Test::More have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program C<new> always returns the same
+Test::Builder object. No matter how many times you call new(), you're
+getting the same object. This is called a singleton. This is done so that
+multiple modules share such global information as the test counter and
+where test output is going.
+
+If you want a completely new Test::Builder object different from the
+singleton, use C<create>.
+
+=cut
+
+my $Test = Test::Builder->new;
+
+sub new {
+ my ($class) = shift;
+ $Test ||= $class->create;
+ return $Test;
+}
+
+=item B<create>
+
+ my $Test = Test::Builder->create;
+
+Ok, so there can be more than one Test::Builder object and this is how
+you get it. You might use this instead of C<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is
+still shared amongst B<all> Test::Builder objects, even ones created using
+this method. Also, the method name may change in the future.
+
+=cut
+
+sub create {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+ $self->reset;
+
+ return $self;
+}
+
+=item B<reset>
+
+ $Test->reset;
+
+Reinitializes the Test::Builder singleton to its original state.
+Mostly useful for tests run in persistent environments where the same
+test might be run multiple times in the same process.
+
+=cut
+
+use vars qw($Level);
+
+sub reset {
+ my ($self) = @_;
+
+ # We leave this a global because it has to be localized and localizing
+ # hash keys is just asking for pain. Also, it was documented.
+ $Level = 1;
+
+ $self->{Test_Died} = 0;
+ $self->{Have_Plan} = 0;
+ $self->{No_Plan} = 0;
+ $self->{Original_Pid} = $$;
+
+ share( $self->{Curr_Test} );
+ $self->{Curr_Test} = 0;
+ $self->{Test_Results} = &share( [] );
+
+ $self->{Exported_To} = undef;
+ $self->{Expected_Tests} = 0;
+
+ $self->{Skip_All} = 0;
+
+ $self->{Use_Nums} = 1;
+
+ $self->{No_Header} = 0;
+ $self->{No_Ending} = 0;
+
+ $self->_dup_stdhandles unless $^C;
+
+ return undef;
+}
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+This is important for getting TODO tests right.
+
+=cut
+
+sub exported_to {
+ my ( $self, $pack ) = @_;
+
+ if ( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call plan(), don't call any of the other methods below.
+
+=cut
+
+sub plan {
+ my ( $self, $cmd, $arg ) = @_;
+
+ return unless $cmd;
+
+ local $Level = $Level + 1;
+
+ if ( $self->{Have_Plan} ) {
+ $self->croak("You tried to plan twice");
+ }
+
+ if ( $cmd eq 'no_plan' ) {
+ $self->no_plan;
+ }
+ elsif ( $cmd eq 'skip_all' ) {
+ return $self->skip_all($arg);
+ }
+ elsif ( $cmd eq 'tests' ) {
+ if ($arg) {
+ local $Level = $Level + 1;
+ return $self->expected_tests($arg);
+ }
+ elsif ( !defined $arg ) {
+ $self->croak("Got an undefined number of tests");
+ }
+ elsif ( !$arg ) {
+ $self->croak("You said to run 0 tests");
+ }
+ }
+ else {
+ my @args = grep {defined} ( $cmd, $arg );
+ $self->croak("plan() doesn't understand @args");
+ }
+
+ return 1;
+}
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the # of tests we expect this test to run and prints out
+the appropriate headers.
+
+=cut
+
+sub expected_tests {
+ my $self = shift;
+ my ($max) = @_;
+
+ if (@_) {
+ $self->croak(
+ "Number of tests must be a positive integer. You gave it '$max'")
+ unless $max =~ /^\+?\d+$/ and $max > 0;
+
+ $self->{Expected_Tests} = $max;
+ $self->{Have_Plan} = 1;
+
+ $self->_print("1..$max\n") unless $self->no_header;
+ }
+ return $self->{Expected_Tests};
+}
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate # of tests.
+
+=cut
+
+sub no_plan {
+ my $self = shift;
+
+ $self->{No_Plan} = 1;
+ $self->{Have_Plan} = 1;
+}
+
+=item B<has_plan>
+
+ $plan = $Test->has_plan
+
+Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
+
+=cut
+
+sub has_plan {
+ my $self = shift;
+
+ return ( $self->{Expected_Tests} ) if $self->{Expected_Tests};
+ return ('no_plan') if $self->{No_Plan};
+ return (undef);
+}
+
+=item B<skip_all>
+
+ $Test->skip_all;
+ $Test->skip_all($reason);
+
+Skips all the tests, using the given $reason. Exits immediately with 0.
+
+=cut
+
+sub skip_all {
+ my ( $self, $reason ) = @_;
+
+ my $out = "1..0";
+ $out .= " # Skip $reason" if $reason;
+ $out .= "\n";
+
+ $self->{Skip_All} = 1;
+
+ $self->_print($out) unless $self->no_header;
+ exit(0);
+}
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in Test::More.
+
+They all return true if the test passed, false if the test failed.
+
+$name is always optional.
+
+=over 4
+
+=item B<ok>
+
+ $Test->ok($test, $name);
+
+Your basic test. Pass if $test is true, fail if $test is false. Just
+like Test::Simple's ok().
+
+=cut
+
+sub ok {
+ my ( $self, $test, $name ) = @_;
+
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ $self->_plan_check;
+
+ lock $self->{Curr_Test};
+ $self->{Curr_Test}++;
+
+ # In case $name is a string overloaded object, force it to stringify.
+ $self->_unoverload_str( \$name );
+
+ $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ERR
+
+ my ( $pack, $file, $line ) = $self->caller;
+
+ my $todo = $self->todo($pack);
+ $self->_unoverload_str( \$todo );
+
+ my $out;
+ my $result = &share( {} );
+
+ unless ($test) {
+ $out .= "not ";
+ @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ $out .= "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+
+ if ( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $out .= " - $name";
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if ($todo) {
+ $out .= " # TODO $todo";
+ $result->{reason} = $todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ unless ($test) {
+ my $msg = $todo ? "Failed (TODO)" : "Failed";
+ $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
+
+ if ( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
+ }
+ }
+
+ return $test ? 1 : 0;
+}
+
+sub _unoverload {
+ my $self = shift;
+ my $type = shift;
+
+ $self->_try( sub { require overload } ) || return;
+
+ foreach my $thing (@_) {
+ if ( $self->_is_object($$thing) ) {
+ if ( my $string_meth = overload::Method( $$thing, $type ) ) {
+ $$thing = $$thing->$string_meth();
+ }
+ }
+ }
+}
+
+sub _is_object {
+ my ( $self, $thing ) = @_;
+
+ return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } )
+ ? 1
+ : 0;
+}
+
+sub _unoverload_str {
+ my $self = shift;
+
+ $self->_unoverload( q[""], @_ );
+}
+
+sub _unoverload_num {
+ my $self = shift;
+
+ $self->_unoverload( '0+', @_ );
+
+ for my $val (@_) {
+ next unless $self->_is_dualvar($$val);
+ $$val = $$val + 0;
+ }
+}
+
+# This is a hack to detect a dualvar such as $!
+sub _is_dualvar {
+ my ( $self, $val ) = @_;
+
+ local $^W = 0;
+ my $numval = $val + 0;
+ return 1 if $numval != 0 and $numval ne $val;
+}
+
+=item B<is_eq>
+
+ $Test->is_eq($got, $expected, $name);
+
+Like Test::More's is(). Checks if $got eq $expected. This is the
+string version.
+
+=item B<is_num>
+
+ $Test->is_num($got, $expected, $name);
+
+Like Test::More's is(). Checks if $got == $expected. This is the
+numeric version.
+
+=cut
+
+sub is_eq {
+ my ( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_str( \$got, \$expect );
+
+ if ( !defined $got || !defined $expect ) {
+
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, 'eq', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'eq', $expect, $name );
+}
+
+sub is_num {
+ my ( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_num( \$got, \$expect );
+
+ if ( !defined $got || !defined $expect ) {
+
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, '==', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '==', $expect, $name );
+}
+
+sub _is_diag {
+ my ( $self, $got, $type, $expect ) = @_;
+
+ foreach my $val ( \$got, \$expect ) {
+ if ( defined $$val ) {
+ if ( $type eq 'eq' ) {
+
+ # quote and force string context
+ $$val = "'$$val'";
+ }
+ else {
+
+ # force numeric context
+ $self->_unoverload_num($val);
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+ }
+
+ return $self->diag( sprintf <<DIAGNOSTIC, $got, $expect );
+ got: %s
+ expected: %s
+DIAGNOSTIC
+
+}
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->isnt_num($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+ my ( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if ( !defined $got || !defined $dont_expect ) {
+
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_cmp_diag( $got, 'ne', $dont_expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
+}
+
+sub isnt_num {
+ my ( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if ( !defined $got || !defined $dont_expect ) {
+
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_cmp_diag( $got, '!=', $dont_expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '!=', $dont_expect, $name );
+}
+
+=item B<like>
+
+ $Test->like($this, qr/$regex/, $name);
+ $Test->like($this, '/$regex/', $name);
+
+Like Test::More's like(). Checks if $this matches the given $regex.
+
+You'll want to avoid qr// if you want your tests to work before 5.005.
+
+=item B<unlike>
+
+ $Test->unlike($this, qr/$regex/, $name);
+ $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's unlike(). Checks if $this B<does not match> the
+given $regex.
+
+=cut
+
+sub like {
+ my ( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ $self->_regex_ok( $this, $regex, '=~', $name );
+}
+
+sub unlike {
+ my ( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ $self->_regex_ok( $this, $regex, '!~', $name );
+}
+
+=item B<cmp_ok>
+
+ $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's cmp_ok().
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+my %numeric_cmps
+ = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+
+sub cmp_ok {
+ my ( $self, $got, $type, $expect, $name ) = @_;
+
+ # Treat overloaded objects as numbers if we're asked to do a
+ # numeric comparison.
+ my $unoverload
+ = $numeric_cmps{$type}
+ ? '_unoverload_num'
+ : '_unoverload_str';
+
+ $self->$unoverload( \$got, \$expect );
+
+ my $test;
+ {
+ local ( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ my $code = $self->_caller_context;
+
+ # Yes, it has to look like this or 5.4.5 won't see the #line directive.
+ # Don't ask me, man, I just work here.
+ $test = eval "
+$code" . "\$got $type \$expect;";
+
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok( $test, $name );
+
+ unless ($ok) {
+ if ( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag( $got, $type, $expect );
+ }
+ else {
+ $self->_cmp_diag( $got, $type, $expect );
+ }
+ }
+ return $ok;
+}
+
+sub _cmp_diag {
+ my ( $self, $got, $type, $expect ) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+ return $self->diag( sprintf <<DIAGNOSTIC, $got, $type, $expect );
+ %s
+ %s
+ %s
+DIAGNOSTIC
+}
+
+sub _caller_context {
+ my $self = shift;
+
+ my ( $pack, $file, $line ) = $self->caller(1);
+
+ my $code = '';
+ $code .= "#line $line $file\n" if defined $file and defined $line;
+
+ return $code;
+}
+
+=back
+
+
+=head2 Other Testing Methods
+
+These are methods which are used in the course of writing a test but are not themselves tests.
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ $Test->BAIL_OUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAIL_OUT {
+ my ( $self, $reason ) = @_;
+
+ $self->{Bailed_Out} = 1;
+ $self->_print("Bail out! $reason");
+ exit 255;
+}
+
+=for deprecated
+BAIL_OUT() used to be BAILOUT()
+
+=cut
+
+*BAILOUT = \&BAIL_OUT;
+
+=item B<skip>
+
+ $Test->skip;
+ $Test->skip($why);
+
+Skips the current test, reporting $why.
+
+=cut
+
+sub skip {
+ my ( $self, $why ) = @_;
+ $why ||= '';
+ $self->_unoverload_str( \$why );
+
+ $self->_plan_check;
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ { 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # skip";
+ $out .= " $why" if length $why;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like skip(), only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+ my ( $self, $why ) = @_;
+ $why ||= '';
+
+ $self->_plan_check;
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ { 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "not ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # TODO & SKIP $why\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
+
+Like skip(), only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under no_plan, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
+
+=head2 Test building utility methods
+
+These methods are useful when writing your own test methods.
+
+=over 4
+
+=item B<maybe_regex>
+
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
+
+Convenience method for building testing functions that take regular
+expressions as arguments, but need to work before perl 5.005.
+
+Takes a quoted regular expression produced by qr//, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or undef if it's argument is not recognised.
+
+For example, a version of like(), sans the useful diagnostic messages,
+could be written as:
+
+ sub laconic_like {
+ my ($self, $this, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($this =~ m/$usable_regex/, $name);
+ }
+
+=cut
+
+sub maybe_regex {
+ my ( $self, $regex ) = @_;
+ my $usable_regex = undef;
+
+ return $usable_regex unless defined $regex;
+
+ my ( $re, $opts );
+
+ # Check for qr/foo/
+ if ( ref $regex eq 'Regexp' ) {
+ $usable_regex = $regex;
+ }
+
+ # Check for '/foo/' or 'm,foo,'
+ elsif (( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx
+ or ( undef, $re, $opts )
+ = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx )
+ {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ }
+
+ return $usable_regex;
+}
+
+sub _regex_ok {
+ my ( $self, $this, $regex, $cmp, $name ) = @_;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless ( defined $usable_regex ) {
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ my $test;
+ my $code = $self->_caller_context;
+
+ local ( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ # Yes, it has to look like this or 5.4.5 won't see the #line directive.
+ # Don't ask me, man, I just work here.
+ $test = eval "
+$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+
+ $test = !$test if $cmp eq '!~';
+
+ local $Level = $Level + 1;
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless ($ok) {
+ $this = defined $this ? "'$this'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+ $self->diag( sprintf <<DIAGNOSTIC, $this, $match, $regex );
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+# I'm not ready to publish this. It doesn't deal with array return
+# values from the code or context.
+
+=begin private
+
+=item B<_try>
+
+ my $return_from_code = $Test->try(sub { code });
+ my($return_from_code, $error) = $Test->try(sub { code });
+
+Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls.
+
+$error is what would normally be in $@.
+
+It is suggested you use this in place of eval BLOCK.
+
+=cut
+
+sub _try {
+ my ( $self, $code ) = @_;
+
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ my $return = eval { $code->() };
+
+ return wantarray ? ( $return, $@ ) : $return;
+}
+
+=end private
+
+
+=item B<is_fh>
+
+ my $is_fh = $Test->is_fh($thing);
+
+Determines if the given $thing can be used as a filehandle.
+
+=cut
+
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
+
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return eval { $maybe_fh->isa("IO::Handle") } ||
+
+ # 5.5.4's tied() and can() doesn't like getting undef
+ eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
+}
+
+=back
+
+
+=head2 Test style
+
+
+=over 4
+
+=item B<level>
+
+ $Test->level($how_high);
+
+How far up the call stack should $Test look when reporting where the
+test failed.
+
+Defaults to 1.
+
+Setting L<$Test::Builder::Level> overrides. This is typically useful
+localized:
+
+ sub my_ok {
+ my $test = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $TB->ok($test);
+ }
+
+To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
+
+=cut
+
+sub level {
+ my ( $self, $level ) = @_;
+
+ if ( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+=item B<use_numbers>
+
+ $Test->use_numbers($on_or_off);
+
+Whether or not the test should output numbers. That is, this if true:
+
+ ok 1
+ ok 2
+ ok 3
+
+or this if false
+
+ ok
+ ok
+ ok
+
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
+
+Defaults to on.
+
+=cut
+
+sub use_numbers {
+ my ( $self, $use_nums ) = @_;
+
+ if ( defined $use_nums ) {
+ $self->{Use_Nums} = $use_nums;
+ }
+ return $self->{Use_Nums};
+}
+
+=item B<no_diag>
+
+ $Test->no_diag($no_diag);
+
+If set true no diagnostics will be printed. This includes calls to
+diag().
+
+=item B<no_ending>
+
+ $Test->no_ending($no_ending);
+
+Normally, Test::Builder does some extra diagnostics when the test
+ends. It also changes the exit code as described below.
+
+If this is true, none of that will be done.
+
+=item B<no_header>
+
+ $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
+=cut
+
+foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
+ my $method = lc $attribute;
+
+ my $code = sub {
+ my ( $self, $no ) = @_;
+
+ if ( defined $no ) {
+ $self->{$attribute} = $no;
+ }
+ return $self->{$attribute};
+ };
+
+ no strict 'refs';
+ *{ __PACKAGE__ . '::' . $method } = $code;
+}
+
+=back
+
+=head2 Output
+
+Controlling where the test output goes.
+
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
+
+=over 4
+
+=item B<diag>
+
+ $Test->diag(@msgs);
+
+Prints out the given @msgs. Like C<print>, arguments are simply
+appended together.
+
+Normally, it uses the failure_output() handle, but if this is for a
+TODO test, the todo_output() handle is used.
+
+Output will be indented and marked with a # so as not to interfere
+with test output. A newline will be put on the end if there isn't one
+already.
+
+We encourage using this rather than calling print directly.
+
+Returns false. Why? Because diag() is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+ return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+
+=cut
+
+sub diag {
+ my ( $self, @msgs ) = @_;
+
+ return if $self->no_diag;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Smash args together like print does.
+ # Convert undef to 'undef' so its readable.
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
+
+ # Escape each line with a #.
+ $msg =~ s/^/# /gm;
+
+ # Stick a newline on the end if it needs it.
+ $msg .= "\n" unless $msg =~ /\n\Z/;
+
+ local $Level = $Level + 1;
+ $self->_print_diag($msg);
+
+ return 0;
+}
+
+=begin _private
+
+=item B<_print>
+
+ $Test->_print(@msgs);
+
+Prints to the output() filehandle.
+
+=end _private
+
+=cut
+
+sub _print {
+ my ( $self, @msgs ) = @_;
+
+ # Prevent printing headers when only compiling. Mostly for when
+ # tests are deparsed with B::Deparse
+ return if $^C;
+
+ my $msg = join '', @msgs;
+
+ local ( $\, $", $, ) = ( undef, ' ', '' );
+ my $fh = $self->output;
+
+ # Escape each line after the first with a # so we don't
+ # confuse Test::Harness.
+ $msg =~ s/\n(.)/\n# $1/sg;
+
+ # Stick a newline on the end if it needs it.
+ $msg .= "\n" unless $msg =~ /\n\Z/;
+
+ print $fh $msg;
+}
+
+=begin private
+
+=item B<_print_diag>
+
+ $Test->_print_diag(@msg);
+
+Like _print, but prints to the current diagnostic filehandle.
+
+=end private
+
+=cut
+
+sub _print_diag {
+ my $self = shift;
+
+ local ( $\, $", $, ) = ( undef, ' ', '' );
+ my $fh = $self->todo ? $self->todo_output : $self->failure_output;
+ print $fh @_;
+}
+
+=item B<output>
+
+ $Test->output($fh);
+ $Test->output($file);
+
+Where normal "ok/not ok" test output should go.
+
+Defaults to STDOUT.
+
+=item B<failure_output>
+
+ $Test->failure_output($fh);
+ $Test->failure_output($file);
+
+Where diagnostic output on test failures and diag() should go.
+
+Defaults to STDERR.
+
+=item B<todo_output>
+
+ $Test->todo_output($fh);
+ $Test->todo_output($file);
+
+Where diagnostics about todo test failures and diag() should go.
+
+Defaults to STDOUT.
+
+=cut
+
+sub output {
+ my ( $self, $fh ) = @_;
+
+ if ( defined $fh ) {
+ $self->{Out_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Out_FH};
+}
+
+sub failure_output {
+ my ( $self, $fh ) = @_;
+
+ if ( defined $fh ) {
+ $self->{Fail_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Fail_FH};
+}
+
+sub todo_output {
+ my ( $self, $fh ) = @_;
+
+ if ( defined $fh ) {
+ $self->{Todo_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Todo_FH};
+}
+
+sub _new_fh {
+ my $self = shift;
+ my ($file_or_fh) = shift;
+
+ my $fh;
+ if ( $self->is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ else {
+ $fh = do { local *FH };
+ open $fh, ">$file_or_fh"
+ or $self->croak("Can't open test output log $file_or_fh: $!");
+ _autoflush($fh);
+ }
+
+ return $fh;
+}
+
+sub _autoflush {
+ my ($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+}
+
+sub _dup_stdhandles {
+ my $self = shift;
+
+ $self->_open_testhandles;
+
+ # Set everything to unbuffered else plain prints to STDOUT will
+ # come out in the wrong order from our own prints.
+ _autoflush( \*TESTOUT );
+ _autoflush( \*STDOUT );
+ _autoflush( \*TESTERR );
+ _autoflush( \*STDERR );
+
+ $self->output( \*TESTOUT );
+ $self->failure_output( \*TESTERR );
+ $self->todo_output( \*TESTOUT );
+}
+
+my $Opened_Testhandles = 0;
+
+sub _open_testhandles {
+ return if $Opened_Testhandles;
+
+ # We dup STDOUT and STDERR so people can change them in their
+ # test suites while still getting normal test output.
+ open( TESTOUT, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
+ open( TESTERR, ">&STDERR" ) or die "Can't dup STDERR: $!";
+ $Opened_Testhandles = 1;
+}
+
+=item carp
+
+ $tb->carp(@message);
+
+Warns with C<@message> but the message will appear to come from the
+point where the original test function was called (C<$tb->caller>).
+
+=item croak
+
+ $tb->croak(@message);
+
+Dies with C<@message> but the message will appear to come from the
+point where the original test function was called (C<$tb->caller>).
+
+=cut
+
+sub _message_at_caller {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ my ( $pack, $file, $line ) = $self->caller;
+ return join( "", @_ ) . " at $file line $line.\n";
+}
+
+sub carp {
+ my $self = shift;
+ warn $self->_message_at_caller(@_);
+}
+
+sub croak {
+ my $self = shift;
+ die $self->_message_at_caller(@_);
+}
+
+sub _plan_check {
+ my $self = shift;
+
+ unless ( $self->{Have_Plan} ) {
+ local $Level = $Level + 2;
+ $self->croak("You tried to run a test without a plan");
+ }
+}
+
+=back
+
+
+=head2 Test Status and Info
+
+=over 4
+
+=item B<current_test>
+
+ my $curr_test = $Test->current_test;
+ $Test->current_test($num);
+
+Gets/sets the current test number we're on. You usually shouldn't
+have to set this.
+
+If set forward, the details of the missing tests are filled in as 'unknown'.
+if set backward, the details of the intervening tests are deleted. You
+can erase history if you really want to.
+
+=cut
+
+sub current_test {
+ my ( $self, $num ) = @_;
+
+ lock( $self->{Curr_Test} );
+ if ( defined $num ) {
+ unless ( $self->{Have_Plan} ) {
+ $self->croak(
+ "Can't change the current test number without a plan!");
+ }
+
+ $self->{Curr_Test} = $num;
+
+ # If the test counter is being pushed forward fill in the details.
+ my $test_results = $self->{Test_Results};
+ if ( $num > @$test_results ) {
+ my $start = @$test_results ? @$test_results : 0;
+ for ( $start .. $num - 1 ) {
+ $test_results->[$_] = &share(
+ { 'ok' => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ }
+ );
+ }
+ }
+
+ # If backward, wipe history. Its their funeral.
+ elsif ( $num < @$test_results ) {
+ $#{$test_results} = $num - 1;
+ }
+ }
+ return $self->{Curr_Test};
+}
+
+=item B<summary>
+
+ my @tests = $Test->summary;
+
+A simple summary of the tests so far. True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
+
+Of course, test #1 is $tests[0], etc...
+
+=cut
+
+sub summary {
+ my ($self) = shift;
+
+ return map { $_->{'ok'} } @{ $self->{Test_Results} };
+}
+
+=item B<details>
+
+ my @tests = $Test->details;
+
+Like summary(), but with a lot more detail.
+
+ $tests[$test_num - 1] =
+ { 'ok' => is the test considered a pass?
+ actual_ok => did it literally say 'ok'?
+ name => name of the test (if any)
+ type => type of test (if any, see below).
+ reason => reason for the above (if any)
+ };
+
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'. This is for examining the result of 'todo'
+tests.
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test. Normal tests have a type
+of ''. Type can be one of the following:
+
+ skip see skip()
+ todo see todo()
+ todo_skip see todo_skip()
+ unknown see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when current_test() is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+it's type is 'unkown'. These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left undef.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+ $tests[22] = # 23 - 1, since arrays start from 0.
+ { ok => 1, # logically, the test passed since it's todo
+ actual_ok => 0, # in absolute terms, it failed
+ name => 'hole count',
+ type => 'todo',
+ reason => 'insufficient donuts'
+ };
+
+=cut
+
+sub details {
+ my $self = shift;
+ return @{ $self->{Test_Results} };
+}
+
+=item B<todo>
+
+ my $todo_reason = $Test->todo;
+ my $todo_reason = $Test->todo($pack);
+
+todo() looks for a $TODO variable in your tests. If set, all tests
+will be considered 'todo' (see Test::More and Test::Harness for
+details). Returns the reason (ie. the value of $TODO) if running as
+todo tests, false otherwise.
+
+todo() is about finding the right package to look for $TODO in. It
+uses the exported_to() package to find it. If that's not set, it's
+pretty good at guessing the right package to look at based on $Level.
+
+Sometimes there is some confusion about where todo() should be looking
+for the $TODO variable. If you want to be sure, tell it explicitly
+what $pack to use.
+
+=cut
+
+sub todo {
+ my ( $self, $pack ) = @_;
+
+ $pack = $pack || $self->exported_to || $self->caller($Level);
+ return 0 unless $pack;
+
+ no strict 'refs';
+ return defined ${ $pack . '::TODO' }
+ ? ${ $pack . '::TODO' }
+ : 0;
+}
+
+=item B<caller>
+
+ my $package = $Test->caller;
+ my($pack, $file, $line) = $Test->caller;
+ my($pack, $file, $line) = $Test->caller($height);
+
+Like the normal caller(), except it reports according to your level().
+
+=cut
+
+sub caller {
+ my ( $self, $height ) = @_;
+ $height ||= 0;
+
+ my @caller = CORE::caller( $self->level + $height + 1 );
+ return wantarray ? @caller : $caller[0];
+}
+
+=back
+
+=cut
+
+=begin _private
+
+=over 4
+
+=item B<_sanity_check>
+
+ $self->_sanity_check();
+
+Runs a bunch of end of test sanity checks to make sure reality came
+through ok. If anything is wrong it will die with a fairly friendly
+error message.
+
+=cut
+
+#'#
+sub _sanity_check {
+ my $self = shift;
+
+ $self->_whoa(
+ $self->{Curr_Test} < 0,
+ 'Says here you ran a negative number of tests!'
+ );
+ $self->_whoa(
+ !$self->{Have_Plan} and $self->{Curr_Test},
+ 'Somehow your tests ran without a plan!'
+ );
+ $self->_whoa(
+ $self->{Curr_Test} != @{ $self->{Test_Results} },
+ 'Somehow you got a different number of results than tests ran!'
+ );
+}
+
+=item B<_whoa>
+
+ $self->_whoa($check, $description);
+
+A sanity check, similar to assert(). If the $check is true, something
+has gone horribly wrong. It will die with the given $description and
+a note to contact the author.
+
+=cut
+
+sub _whoa {
+ my ( $self, $check, $desc ) = @_;
+ if ($check) {
+ local $Level = $Level + 1;
+ $self->croak(<<"WHOA");
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+=item B<_my_exit>
+
+ _my_exit($exit_num);
+
+Perl seems to have some trouble with exiting inside an END block. 5.005_03
+and 5.6.1 both seem to do odd things. Instead, this function edits $?
+directly. It should ONLY be called from inside an END block. It
+doesn't actually exit, that's your job.
+
+=cut
+
+sub _my_exit {
+ $? = $_[0];
+
+ return 1;
+}
+
+=back
+
+=end _private
+
+=cut
+
+$SIG{__DIE__} = sub {
+
+ # We don't want to muck with death in an eval, but $^S isn't
+ # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
+ # with it. Instead, we use caller. This also means it runs under
+ # 5.004!
+ my $in_eval = 0;
+ for ( my $stack = 1; my $sub = ( CORE::caller($stack) )[3]; $stack++ ) {
+ $in_eval = 1 if $sub =~ /^\(eval\)/;
+ }
+ $Test->{Test_Died} = 1 unless $in_eval;
+};
+
+sub _ending {
+ my $self = shift;
+
+ $self->_sanity_check();
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ # Exit if plan() was never called. This is so "require Test::Simple"
+ # doesn't puke.
+ # Don't do an ending if we bailed out.
+ if ( ( $self->{Original_Pid} != $$ )
+ or ( !$self->{Have_Plan} && !$self->{Test_Died} )
+ or $self->{Bailed_Out} )
+ {
+ _my_exit($?);
+ return;
+ }
+
+ # Figure out if we passed or failed and print helpful messages.
+ my $test_results = $self->{Test_Results};
+ if (@$test_results) {
+
+ # The plan? We have no plan.
+ if ( $self->{No_Plan} ) {
+ $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
+ $self->{Expected_Tests} = $self->{Curr_Test};
+ }
+
+ # Auto-extended arrays and elements which aren't explicitly
+ # filled in with a shared reference will puke under 5.8.0
+ # ithreads. So we have to fill them in by hand. :(
+ my $empty_result = &share( {} );
+ for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
+ $test_results->[$idx] = $empty_result
+ unless defined $test_results->[$idx];
+ }
+
+ my $num_failed = grep !$_->{'ok'},
+ @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
+
+ my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
+
+ if ( $num_extra < 0 ) {
+ my $s = $self->{Expected_Tests} == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
+FAIL
+ }
+ elsif ( $num_extra > 0 ) {
+ my $s = $self->{Expected_Tests} == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
+FAIL
+ }
+
+ if ($num_failed) {
+ my $num_tests = $self->{Curr_Test};
+ my $s = $num_failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+
+ $self->diag(<<"FAIL");
+Looks like you failed $num_failed test$s of $num_tests$qualifier.
+FAIL
+ }
+
+ if ( $self->{Test_Died} ) {
+ $self->diag(<<"FAIL");
+Looks like your test died just after $self->{Curr_Test}.
+FAIL
+
+ _my_exit(255) && return;
+ }
+
+ my $exit_code;
+ if ($num_failed) {
+ $exit_code = $num_failed <= 254 ? $num_failed : 254;
+ }
+ elsif ( $num_extra != 0 ) {
+ $exit_code = 255;
+ }
+ else {
+ $exit_code = 0;
+ }
+
+ _my_exit($exit_code) && return;
+ }
+ elsif ( $self->{Skip_All} ) {
+ _my_exit(0) && return;
+ }
+ elsif ( $self->{Test_Died} ) {
+ $self->diag(<<'FAIL');
+Looks like your test died before it could output anything.
+FAIL
+ _my_exit(255) && return;
+ }
+ else {
+ $self->diag("No tests run!\n");
+ _my_exit(255) && return;
+ }
+}
+
+END {
+ $Test->_ending if defined $Test and !$Test->no_ending;
+}
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+
+=head1 THREADS
+
+In perl 5.8.1 and later, Test::Builder is thread-safe. The test
+number is shared amongst all threads. This means if one thread sets
+the test number using current_test() they will all be effected.
+
+While versions earlier than 5.8.1 had threads they contain too many
+bugs to support.
+
+Test::Builder is only thread-aware if threads.pm is loaded I<before>
+Test::Builder.
+
+=head1 EXAMPLES
+
+CPAN can provide the best examples. Test::Simple, Test::More,
+Test::Exception and Test::Differences all use Test::Builder.
+
+=head1 SEE ALSO
+
+Test::Simple, Test::More, Test::Harness
+
+=head1 AUTHORS
+
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
+ Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff -urN perl-5.10.0/t.ble/lib/Test/More.pm perl-5.10.0/t/lib/Test/More.pm
--- perl-5.10.0/t.ble/lib/Test/More.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/Test/More.pm 2008-06-18 01:27:22.000000000 +0200
@@ -0,0 +1,1546 @@
+package Test::More;
+
+use 5.004;
+
+use strict;
+
+# Can't use Carp because it might cause use_ok() to accidentally succeed
+# even though the module being used forgot to use Carp. Yes, this
+# actually happened.
+sub _carp {
+ my ( $file, $line ) = ( caller(1) )[ 1, 2 ];
+ warn @_, " at $file line $line\n";
+}
+
+use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
+$VERSION = '0.72';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+use Test::Builder::Module;
+@ISA = qw(Test::Builder::Module);
+@EXPORT = qw(ok use_ok require_ok
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
+ pass fail
+ eq_array eq_hash eq_set
+ $TODO
+ plan
+ can_ok isa_ok
+ diag
+ BAIL_OUT
+);
+
+=head1 NAME
+
+Test::More - yet another framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use Test::More tests => 23;
+ # or
+ use Test::More qw(no_plan);
+ # or
+ use Test::More skip_all => $reason;
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ require_ok( 'Some::Module' );
+
+ # Various ways to say "ok"
+ ok($got eq $expected, $test_name);
+
+ is ($got, $expected, $test_name);
+ isnt($got, $expected, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($got, qr/expected/, $test_name);
+ unlike($got, qr/expected/, $test_name);
+
+ cmp_ok($got, '==', $expected, $test_name);
+
+ is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
+
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ TODO: {
+ local $TODO = $why;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ can_ok($module, @methods);
+ isa_ok($object, $class);
+
+ pass($test_name);
+ fail($test_name);
+
+ BAIL_OUT($why);
+
+ # UNIMPLEMENTED!!!
+ my @status = Test::More::status;
+
+
+=head1 DESCRIPTION
+
+B<STOP!> If you're just getting started writing tests, have a look at
+Test::Simple first. This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
+
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
+
+
+=head2 I love it when a plan comes together
+
+Before anything else, you need a testing plan. This basically declares
+how many tests your script is going to run to protect against premature
+failure.
+
+The preferred way to do this is to declare a plan when you C<use Test::More>.
+
+ use Test::More tests => 23;
+
+There are rare cases when you will not know beforehand how many tests
+your script is going to run. In this case, you can declare that you
+have no plan. (Try to avoid using this as it weakens your test.)
+
+ use Test::More qw(no_plan);
+
+B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
+think everything has failed. See L<CAVEATS and NOTES>).
+
+In some cases, you'll want to completely skip an entire testing script.
+
+ use Test::More skip_all => $skip_reason;
+
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success). See L<Test::Harness> for
+details.
+
+If you want to control what functions Test::More will export, you
+have to use the 'import' option. For example, to import everything
+but 'fail', you'd do:
+
+ use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function. Useful for when you
+have to calculate the number of tests.
+
+ use Test::More;
+ plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+ use Test::More;
+ if( $^O eq 'MacOS' ) {
+ plan skip_all => 'Test irrelevant on MacOS';
+ }
+ else {
+ plan tests => 42;
+ }
+
+=cut
+
+sub plan {
+ my $tb = Test::More->builder;
+
+ $tb->plan(@_);
+}
+
+# This implements "use Test::More 'no_diag'" but the behavior is
+# deprecated.
+sub import_extra {
+ my $class = shift;
+ my $list = shift;
+
+ my @other = ();
+ my $idx = 0;
+ while ( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if ( defined $item and $item eq 'no_diag' ) {
+ $class->builder->no_diag(1);
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+}
+
+=head2 Test names
+
+By convention, each test is assigned a number in order. This is
+largely done automatically for you. However, it's often very useful to
+assign a name to each test. Which would you rather see:
+
+ ok 4
+ not ok 5
+ ok 6
+
+or
+
+ ok 4 - basic multi-variable
+ not ok 5 - simple exponential
+ ok 6 - force == mass * acceleration
+
+The later gives you some idea of what failed. It also makes it easier
+to find the test in your script, simply search for "simple
+exponential".
+
+All test functions take a name argument. It's optional, but highly
+suggested that you use it.
+
+
+=head2 I'm ok, you're not ok.
+
+The basic purpose of this module is to print out either "ok #" or "not
+ok #" depending on if a given test succeeded or failed. Everything
+else is just gravy.
+
+All of the following print "ok" or "not ok" depending on if the test
+succeeded or failed. They all also return true or false,
+respectively.
+
+=over 4
+
+=item B<ok>
+
+ ok($got eq $expected, $test_name);
+
+This simply evaluates any expression (C<$got eq $expected> is just a
+simple example) and uses that to determine if the test succeeded or
+failed. A true expression passes, a false one fails. Very simple.
+
+For example:
+
+ ok( $exp{9} == 81, 'simple exponential' );
+ ok( Film->can('db_Main'), 'set_db()' );
+ ok( $p->tests == 4, 'saw tests' );
+ ok( !grep !defined $_, @items, 'items populated' );
+
+(Mnemonic: "This is ok.")
+
+$test_name is a very short description of the test that will be printed
+out. It makes it very easy to find a test in your script when it fails
+and gives others an idea of your intentions. $test_name is optional,
+but we B<very> strongly encourage its use.
+
+Should an ok() fail, it will produce some diagnostics:
+
+ not ok 18 - sufficient mucus
+ # Failed test 'sufficient mucus'
+ # in foo.t at line 42.
+
+This is the same as Test::Simple's ok() routine.
+
+=cut
+
+sub ok ($;$) {
+ my ( $test, $name ) = @_;
+ my $tb = Test::More->builder;
+
+ $tb->ok( $test, $name );
+}
+
+=item B<is>
+
+=item B<isnt>
+
+ is ( $got, $expected, $test_name );
+ isnt( $got, $expected, $test_name );
+
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> respectively and use the result of that to
+determine if the test succeeded or failed. So these:
+
+ # Is the ultimate answer 42?
+ is( ultimate_answer(), 42, "Meaning of Life" );
+
+ # $foo isn't empty
+ isnt( $foo, '', "Got some foo" );
+
+are similar to these:
+
+ ok( ultimate_answer() eq 42, "Meaning of Life" );
+ ok( $foo ne '', "Got some foo" );
+
+(Mnemonic: "This is that." "This isn't that.")
+
+So why use these? They produce better diagnostics on failure. ok()
+cannot know what you are testing for (beyond the name), but is() and
+isnt() know what the test was and why it failed. For example this
+test:
+
+ my $foo = 'waffle'; my $bar = 'yarblokos';
+ is( $foo, $bar, 'Is foo the same as bar?' );
+
+Will produce something like this:
+
+ not ok 17 - Is foo the same as bar?
+ # Failed test 'Is foo the same as bar?'
+ # in foo.t at line 139.
+ # got: 'waffle'
+ # expected: 'yarblokos'
+
+So you can figure out what went wrong without rerunning the test.
+
+You are encouraged to use is() and isnt() over ok() where possible,
+however do not be tempted to use them to find out if something is
+true or false!
+
+ # XXX BAD!
+ is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
+
+This does not check if C<exists $brooklyn{tree}> is true, it checks if
+it returns 1. Very different. Similar caveats exist for false and 0.
+In these cases, use ok().
+
+ ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
+
+For those grammatical pedants out there, there's an C<isn't()>
+function which is an alias of isnt().
+
+=cut
+
+sub is ($$;$) {
+ my $tb = Test::More->builder;
+
+ $tb->is_eq(@_);
+}
+
+sub isnt ($$;$) {
+ my $tb = Test::More->builder;
+
+ $tb->isnt_eq(@_);
+}
+
+*isn't = \&isnt;
+
+=item B<like>
+
+ like( $got, qr/expected/, $test_name );
+
+Similar to ok(), like() matches $got against the regex C<qr/expected/>.
+
+So this:
+
+ like($got, qr/expected/, 'this is like that');
+
+is similar to:
+
+ ok( $got =~ /expected/, 'this is like that');
+
+(Mnemonic "This is like that".)
+
+The second argument is a regular expression. It may be given as a
+regex reference (i.e. C<qr//>) or (for better compatibility with older
+perls) as a string that looks like a regex (alternative delimiters are
+currently not supported):
+
+ like( $got, '/expected/', 'this is like that' );
+
+Regex options may be placed on the end (C<'/expected/i'>).
+
+Its advantages over ok() are similar to that of is() and isnt(). Better
+diagnostics on failure.
+
+=cut
+
+sub like ($$;$) {
+ my $tb = Test::More->builder;
+
+ $tb->like(@_);
+}
+
+=item B<unlike>
+
+ unlike( $got, qr/expected/, $test_name );
+
+Works exactly as like(), only it checks if $got B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike ($$;$) {
+ my $tb = Test::More->builder;
+
+ $tb->unlike(@_);
+}
+
+=item B<cmp_ok>
+
+ cmp_ok( $got, $op, $expected, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $got eq $expected );
+ cmp_ok( $got, 'eq', $expected, 'this eq that' );
+
+ # ok( $got == $expected );
+ cmp_ok( $got, '==', $expected, 'this == that' );
+
+ # ok( $got && $expected );
+ cmp_ok( $got, '&&', $expected, 'this && that' );
+ ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $got
+and $expected were:
+
+ not ok 1
+ # Failed test in foo.t at line 12.
+ # '23'
+ # &&
+ # undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+=cut
+
+sub cmp_ok($$$;$) {
+ my $tb = Test::More->builder;
+
+ $tb->cmp_ok(@_);
+}
+
+=item B<can_ok>
+
+ can_ok($module, @methods);
+ can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+ can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
+ );
+
+only without all the typing and with a better interface. Handy for
+quickly testing an interface.
+
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
+=cut
+
+sub can_ok ($@) {
+ my ( $proto, @methods ) = @_;
+ my $class = ref $proto || $proto;
+ my $tb = Test::More->builder;
+
+ unless ($class) {
+ my $ok = $tb->ok( 0, "->can(...)" );
+ $tb->diag(' can_ok() called with empty class or reference');
+ return $ok;
+ }
+
+ unless (@methods) {
+ my $ok = $tb->ok( 0, "$class->can(...)" );
+ $tb->diag(' can_ok() called with no methods');
+ return $ok;
+ }
+
+ my @nok = ();
+ foreach my $method (@methods) {
+ $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
+ }
+
+ my $name;
+ $name
+ = @methods == 1
+ ? "$class->can('$methods[0]')"
+ : "$class->can(...)";
+
+ my $ok = $tb->ok( !@nok, $name );
+
+ $tb->diag( map " $class->can('$_') failed\n", @nok );
+
+ return $ok;
+}
+
+=item B<isa_ok>
+
+ isa_ok($object, $class, $object_name);
+ isa_ok($ref, $type, $ref_name);
+
+Checks to see if the given C<< $object->isa($class) >>. Also checks to make
+sure the object was defined in the first place. Handy for this sort
+of thing:
+
+ my $obj = Some::Module->new;
+ isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+ my $obj = Some::Module->new;
+ ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'. If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
+=cut
+
+sub isa_ok ($$;$) {
+ my ( $object, $class, $obj_name ) = @_;
+ my $tb = Test::More->builder;
+
+ my $diag;
+ $obj_name = 'The object' unless defined $obj_name;
+ my $name = "$obj_name isa $class";
+ if ( !defined $object ) {
+ $diag = "$obj_name isn't defined";
+ }
+ elsif ( !ref $object ) {
+ $diag = "$obj_name isn't a reference";
+ }
+ else {
+
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ my ( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
+ if ($error) {
+ if ( $error =~ /^Can't call method "isa" on unblessed reference/ )
+ {
+
+ # Its an unblessed reference
+ if ( !UNIVERSAL::isa( $object, $class ) ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+ else {
+ die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+Here's the error.
+$error
+WHOA
+ }
+ }
+ elsif ( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+
+ my $ok;
+ if ($diag) {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
+ }
+ else {
+ $ok = $tb->ok( 1, $name );
+ }
+
+ return $ok;
+}
+
+=item B<pass>
+
+=item B<fail>
+
+ pass($test_name);
+ fail($test_name);
+
+Sometimes you just want to say that the tests have passed. Usually
+the case is you've got some complicated condition that is difficult to
+wedge into an ok(). In this case, you can simply use pass() (to
+declare the test ok) or fail (for not ok). They are synonyms for
+ok(1) and ok(0).
+
+Use these very, very, very sparingly.
+
+=cut
+
+sub pass (;$) {
+ my $tb = Test::More->builder;
+ $tb->ok( 1, @_ );
+}
+
+sub fail (;$) {
+ my $tb = Test::More->builder;
+ $tb->ok( 0, @_ );
+}
+
+=back
+
+
+=head2 Module tests
+
+You usually want to test if the module you're testing loads ok, rather
+than just vomiting if its load fails. For such purposes we have
+C<use_ok> and C<require_ok>.
+
+=over 4
+
+=item B<use_ok>
+
+ BEGIN { use_ok($module); }
+ BEGIN { use_ok($module, @imports); }
+
+These simply use the given $module and test to make sure the load
+happened ok. It's recommended that you run use_ok() inside a BEGIN
+block so its functions are exported at compile-time and prototypes are
+properly honored.
+
+If @imports are given, they are passed through to the use. So this:
+
+ BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+ use Some::Module qw(foo bar);
+
+Version numbers can be checked like so:
+
+ # Just like "use Some::Module 1.02"
+ BEGIN { use_ok('Some::Module', 1.02) }
+
+Don't try to do this:
+
+ BEGIN {
+ use_ok('Some::Module');
+
+ ...some code that depends on the use...
+ ...happening at compile time...
+ }
+
+because the notion of "compile-time" is relative. Instead, you want:
+
+ BEGIN { use_ok('Some::Module') }
+ BEGIN { ...some code that depends on the use... }
+
+
+=cut
+
+sub use_ok ($;@) {
+ my ( $module, @imports ) = @_;
+ @imports = () unless @imports;
+ my $tb = Test::More->builder;
+
+ my ( $pack, $filename, $line ) = caller;
+
+ local ( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ if ( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ eval <<USE;
+package $pack;
+use $module $imports[0];
+USE
+ }
+ else {
+ eval <<USE;
+package $pack;
+use $module \@imports;
+USE
+ }
+
+ my $ok = $tb->ok( !$@, "use $module;" );
+
+ unless ($ok) {
+ chomp $@;
+ $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+ {BEGIN failed--compilation aborted at $filename line $line.}m;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to use '$module'.
+ Error: $@
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+=item B<require_ok>
+
+ require_ok($module);
+ require_ok($file);
+
+Like use_ok(), except it requires the $module or $file.
+
+=cut
+
+sub require_ok ($) {
+ my ($module) = shift;
+ my $tb = Test::More->builder;
+
+ my $pack = caller;
+
+ # Try to deterine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ local ( $!, $@, $SIG{__DIE__} ); # isolate eval
+ local $SIG{__DIE__};
+ eval <<REQUIRE;
+package $pack;
+require $module;
+REQUIRE
+
+ my $ok = $tb->ok( !$@, "require $module;" );
+
+ unless ($ok) {
+ chomp $@;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $@
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+ $module =~ /^[a-zA-Z]\w*$/;
+}
+
+=back
+
+
+=head2 Complex data structures
+
+Not everything is a simple eq check or regex. There are times you
+need to see if two data structures are equivalent. For these
+instances Test::More provides a handful of useful functions.
+
+B<NOTE> I'm not quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $got, $expected, $test_name );
+
+Similar to is(), except that if $got and $expected are references, it
+does a deep comparison walking each data structure to see if they are
+equivalent. If the two structures are different, it will display the
+place where they start differing.
+
+is_deeply() compares the dereferenced values of references, the
+references themselves (except for their type) are ignored. This means
+aspects such as blessing and ties are not considered "different".
+
+is_deeply() current has very limited handling of function reference
+and globs. It merely checks if they have the same referent. This may
+improve in the future.
+
+Test::Differences and Test::Deep provide more in-depth functionality
+along these lines.
+
+=cut
+
+use vars qw(@Data_Stack %Refs_Seen);
+my $DNE = bless [], 'Does::Not::Exist';
+
+sub _dne {
+ ref $_[0] eq ref $DNE;
+}
+
+sub is_deeply {
+ my $tb = Test::More->builder;
+
+ unless ( @_ == 2 or @_ == 3 ) {
+ my $msg = <<WARNING;
+is_deeply() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ _carp sprintf $msg, scalar @_;
+
+ return $tb->ok(0);
+ }
+
+ my ( $got, $expected, $name ) = @_;
+
+ $tb->_unoverload_str( \$expected, \$got );
+
+ my $ok;
+ if ( !ref $got and !ref $expected ) { # neither is a reference
+ $ok = $tb->is_eq( $got, $expected, $name );
+ }
+ elsif ( !ref $got xor !ref $expected ) { # one's a reference, one isn't
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack( { vals => [ $got, $expected ] } ) );
+ }
+ else { # both references
+ local @Data_Stack = ();
+ if ( _deep_check( $got, $expected ) ) {
+ $ok = $tb->ok( 1, $name );
+ }
+ else {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack(@Data_Stack) );
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my (@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if ( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif ( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif ( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
+ my @vars = ();
+ ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
+ ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
+
+ my $out = "Structures begin differing at:\n";
+ foreach my $idx ( 0 .. $#vals ) {
+ my $val = $vals[$idx];
+ $vals[$idx]
+ = !defined $val ? 'undef'
+ : _dne($val) ? "Does not exist"
+ : ref $val ? "$val"
+ : "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ return $type if UNIVERSAL::isa( $thing, $type );
+ }
+
+ return '';
+}
+
+=back
+
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Like C<print> @diagnostic_message is simply concatenated
+together.
+
+Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test 'There's a foo user'
+ # in foo.t at line 52.
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=cut
+
+sub diag {
+ my $tb = Test::More->builder;
+
+ $tb->diag(@_);
+}
+
+=back
+
+
+=head2 Conditional tests
+
+Sometimes running a test under certain conditions will cause the
+test script to die. A certain function or method isn't implemented
+(such as fork() on MacOS), some resource isn't available (like a
+net connection) or a module isn't available. In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
+but will work in the future (a todo test).
+
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
+
+The way Test::More handles this is with a named block. Basically, a
+block of tests which can be skipped over or made todo. It's best if I
+just show you...
+
+=over 4
+
+=item B<SKIP: BLOCK>
+
+ SKIP: {
+ skip $why, $how_many if $condition;
+
+ ...normal testing code goes here...
+ }
+
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them. An example is
+the easiest way to illustrate:
+
+ SKIP: {
+ eval { require HTML::Lint };
+
+ skip "HTML::Lint not installed", 2 if $@;
+
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
+
+ $lint->parse( $html );
+ is( $lint->errors, 0, "No errors found in HTML" );
+ }
+
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>. Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
+
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
+
+It's perfectly safe to nest SKIP blocks. Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
+
+You don't skip tests which are failing because there's a bug in your
+program, or for which you don't yet have code written. For that you
+use TODO. Read on.
+
+=cut
+
+#'#
+sub skip {
+ my ( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless ( defined $how_many ) {
+
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ if ( defined $how_many and $how_many =~ /\D/ ) {
+ _carp
+ "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
+ $how_many = 1;
+ }
+
+ for ( 1 .. $how_many ) {
+ $tb->skip($why);
+ }
+
+ local $^W = 0;
+ last SKIP;
+}
+
+=item B<TODO: BLOCK>
+
+ TODO: {
+ local $TODO = $why if $condition;
+
+ ...normal testing code goes here...
+ }
+
+Declares a block of tests you expect to fail and $why. Perhaps it's
+because you haven't fixed a bug or haven't finished a new feature:
+
+ TODO: {
+ local $TODO = "URI::Geller not finished";
+
+ my $card = "Eight of clubs";
+ is( URI::Geller->your_card, $card, 'Is THIS your card?' );
+
+ my $spoon;
+ URI::Geller->bend_spoon;
+ is( $spoon, 'bent', "Spoon bending, that's original" );
+ }
+
+With a todo block, the tests inside are expected to fail. Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo". Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programmatic todo list. You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+B<NOTE>: TODO tests require a Test::Harness upgrade else it will
+treat it as a normal failure. See L<CAVEATS and NOTES>).
+
+
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+With todo tests, it's best to have the tests actually run. That way
+you'll know when they start passing. Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>. In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my ( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless ( defined $how_many ) {
+
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "todo_skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ for ( 1 .. $how_many ) {
+ $tb->todo_skip($why);
+ }
+
+ local $^W = 0;
+ last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
+
+B<If it's something the programmer hasn't done yet>, use TODO. This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
+
+
+=back
+
+
+=head2 Test control
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ BAIL_OUT($reason);
+
+Indicates to the harness that things are going so badly all testing
+should terminate. This includes the running any additional test scripts.
+
+This is typically used when testing cannot continue such as a critical
+module failing to compile or a necessary external utility not being
+available such as a database connection failing.
+
+The test will exit with 255.
+
+=cut
+
+sub BAIL_OUT {
+ my $reason = shift;
+ my $tb = Test::More->builder;
+
+ $tb->BAIL_OUT($reason);
+}
+
+=back
+
+
+=head2 Discouraged comparison functions
+
+The use of the following functions is discouraged as they are not
+actually testing functions and produce no diagnostics to help figure
+out what went wrong. They were written before is_deeply() existed
+because I couldn't figure out how to display a useful diff of two
+arbitrary data structures.
+
+These functions are usually used inside an ok().
+
+ ok( eq_array(\@got, \@expected) );
+
+C<is_deeply()> can do that better and with diagnostics.
+
+ is_deeply( \@got, \@expected );
+
+They may be deprecated in future versions.
+
+=over 4
+
+=item B<eq_array>
+
+ my $is_eq = eq_array(\@got, \@expected);
+
+Checks if two arrays are equivalent. This is a deep check, so
+multi-level structures are handled correctly.
+
+=cut
+
+#'#
+sub eq_array {
+ local @Data_Stack;
+ _deep_check(@_);
+}
+
+sub _eq_array {
+ my ( $a1, $a2 ) = @_;
+
+ if ( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
+ warn "eq_array passed a non-array ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for ( 0 .. $max ) {
+ my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+ push @Data_Stack,
+ { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+sub _deep_check {
+ my ( $e1, $e2 ) = @_;
+ my $tb = Test::More->builder;
+
+ my $ok = 0;
+
+ # Effectively turn %Refs_Seen into a stack. This avoids picking up
+ # the same referenced used twice (such as [\$a, \$a]) to be considered
+ # circular.
+ local %Refs_Seen = %Refs_Seen;
+
+ {
+
+ # Quiet uninitialized value warnings when comparing undefs.
+ local $^W = 0;
+
+ $tb->_unoverload_str( \$e1, \$e2 );
+
+ # Either they're both references or both not.
+ my $same_ref = !( !ref $e1 xor !ref $e2 );
+ my $not_ref = ( !ref $e1 and !ref $e2 );
+
+ if ( defined $e1 xor defined $e2 ) {
+ $ok = 0;
+ }
+ elsif ( _dne($e1) xor _dne($e2) ) {
+ $ok = 0;
+ }
+ elsif ( $same_ref and ( $e1 eq $e2 ) ) {
+ $ok = 1;
+ }
+ elsif ($not_ref) {
+ push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ if ( $Refs_Seen{$e1} ) {
+ return $Refs_Seen{$e1} eq $e2;
+ }
+ else {
+ $Refs_Seen{$e1} = "$e2";
+ }
+
+ my $type = _type($e1);
+ $type = 'DIFFERENT' unless _type($e2) eq $type;
+
+ if ( $type eq 'DIFFERENT' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ elsif ( $type eq 'ARRAY' ) {
+ $ok = _eq_array( $e1, $e2 );
+ }
+ elsif ( $type eq 'HASH' ) {
+ $ok = _eq_hash( $e1, $e2 );
+ }
+ elsif ( $type eq 'REF' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif ( $type eq 'SCALAR' ) {
+ push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif ($type) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ _whoa( 1, "No type in _deep_check" );
+ }
+ }
+ }
+
+ return $ok;
+}
+
+sub _whoa {
+ my ( $check, $desc ) = @_;
+ if ($check) {
+ die <<WHOA;
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+=item B<eq_hash>
+
+ my $is_eq = eq_hash(\%got, \%expected);
+
+Determines if the two hashes contain the same keys and values. This
+is a deep check.
+
+=cut
+
+sub eq_hash {
+ local @Data_Stack;
+ return _deep_check(@_);
+}
+
+sub _eq_hash {
+ my ( $a1, $a2 ) = @_;
+
+ if ( grep !_type($_) eq 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ foreach my $k ( keys %$bigger ) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+=item B<eq_set>
+
+ my $is_eq = eq_set(\@got, \@expected);
+
+Similar to eq_array(), except the order of the elements is B<not>
+important. This is a deep check, but the irrelevancy of order only
+applies to the top level.
+
+ ok( eq_set(\@got, \@expected) );
+
+Is better written:
+
+ is_deeply( [sort @got], [sort @expected] );
+
+B<NOTE> By historical accident, this is not a true set comparison.
+While the order of elements does not matter, duplicate elements do.
+
+B<NOTE> eq_set() does not know how to deal with references at the top
+level. The following is an example of a comparison which might not work:
+
+ eq_set([\1, \2], [\2, \1]);
+
+Test::Deep contains much better set comparison functions.
+
+=cut
+
+sub eq_set {
+ my ( $a1, $a2 ) = @_;
+ return 0 unless @$a1 == @$a2;
+
+ # There's faster ways to do this, but this is easiest.
+ local $^W = 0;
+
+ # It really doesn't matter how we sort them, as long as both arrays are
+ # sorted with the same algorithm.
+ #
+ # Ensure that references are not accidentally treated the same as a
+ # string containing the reference.
+ #
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ #
+ # I don't know how references would be sorted so we just don't sort
+ # them. This means eq_set doesn't really work with refs.
+ return eq_array(
+ [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
+ [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
+ );
+}
+
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+ my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+
+=back
+
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+B<NOTE> This behavior may go away in future versions.
+
+
+=head1 CAVEATS and NOTES
+
+=over 4
+
+=item Backwards compatibility
+
+Test::More works with Perls as old as 5.004_05.
+
+
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings> (or in cmp_ok()'s
+case, strings or numbers as appropriate to the comparison op). This
+prevents Test::More from piercing an object's interface allowing
+better blackbox testing. So if a function starts returning overloaded
+objects instead of bare strings your tests won't notice the
+difference. This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects. In this case I would
+suggest Test::Deep which contains more flexible testing functions for
+complex data structures.
+
+
+=item Threads
+
+Test::More will only be aware of threads if "use threads" has been done
+I<before> Test::More is loaded. This is ok:
+
+ use threads;
+ use Test::More;
+
+This may cause problems:
+
+ use Test::More
+ use threads;
+
+5.8.1 and above are supported. Anything below that has too many bugs.
+
+
+=item Test::Harness upgrade
+
+no_plan and todo depend on new Test::Harness features and fixes. If
+you're going to distribute tests that use no_plan or todo your
+end-users will have to upgrade Test::Harness to the latest one on
+CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
+will work fine.
+
+Installing Test::More should also upgrade Test::Harness.
+
+=back
+
+
+=head1 HISTORY
+
+This is a case of convergent evolution with Joshua Pritikin's Test
+module. I was largely unaware of its existence when I'd first
+written my own ok() routines. This module exists because I can't
+figure out how to easily wedge test names into Test's interface (along
+with a few other problems).
+
+The goal here is to have a testing utility that's simple to learn,
+quick to use and difficult to trip yourself up with while still
+providing more flexibility than the existing Test.pm. As such, the
+names of the most common routines are kept tiny, special cases and
+magic side-effects are kept to a minimum. WYSIWYG.
+
+
+=head1 SEE ALSO
+
+L<Test::Simple> if all this confuses you and you just want to write
+some tests. You can upgrade to Test::More later (it's forward
+compatible).
+
+L<Test> is the old testing module. Its main benefit is that it has
+been distributed with Perl since 5.004_05.
+
+L<Test::Harness> for details on how your test results are interpreted
+by Perl.
+
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test::Class> is like XUnit but more perlish.
+
+L<Test::Deep> gives you more powerful complex data structure testing.
+
+L<Test::Unit> is XUnit style testing.
+
+L<Test::Inline> shows the idea of embedded testing.
+
+L<Bundle::Test> installs a whole bunch of useful test modules.
+
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001-2002, 2004-2006 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff -urN perl-5.10.0/t.ble/lib/Test/Simple.pm perl-5.10.0/t/lib/Test/Simple.pm
--- perl-5.10.0/t.ble/lib/Test/Simple.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/t/lib/Test/Simple.pm 2008-06-18 01:26:25.000000000 +0200
@@ -0,0 +1,228 @@
+package Test::Simple;
+
+use 5.004;
+
+use strict 'vars';
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '0.72';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+use Test::Builder::Module;
+@ISA = qw(Test::Builder::Module);
+@EXPORT = qw(ok);
+
+my $CLASS = __PACKAGE__;
+
+=head1 NAME
+
+Test::Simple - Basic utilities for writing tests.
+
+=head1 SYNOPSIS
+
+ use Test::Simple tests => 1;
+
+ ok( $foo eq $bar, 'foo is bar' );
+
+
+=head1 DESCRIPTION
+
+** If you are unfamiliar with testing B<read Test::Tutorial> first! **
+
+This is an extremely simple, extremely basic module for writing tests
+suitable for CPAN modules and other pursuits. If you wish to do more
+complicated testing, use the Test::More module (a drop-in replacement
+for this one).
+
+The basic unit of Perl testing is the ok. For each thing you want to
+test your program will print out an "ok" or "not ok" to indicate pass
+or fail. You do this with the ok() function (see below).
+
+The only other constraint is you must pre-declare how many tests you
+plan to run. This is in case something goes horribly wrong during the
+test and your test program aborts, or skips a test or whatever. You
+do this like so:
+
+ use Test::Simple tests => 23;
+
+You must have a plan.
+
+
+=over 4
+
+=item B<ok>
+
+ ok( $foo eq $bar, $name );
+ ok( $foo eq $bar );
+
+ok() is given an expression (in this case C<$foo eq $bar>). If it's
+true, the test passed. If it's false, it didn't. That's about it.
+
+ok() prints out either "ok" or "not ok" along with a test number (it
+keeps track of that for you).
+
+ # This produces "ok 1 - Hell not yet frozen over" (or not ok)
+ ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
+
+If you provide a $name, that will be printed along with the "ok/not
+ok" to make it easier to find your test when if fails (just search for
+the name). It also makes it easier for the next guy to understand
+what your test is for. It's highly recommended you use test names.
+
+All tests are run in scalar context. So this:
+
+ ok( @stuff, 'I have some stuff' );
+
+will do what you mean (fail if stuff is empty)
+
+=cut
+
+sub ok ($;$) {
+ $CLASS->builder->ok(@_);
+}
+
+=back
+
+Test::Simple will start by printing number of tests run in the form
+"1..M" (so "1..5" means you're going to run 5 tests). This strange
+format lets Test::Harness know how many tests you plan on running in
+case something goes horribly wrong.
+
+If all your tests passed, Test::Simple will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Simple
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+This module is by no means trying to be a complete testing system.
+It's just to get you started. Once you're off the ground its
+recommended you look at L<Test::More>.
+
+
+=head1 EXAMPLE
+
+Here's an example of a simple .t file for the fictional Film module.
+
+ use Test::Simple tests => 5;
+
+ use Film; # What you're testing.
+
+ my $btaste = Film->new({ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 1
+ });
+ ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' );
+
+ ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
+ ok( $btaste->Director eq 'Peter Jackson', 'Director() get' );
+ ok( $btaste->Rating eq 'R', 'Rating() get' );
+ ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
+
+It will produce output like this:
+
+ 1..5
+ ok 1 - new() works
+ ok 2 - Title() get
+ ok 3 - Director() get
+ not ok 4 - Rating() get
+ # Failed test 'Rating() get'
+ # in t/film.t at line 14.
+ ok 5 - NumExplodingSheep() get
+ # Looks like you failed 1 tests of 5
+
+Indicating the Film::Rating() method is broken.
+
+
+=head1 CAVEATS
+
+Test::Simple will only report a maximum of 254 failures in its exit
+code. If this is a problem, you probably have a huge test script.
+Split it into multiple files. (Otherwise blame the Unix folks for
+using an unsigned short integer as the exit status).
+
+Because VMS's exit codes are much, much different than the rest of the
+universe, and perl does horrible mangling to them that gets in my way,
+it works like this on VMS.
+
+ 0 SS$_NORMAL all tests successful
+ 4 SS$_ABORT something went wrong
+
+Unfortunately, I can't differentiate any further.
+
+
+=head1 NOTES
+
+Test::Simple is B<explicitly> tested all the way back to perl 5.004.
+
+Test::Simple is thread-safe in perl 5.8.0 and up.
+
+=head1 HISTORY
+
+This module was conceived while talking with Tony Bowden in his
+kitchen one night about the problems I was having writing some really
+complicated feature into the new Testing module. He observed that the
+main problem is not dealing with these edge cases but that people hate
+to write tests B<at all>. What was needed was a dead simple module
+that took all the hard work out of testing and was really, really easy
+to learn. Paul Johnson simultaneously had this idea (unfortunately,
+he wasn't in Tony's kitchen). This is it.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Test::More>
+
+More testing functions! Once you outgrow Test::Simple, look at
+Test::More. Test::Simple is 100% forward compatible with Test::More
+(i.e. you can just use Test::More instead of Test::Simple in your
+programs and things will still work).
+
+=item L<Test>
+
+The original Perl testing module.
+
+=item L<Test::Unit>
+
+Elaborate unit testing.
+
+=item L<Test::Inline>, L<SelfTest>
+
+Embed tests in your code!
+
+=item L<Test::Harness>
+
+Interprets the output of your test program.
+
+=back
+
+
+=head1 AUTHORS
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff -urN perl-5.10.0/lib.ble/App/Prove/State.pm perl-5.10.0/lib/App/Prove/State.pm
--- perl-5.10.0/lib.ble/App/Prove/State.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/App/Prove/State.pm 2008-06-18 01:27:27.000000000 +0200
@@ -0,0 +1,438 @@
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+@ISA = qw( TAP::Base );
+
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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>
+
+=cut
+
+# override TAP::Base::new:
+sub new {
+ my $class = shift;
+ my %args = %{ shift || {} };
+
+ my $self = bless {
+ _ => {
+ tests => {},
+ generation => 1
+ },
+ select => [],
+ seq => 1,
+ store => delete $args{store},
+ extension => delete $args{extension} || '.t',
+ }, $class;
+
+ my $store = $self->{store};
+ $self->load($store)
+ if defined $store && -f $store;
+
+ return $self;
+}
+
+=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};
+}
+
+sub DESTROY {
+ my $self = shift;
+ if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
+ $self->save($store);
+ }
+}
+
+=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->{_}->{generation} - 1;
+ my $now = $self->get_time;
+
+ my @switches = map { split /,/ } @opts;
+
+ my %handler = (
+ last => sub {
+ $self->_select(
+ where => sub { $_->{gen} >= $last_gen },
+ order => sub { $_->{seq} }
+ );
+ },
+ failed => sub {
+ $self->_select(
+ where => sub { $_->{last_result} != 0 },
+ order => sub { -$_->{last_result} }
+ );
+ },
+ passed => sub {
+ $self->_select( where => sub { $_->{last_result} == 0 } );
+ },
+ all => sub {
+ $self->_select();
+ },
+ todo => sub {
+ $self->_select(
+ where => sub { $_->{last_todo} != 0 },
+ order => sub { -$_->{last_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} } );
+ },
+ 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 keys %{ $self->{_}->{tests} };
+ return map { $self->_query_clause($_) } @sel;
+ }
+ return;
+}
+
+sub _query_clause {
+ my ( $self, $clause ) = @_;
+ my @got;
+ my $tests = $self->{_}->{tests};
+ my $where = $clause->{where} || sub {1};
+
+ # Select
+ for my $test ( sort keys %$tests ) {
+ next unless -f $test;
+ local $_ = $tests->{$test};
+ push @got, $test 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 $_ = $tests->{$_}; $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
+ 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
+
+sub observe_test {
+ my ( $self, $test, $parser ) = @_;
+ $self->_record_test(
+ $test, scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
+ scalar( $parser->todo ), $parser->start_time, $parser->end_time
+ );
+}
+
+# Store:
+# last fail time
+# last pass time
+# last run time
+# most recent result
+# most recent todos
+# total failures
+# total passes
+# state generation
+
+sub _record_test {
+ my ( $self, $test, $fail, $todo, $start_time, $end_time ) = @_;
+ my $rec = $self->{_}->{tests}->{ $test->[0] } ||= {};
+
+ $rec->{seq} = $self->{seq}++;
+ $rec->{gen} = $self->{_}->{generation};
+
+ $rec->{last_run_time} = $end_time;
+ $rec->{last_result} = $fail;
+ $rec->{last_todo} = $todo;
+ $rec->{elapsed} = $end_time - $start_time;
+
+ if ($fail) {
+ $rec->{total_failures}++;
+ $rec->{last_fail_time} = $end_time;
+ }
+ else {
+ $rec->{total_passes}++;
+ $rec->{last_pass_time} = $end_time;
+ }
+}
+
+=head3 C<save>
+
+Write the state to a file.
+
+=cut
+
+sub save {
+ my ( $self, $name ) = @_;
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+ local *FH;
+ open FH, ">$name" or croak "Can't write $name ($!)";
+ $writer->write( $self->{_} || {}, \*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 ($!)";
+ $self->{_} = $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->{_}->{generation}++;
+}
+
+sub _prune_and_stamp {
+ my $self = shift;
+ for my $name ( keys %{ $self->{_}->{tests} || {} } ) {
+ if ( my @stat = stat $name ) {
+ $self->{_}->{tests}->{$name}->{mtime} = $stat[9];
+ }
+ else {
+ delete $self->{_}->{tests}->{$name};
+ }
+ }
+}
+
+sub _regen_seq {
+ my $self = shift;
+ for my $rec ( values %{ $self->{_}->{tests} || {} } ) {
+ $self->{seq} = $rec->{seq} + 1
+ if defined $rec->{seq} && $rec->{seq} >= $self->{seq};
+ }
+}
diff -urN perl-5.10.0/lib.ble/App/Prove.pm perl-5.10.0/lib/App/Prove.pm
--- perl-5.10.0/lib.ble/App/Prove.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/App/Prove.pm 2008-06-18 01:27:28.000000000 +0200
@@ -0,0 +1,636 @@
+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;
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+App::Prove - Implements the C<prove> command.
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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 {
+ @ATTR = qw(
+ archive argv blib 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 test_args state dry extension ignore_exit
+ );
+ for my $attr (@ATTR) {
+ no strict 'refs';
+ *$attr = sub {
+ my $self = shift;
+ croak "$attr is read-only" if @_;
+ $self->{$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 )) {
+ $self->{$key} = [];
+ }
+ $self->{harness_class} = 'TAP::Harness';
+ $self->{_state} = App::Prove::State->new( { store => STATE_FILE } );
+
+ for my $attr (@ATTR) {
+ if ( exists $args->{$attr} ) {
+
+ # TODO: Some validation here
+ $self->{$attr} = $args->{$attr};
+ }
+ }
+
+ return $self;
+}
+
+=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},
+ '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},
+ ) 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 ( $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;
+ }
+
+ 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 );
+ print "$name\n";
+ eval "require $name";
+ return $name unless $@;
+ }
+
+ eval "require $class";
+ return $class unless $@;
+ return;
+}
+
+sub _load_extension {
+ my ( $self, $class, @search ) = @_;
+
+ my @args = ();
+ if ( $class =~ /^(.*?)=(.*)/ ) {
+ $class = $1;
+ @args = split( /,/, $2 );
+ }
+
+ if ( my $name = $self->_find_module( $class, @search ) ) {
+ $name->import(@args);
+ }
+ else {
+ croak "Can't load module $class";
+ }
+}
+
+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);
+ $app->run;
+
+=cut
+
+sub run {
+ my $self = shift;
+
+ 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};
+ 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);
+
+ $harness->callback(
+ after_test => sub {
+ $self->{_state}->observe_test(@_);
+ }
+ );
+
+ my $aggregator = $harness->runtests(@tests);
+
+ return $aggregator->has_problems ? 0 : 1;
+}
+
+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<show_help>
+
+=item C<show_man>
+
+=item C<show_version>
+
+=item C<shuffle>
+
+=item C<state>
+
+=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
diff -urN perl-5.10.0/lib.ble/TAP/Base.pm perl-5.10.0/lib/TAP/Base.pm
--- perl-5.10.0/lib.ble/TAP/Base.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Base.pm 2008-06-18 01:26:16.000000000 +0200
@@ -0,0 +1,139 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+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
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+
+ my $self = bless {}, $class;
+ return $self->_initialize($arg_for);
+}
+
+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/lib.ble/TAP/Formatter/Color.pm perl-5.10.0/lib/TAP/Formatter/Color.pm
--- perl-5.10.0/lib.ble/TAP/Formatter/Color.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Color.pm 2008-06-18 01:26:28.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Formatter/Console/ParallelSession.pm perl-5.10.0/lib/TAP/Formatter/Console/ParallelSession.pm
--- perl-5.10.0/lib.ble/TAP/Formatter/Console/ParallelSession.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Console/ParallelSession.pm 2008-06-18 01:27:03.000000000 +0200
@@ -0,0 +1,186 @@
+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,
+ };
+}
+
+sub _need_refresh {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ $shared{$formatter}->{need_refresh}++;
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for L<TAP::Harness::Parallel>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+Output test preamble
+
+=cut
+
+sub header {
+ my $self = shift;
+ $self->_need_refresh;
+}
+
+sub _refresh {
+}
+
+sub _clear_line {
+ my $self = shift;
+ $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
+}
+
+sub _output_ruler {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $context = $shared{$formatter};
+
+ my $ruler = sprintf( "===( %7d )", $context->{tests} );
+ $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 $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ $self->_refresh;
+
+ # my $really_quiet = $formatter->really_quiet;
+ # my $show_count = $self->_should_show_count;
+ my $planned = $parser->tests_planned;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ if ( $result->is_test ) {
+ $context->{tests}++;
+
+ my $test_print_modulus = 1;
+ my $ceiling = $context->{tests} / 5;
+ $test_print_modulus *= 2 while $test_print_modulus < $ceiling;
+
+ unless ( $context->{tests} % $test_print_modulus ) {
+ $self->_output_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};
+
+ unless ( $formatter->really_quiet ) {
+ $self->_clear_line;
+
+ # my $output = $self->_output_method;
+ $formatter->_output(
+ $formatter->_format_name( $self->name ),
+ ' '
+ );
+ }
+
+ if ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ $formatter->_output("ok\n")
+ unless $formatter->really_quiet;
+ }
+
+ $self->_output_ruler;
+
+ # $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;
+
+ $self->_need_refresh;
+
+ unless (@$active) {
+
+ # $self->formatter->_output("\n");
+ delete $shared{$formatter};
+ }
+}
+
+1;
diff -urN perl-5.10.0/lib.ble/TAP/Formatter/Console/Session.pm perl-5.10.0/lib/TAP/Formatter/Console/Session.pm
--- perl-5.10.0/lib.ble/TAP/Formatter/Console/Session.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Console/Session.pm 2008-06-18 01:27:05.000000000 +0200
@@ -0,0 +1,327 @@
+package TAP::Formatter::Console::Session;
+
+use strict;
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+my @ACCESSOR;
+
+BEGIN {
+
+ @ACCESSOR = qw( name formatter parser );
+
+ for my $method (@ACCESSOR) {
+ no strict 'refs';
+ *$method = sub { shift->{$method} };
+ }
+
+ my @CLOSURE_BINDING = qw( header result 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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+=cut
+
+=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>
+
+=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 ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::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.
+
+=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 $show_count = $self->_should_show_count;
+ my $pretty = $formatter->_format_name( $self->name );
+
+ 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 on first number, and roughly once per second
+ if ( ( $number == 1 )
+ || ( $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");
+ }
+ },
+
+ close_test => sub {
+ return if $really_quiet;
+
+ if ($show_count) {
+ my $spaces = ' ' x
+ length( '.' . $pretty . $plan . $parser->tests_run );
+ $formatter->$output("\r$spaces\r$pretty");
+ }
+
+ 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");
+ }
+ },
+ };
+}
+
+sub _should_show_count {
+
+ # we need this because if someone tries to redirect the output, it can get
+ # very garbled from the carriage returns (\r) in the count line.
+ return !shift->formatter->verbose && -t 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/lib.ble/TAP/Formatter/Console.pm perl-5.10.0/lib/TAP/Formatter/Console.pm
--- perl-5.10.0/lib.ble/TAP/Formatter/Console.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Formatter/Console.pm 2008-06-18 01:26:50.000000000 +0200
@@ -0,0 +1,469 @@
+package TAP::Formatter::Console;
+
+use strict;
+use TAP::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+my $MAX_ERRORS = 5;
+my %VALIDATION_FOR;
+
+BEGIN {
+ %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 },
+ 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
+ );
+
+ for my $method ( @getter_setters, keys %VALIDATION_FOR ) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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.
+
+=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 + 4 - length $test );
+
+ 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 {
+ 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
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+=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");
+ }
+
+ 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 } @_;
+}
+
+# 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;
+}
+
+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/lib.ble/TAP/Harness.pm perl-5.10.0/lib/TAP/Harness.pm
--- perl-5.10.0/lib.ble/TAP/Harness.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Harness.pm 2008-06-18 01:27:31.000000000 +0200
@@ -0,0 +1,822 @@
+package TAP::Harness;
+
+use strict;
+use Carp;
+
+use File::Spec;
+use File::Path;
+use IO::Handle;
+
+use TAP::Base;
+use TAP::Parser;
+use TAP::Parser::Aggregator;
+use TAP::Parser::Multiplexer;
+use TAP::Parser::Scheduler;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run test scripts with statistics
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+$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
+ );
+
+ %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 },
+ formatter_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.
+
+=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<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<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>.
+
+=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<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
+ );
+
+ 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;
+
+ unless ( $self->formatter ) {
+
+ $self->formatter_class( my $class = $self->formatter_class
+ || 'TAP::Formatter::Console' );
+
+ croak "Bad module name $class"
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ eval "require $class";
+ $self->_croak("Can't load $class") if $@;
+
+ # 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( $class->new( \%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 = TAP::Parser::Aggregator->new;
+
+ $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 ) ) {
+ exit 1 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 _aggregate_parallel {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ my $jobs = $self->jobs;
+ my $mux = TAP::Parser::Multiplexer->new;
+
+ 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);
+ exit 1 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;
+ exit 1;
+ }
+ }
+
+ $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;
+
+ # First transformation: turn scalars into single element arrays
+ my @tests = map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
+
+ # Work out how many different extensions we have
+ my %ext;
+ for my $test (@tests) {
+ $ext{$1}++ if $test->[0] =~ /\.(\w+)$/;
+ }
+
+ for my $test (@tests) {
+ if ( @$test == 1 ) {
+ $test->[1] = $test->[0];
+ $test->[1] =~ s/\.\w+$//
+ if keys %ext <= 1;
+ }
+ }
+ return @tests;
+}
+
+=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 TAP::Parser::Scheduler->new(
+ tests => [ $self->_add_descriptions(@tests) ],
+ rules => $self->rules
+ );
+}
+
+=head3 C<jobs>
+
+Returns the number of concurrent test runs the harness is handling. For the default
+harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel>
+will override this to return the number of jobs it is handling.
+
+=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 = TAP::Parser->new($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/lib.ble/TAP/Object.pm perl-5.10.0/lib/TAP/Object.pm
--- perl-5.10.0/lib.ble/TAP/Object.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Object.pm 2008-06-18 01:26:34.000000000 +0200
@@ -0,0 +1,97 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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;
+}
+
+1;
+
diff -urN perl-5.10.0/lib.ble/TAP/Parser/Aggregator.pm perl-5.10.0/lib/TAP/Parser/Aggregator.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Aggregator.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Aggregator.pm 2008-06-18 01:27:32.000000000 +0200
@@ -0,0 +1,412 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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';
+
+ 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 * 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 erros
+
+=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/lib.ble/TAP/Parser/Grammar.pm perl-5.10.0/lib/TAP/Parser/Grammar.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Grammar.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Grammar.pm 2008-06-22 03:03:04.000000000 +0200
@@ -0,0 +1,581 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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,
+ uc $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 ) = @_;
+ my %test = (
+ ok => $ok,
+ test_num => $num,
+ description => _trim($desc),
+ directive => uc( defined $dir ? $dir : '' ),
+ explanation => _trim($explanation),
+ raw => $line,
+ type => 'test',
+ );
+ return \%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/lib.ble/TAP/Parser/Iterator/Array.pm perl-5.10.0/lib/TAP/Parser/Iterator/Array.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Iterator/Array.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator/Array.pm 2008-06-22 03:03:04.000000000 +0200
@@ -0,0 +1,107 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Iterator/Process.pm perl-5.10.0/lib/TAP/Parser/Iterator/Process.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Iterator/Process.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator/Process.pm 2008-06-22 03:03:04.000000000 +0200
@@ -0,0 +1,373 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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 = $?;
+
+ # 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/lib.ble/TAP/Parser/Iterator/Stream.pm perl-5.10.0/lib/TAP/Parser/Iterator/Stream.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Iterator/Stream.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator/Stream.pm 2008-06-22 03:03:04.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/IteratorFactory.pm perl-5.10.0/lib/TAP/Parser/IteratorFactory.pm
--- perl-5.10.0/lib.ble/TAP/Parser/IteratorFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/IteratorFactory.pm 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,173 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Iterator.pm perl-5.10.0/lib/TAP/Parser/Iterator.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Iterator.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Iterator.pm 2008-06-22 03:03:04.000000000 +0200
@@ -0,0 +1,169 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Multiplexer.pm perl-5.10.0/lib/TAP/Parser/Multiplexer.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Multiplexer.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Multiplexer.pm 2008-06-18 01:27:16.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/Bailout.pm perl-5.10.0/lib/TAP/Parser/Result/Bailout.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/Bailout.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Bailout.pm 2008-06-18 01:26:33.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/Comment.pm perl-5.10.0/lib/TAP/Parser/Result/Comment.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/Comment.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Comment.pm 2008-06-18 01:27:23.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/Plan.pm perl-5.10.0/lib/TAP/Parser/Result/Plan.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/Plan.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Plan.pm 2008-06-18 01:26:45.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/Pragma.pm perl-5.10.0/lib/TAP/Parser/Result/Pragma.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/Pragma.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Pragma.pm 2008-06-18 01:26:59.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/Test.pm perl-5.10.0/lib/TAP/Parser/Result/Test.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/Test.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Test.pm 2008-06-18 01:27:21.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/Unknown.pm perl-5.10.0/lib/TAP/Parser/Result/Unknown.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/Unknown.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Unknown.pm 2008-06-18 01:26:36.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/Version.pm perl-5.10.0/lib/TAP/Parser/Result/Version.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/Version.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/Version.pm 2008-06-18 01:26:35.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result/YAML.pm perl-5.10.0/lib/TAP/Parser/Result/YAML.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result/YAML.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result/YAML.pm 2008-06-18 01:27:06.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/ResultFactory.pm perl-5.10.0/lib/TAP/Parser/ResultFactory.pm
--- perl-5.10.0/lib.ble/TAP/Parser/ResultFactory.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/ResultFactory.pm 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,187 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Result.pm perl-5.10.0/lib/TAP/Parser/Result.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Result.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Result.pm 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,297 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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) {
+ # make a shallow copy of the token:
+ $self->{$_} = $token->{$_} for (keys %$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/lib.ble/TAP/Parser/Scheduler/Job.pm perl-5.10.0/lib/TAP/Parser/Scheduler/Job.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Scheduler/Job.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Scheduler/Job.pm 2008-06-18 01:27:06.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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,
+ 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/lib.ble/TAP/Parser/Scheduler/Spinner.pm perl-5.10.0/lib/TAP/Parser/Scheduler/Spinner.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Scheduler/Spinner.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Scheduler/Spinner.pm 2008-06-18 01:27:33.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/Scheduler.pm perl-5.10.0/lib/TAP/Parser/Scheduler.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Scheduler.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Scheduler.pm 2008-06-18 01:27:18.000000000 +0200
@@ -0,0 +1,241 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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 _expand {
+ my ( $self, $name, $tests ) = @_;
+
+ $name =~ s{(.)}{
+ $1 eq '?' ? '[^/]'
+ : $1 eq '*' ? '[^/]*'
+ : quotemeta($1);
+ }gex;
+
+ my $pattern = qr{^$name$};
+ 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;
+ $self->_gather( $self->{schedule} );
+}
+
+sub _gather {
+ my ( $self, $rule ) = @_;
+ return unless defined $rule;
+ return $rule unless 'ARRAY' eq ref $rule;
+ return map { $self->_gather($_) } grep {defined} 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;
+ my @jobs = $self->_find_next_job( $self->{schedule} );
+ return $jobs[0] if @jobs;
+
+ # TODO: This isn't very efficient...
+ return TAP::Parser::Scheduler::Spinner->new
+ if $self->get_all;
+
+ return;
+}
+
+sub _not_empty {
+ my $ar = shift;
+ return 1 unless defined $ar && 'ARRAY' eq ref $ar;
+ return 1 if grep { _not_empty($_) } @$ar;
+ return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+ my ( $self, $rule ) = @_;
+
+ my @queue = ();
+ for my $seq (@$rule) {
+
+ # Prune any exhausted items.
+ shift @$seq while @$seq && _is_empty( $seq->[0] );
+ if ( @$seq && 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;
+ }
+ }
+ }
+
+ 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 ) {
+ 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/lib.ble/TAP/Parser/Source/Perl.pm perl-5.10.0/lib/TAP/Parser/Source/Perl.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Source/Perl.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Source/Perl.pm 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,322 @@
+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;
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new({ parser => $parser });
+ 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({ parser => $parser });
+
+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;
+
+Returns a stream of the output generated by executing C<source>.
+
+=cut
+
+sub get_stream {
+ my $self = shift;
+
+ my @extra_libs;
+
+ my @switches = $self->_switches;
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+
+ # 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;
+ for ( grep { $_ !~ $path_pat } @switches ) {
+ push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
+ }
+
+ my $previous = $ENV{PERL5LIB};
+ if ($previous) {
+ push @libs, split( $path_pat, $previous );
+ }
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB} = join( $path_sep, @libs );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $teardown = sub {
+ if ($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" } @switches ) {
+ push @switches,
+ $self->_libs2switches(
+ split $path_pat,
+ $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
+ );
+
+ push @switches, $ENV{PERL5OPT} || ();
+ }
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ return $self->{parser}->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 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 (@switches) {
+ $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
+ }
+
+ 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/lib.ble/TAP/Parser/Source.pm perl-5.10.0/lib/TAP/Parser/Source.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Source.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Source.pm 2008-06-22 14:32:38.000000000 +0200
@@ -0,0 +1,171 @@
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new({ parser => $parser });
+ 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({ parser => $parser });
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{switches} = [];
+ $self->{parser} = $args->{parser}; # TODO: accessor
+ _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.
+
+=cut
+
+sub get_stream {
+ my ($self) = @_;
+ my @command = $self->_get_command
+ or $self->_croak('No command found!');
+
+ return $self->{parser}->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/lib.ble/TAP/Parser/Utils.pm perl-5.10.0/lib/TAP/Parser/Utils.pm
--- perl-5.10.0/lib.ble/TAP/Parser/Utils.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/Utils.pm 2008-06-18 01:26:33.000000000 +0200
@@ -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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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/lib.ble/TAP/Parser/YAMLish/Reader.pm perl-5.10.0/lib/TAP/Parser/YAMLish/Reader.pm
--- perl-5.10.0/lib.ble/TAP/Parser/YAMLish/Reader.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/YAMLish/Reader.pm 2008-06-18 01:26:43.000000000 +0200
@@ -0,0 +1,333 @@
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.12';
+
+# 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.12
+
+=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/lib.ble/TAP/Parser/YAMLish/Writer.pm perl-5.10.0/lib/TAP/Parser/YAMLish/Writer.pm
--- perl-5.10.0/lib.ble/TAP/Parser/YAMLish/Writer.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser/YAMLish/Writer.pm 2008-06-18 01:27:16.000000000 +0200
@@ -0,0 +1,255 @@
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.12';
+
+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 enocde $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.12
+
+=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/lib.ble/TAP/Parser.pm perl-5.10.0/lib/TAP/Parser.pm
--- perl-5.10.0/lib.ble/TAP/Parser.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/TAP/Parser.pm 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,1847 @@
+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 );
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+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
+ foreach my $method (
+ 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
+ )
+ )
+ {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+} # 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(@_); }
+
+{
+
+ # 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->make_iterator( [ split "\n" => $tap ] );
+ }
+ elsif ($exec) {
+ my $source = $self->make_source( { parser => $self } );
+ $source->source( [ @$exec, @test_args ] );
+ $source->merge($merge); # XXX should just be arguments?
+ $stream = $source->get_stream;
+ }
+ elsif ($source) {
+ if ( my $ref = ref $source ) {
+ $stream = $self->make_iterator($source);
+ }
+ elsif ( -e $source ) {
+ my $perl = $self->make_perl_source( { parser => $self } );
+
+ $perl->switches($switches)
+ if $switches;
+
+ $perl->merge($merge); # XXX args to new()?
+ $perl->source( [ $source, @test_args ] );
+ $stream = $perl->get_stream;
+ }
+ 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 );
+
+ # 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
+
+=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>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-tapx-parser@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
+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/lib.ble/Test/Harness/bin/prove perl-5.10.0/lib/Test/Harness/bin/prove
--- perl-5.10.0/lib.ble/Test/Harness/bin/prove 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/bin/prove 2008-06-18 01:27:34.000000000 +0200
@@ -0,0 +1,258 @@
+#!/usr/bin/perl -w
+
+use strict;
+use App::Prove;
+
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+exit( $app->run ? 0 : 1 );
+
+__END__
+
+=head1 NAME
+
+prove - Run tests through a TAP harness.
+
+=head1 USAGE
+
+ prove [options] [files or directories]
+
+=head1 OPTIONS
+
+Boolean options:
+
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' to the path for your tests (-Iblib/lib).
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ -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
+
+Options that take arguments:
+
+ -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
+
+=head1 NOTES
+
+=head2 .proverc
+
+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:
+
+ # .proverc
+ --state=hot,fast,save
+ -j9 --fork
+
+Additional option files may be specified with the C<--rc> option.
+Default option file processing is disabled by the C<--norc> option.
+
+Under Windows and VMS the option file is named F<_proverc> rather than
+F<.proverc> and is sought only in the current directory.
+
+=head2 Reading from C<STDIN>
+
+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 '-':
+
+ prove - < my_list_of_things_to_test.txt
+
+See the C<README> in the C<examples> directory of this distribution.
+
+=head2 Default Test Directory
+
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
+
+=head2 Colored Test Output
+
+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.
+
+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.
+
+=head2 Arguments to Tests
+
+It is possible to supply arguments to tests. To do so separate them from
+prove's own arguments with the arisdottle, '::'. For example
+
+ 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.
+
+=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 this time 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>
+
+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.
+
+ # Run all tests in random order
+ $ prove -b --state=save --shuffle
+
+ # Run them again in the same order
+ $ prove -b --state=last
+
+=item C<failed>
+
+Run only the tests that failed on the last run.
+
+ # Run all tests
+ $ prove -b --state=save
+
+ # Run failures
+ $ prove -b --state=failed
+
+If you also specify the C<save> option newly passing tests will be
+excluded from subsequent runs.
+
+ # Repeat until no more failures
+ $ prove -b --state=failed,save
+
+=item C<passed>
+
+Run only the passed tests from last time. Useful to make sure that no
+new problems have been introduced.
+
+=item C<all>
+
+Run all tests in normal order. Multple options may be specified, so to
+run all tests with the failures from last time first:
+
+ $ prove -b --state=failed,all,save
+
+=item C<hot>
+
+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.
+
+ $ prove -b --state=hot,save
+
+Tests that have never failed will not be selected. To run all tests with
+the most recently failed first use
+
+ $ prove -b --state=hot,all,save
+
+This combination of options may also be specified thus
+
+ $ prove -b --state=adrian
+
+=item C<todo>
+
+Run any tests with todos.
+
+=item C<slow>
+
+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.
+
+ $ prove -b --state=slow -j9
+
+=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. The state is stored in a file called F<.prove>
+(F<_prove> on Windows and VMS) in the current directory.
+
+=back
+
+The C<--state> switch may be used more than once.
+
+ $ prove -b --state=hot --state=all,save
+
+=head2 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build directories
+to C<@INC> 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.
+
+=cut
+
+# vim:ts=4:sw=4:et:sta
diff -urN perl-5.10.0/lib.ble/Test/Harness/Changes perl-5.10.0/lib/Test/Harness/Changes
--- perl-5.10.0/lib.ble/Test/Harness/Changes 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/Changes 2008-06-22 03:03:49.000000000 +0200
@@ -0,0 +1,630 @@
+Revision history for Test-Harness
+
+3.12 ****-**-**
+ - 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 ...
diff -urN perl-5.10.0/lib.ble/Test/Harness/Hook.pm perl-5.10.0/lib/Test/Harness/Hook.pm
--- perl-5.10.0/lib.ble/Test/Harness/Hook.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/Hook.pm 2007-11-28 22:34:00.000000000 +0100
@@ -0,0 +1,30 @@
+package Harness::Hook;
+
+use strict;
+use warnings;
+use Carp;
+
+sub new {
+ my ( $class, $harness ) = @_;
+ my $self = bless {}, $class;
+
+ $harness->callback(
+ 'before_runtests',
+ sub {
+ my ($aggregate) = @_;
+ warn "Before runtests\n";
+ }
+ );
+
+ $harness->callback(
+ 'after_runtests',
+ sub {
+ my ( $aggregate, $results ) = @_;
+ warn "After runtests\n";
+ }
+ );
+
+ return $self;
+}
+
+1;
diff -urN perl-5.10.0/lib.ble/Test/Harness/t/000-load.t perl-5.10.0/lib/Test/Harness/t/000-load.t
--- perl-5.10.0/lib.ble/Test/Harness/t/000-load.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/000-load.t 2008-06-18 01:26:57.000000000 +0200
@@ -0,0 +1,59 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 74;
+
+BEGIN {
+
+ # TAP::Parser must come first
+ my @classes = qw(
+ TAP::Parser
+ App::Prove
+ App::Prove::State
+ 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/lib.ble/Test/Harness/t/aggregator.t perl-5.10.0/lib/Test/Harness/t/aggregator.t
--- perl-5.10.0/lib.ble/Test/Harness/t/aggregator.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/aggregator.t 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,301 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 79;
+
+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, '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/lib.ble/Test/Harness/t/bailout.t perl-5.10.0/lib/Test/Harness/t/bailout.t
--- perl-5.10.0/lib.ble/Test/Harness/t/bailout.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/bailout.t 2008-06-18 01:27:17.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/base.t perl-5.10.0/lib/Test/Harness/t/base.t
--- perl-5.10.0/lib.ble/Test/Harness/t/base.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/base.t 2008-06-18 01:27:33.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/callbacks.t perl-5.10.0/lib/Test/Harness/t/callbacks.t
--- perl-5.10.0/lib.ble/Test/Harness/t/callbacks.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/callbacks.t 2008-06-22 14:21:19.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/console.t perl-5.10.0/lib/Test/Harness/t/console.t
--- perl-5.10.0/lib.ble/Test/Harness/t/console.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/console.t 2008-06-18 01:26:31.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/errors.t perl-5.10.0/lib/Test/Harness/t/errors.t
--- perl-5.10.0/lib.ble/Test/Harness/t/errors.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/errors.t 2008-06-18 01:26:45.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/grammar.t perl-5.10.0/lib/Test/Harness/t/grammar.t
--- perl-5.10.0/lib.ble/Test/Harness/t/grammar.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/grammar.t 2008-06-18 01:27:14.000000000 +0200
@@ -0,0 +1,452 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib '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/lib.ble/Test/Harness/t/harness.t perl-5.10.0/lib/Test/Harness/t/harness.t
--- perl-5.10.0/lib.ble/Test/Harness/t/harness.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/harness.t 2008-06-18 01:27:20.000000000 +0200
@@ -0,0 +1,889 @@
+#!/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 IO::c55Capture;
+
+use TAP::Harness;
+
+my $HARNESS = 'TAP::Harness';
+
+my $source_tests = $ENV{PERL_CORE} ? 'lib/source_tests' : 't/source_tests';
+my $sample_tests = $ENV{PERL_CORE} ? 'lib/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::Console::_should_show_count = sub {0};
+ local *TAP::Formatter::Console::_output = sub {
+ my $self = shift;
+ push @output => grep { $_ ne '' }
+ map {
+ local $_ = $_;
+ chomp;
+ trim($_)
+ } @_;
+ };
+ 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 } );
+
+ 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} ? 'lib/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} ? ('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;
+
+ # 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' ], [ 'bar.t', 'bar' ], [ 'fletz.t', 'fletz' ]
+ ],
+ },
+ { name => 'all the same, already cooked',
+ input => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ],
+ output => [
+ [ 'foo.t', 'foo' ], [ 'bar.t', 'brip' ],
+ [ 'fletz.t', 'fletz' ]
+ ],
+ },
+ { 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/lib.ble/Test/Harness/t/iterators.t perl-5.10.0/lib/Test/Harness/t/iterators.t
--- perl-5.10.0/lib.ble/Test/Harness/t/iterators.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/iterators.t 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,212 @@
+#!/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} ? 'lib' : '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 $^O eq 'MSWin32' || $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/lib.ble/Test/Harness/t/multiplexer.t perl-5.10.0/lib/Test/Harness/t/multiplexer.t
--- perl-5.10.0/lib.ble/Test/Harness/t/multiplexer.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/multiplexer.t 2008-06-18 01:26:25.000000000 +0200
@@ -0,0 +1,167 @@
+#!/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} ? 'lib' : '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} ? 'lib' : '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} ? 'lib' : '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/lib.ble/Test/Harness/t/nofork-mux.t perl-5.10.0/lib/Test/Harness/t/nofork-mux.t
--- perl-5.10.0/lib.ble/Test/Harness/t/nofork-mux.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/nofork-mux.t 2008-06-18 01:27:30.000000000 +0200
@@ -0,0 +1,17 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use strict;
+
+use NoFork;
+require(
+ ( $ENV{PERL_CORE} ? '../lib/Test/Harness/' : '' ) . 't/multiplexer.t' );
diff -urN perl-5.10.0/lib.ble/Test/Harness/t/nofork.t perl-5.10.0/lib/Test/Harness/t/nofork.t
--- perl-5.10.0/lib.ble/Test/Harness/t/nofork.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/nofork.t 2008-06-18 01:26:58.000000000 +0200
@@ -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', '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} ? 'lib' : '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/lib.ble/Test/Harness/t/object.t perl-5.10.0/lib/Test/Harness/t/object.t
--- perl-5.10.0/lib.ble/Test/Harness/t/object.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/object.t 2008-06-18 01:26:44.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/parser-config.t perl-5.10.0/lib/Test/Harness/t/parser-config.t
--- perl-5.10.0/lib.ble/Test/Harness/t/parser-config.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/parser-config.t 2008-06-18 01:26:27.000000000 +0200
@@ -0,0 +1,46 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use vars qw(%INIT %CUSTOM);
+
+use Test::More tests => 11;
+use File::Spec::Functions qw( catfile );
+use TAP::Parser;
+
+use_ok('MySource');
+use_ok('MyPerlSource');
+use_ok('MyGrammar');
+use_ok('MyIteratorFactory');
+use_ok('MyResultFactory');
+
+my $t_dir = $ENV{PERL_CORE} ? 'lib' : 't';
+my $source = catfile( $t_dir, '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/lib.ble/Test/Harness/t/parser-subclass.t perl-5.10.0/lib/Test/Harness/t/parser-subclass.t
--- perl-5.10.0/lib.ble/Test/Harness/t/parser-subclass.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/parser-subclass.t 2008-06-22 20:08:33.000000000 +0200
@@ -0,0 +1,88 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use vars qw(%INIT %CUSTOM);
+
+use Test::More tests => 24;
+use File::Spec::Functions qw( catfile );
+
+use_ok('TAP::Parser::SubclassTest');
+
+# TODO: foreach my $source ( ... )
+my $t_dir = $ENV{PERL_CORE} ? 'lib' : 't';
+
+{ # perl source
+ %INIT = %CUSTOM = ();
+ my $source = catfile( $t_dir, '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_dir, '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/lib.ble/Test/Harness/t/parse.t perl-5.10.0/lib/Test/Harness/t/parse.t
--- perl-5.10.0/lib.ble/Test/Harness/t/parse.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/parse.t 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,1040 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', '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} ? 'lib' : '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';
+}
+
+{
+
+ # 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/lib.ble/Test/Harness/t/premature-bailout.t perl-5.10.0/lib/Test/Harness/t/premature-bailout.t
--- perl-5.10.0/lib.ble/Test/Harness/t/premature-bailout.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/premature-bailout.t 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,126 @@
+#!/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/lib.ble/Test/Harness/t/process.t perl-5.10.0/lib/Test/Harness/t/process.t
--- perl-5.10.0/lib.ble/Test/Harness/t/process.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/process.t 2008-06-18 01:26:54.000000000 +0200
@@ -0,0 +1,52 @@
+#!/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} ? 'lib' : '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/lib.ble/Test/Harness/t/proverc.t perl-5.10.0/lib/Test/Harness/t/proverc.t
--- perl-5.10.0/lib.ble/Test/Harness/t/proverc.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/proverc.t 2008-06-18 01:27:26.000000000 +0200
@@ -0,0 +1,32 @@
+#!/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} ? 'lib' : '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/lib.ble/Test/Harness/t/proverun.t perl-5.10.0/lib/Test/Harness/t/proverun.t
--- perl-5.10.0/lib.ble/Test/Harness/t/proverun.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/proverun.t 2008-06-18 01:26:59.000000000 +0200
@@ -0,0 +1,165 @@
+#!/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 {
+
+ my $sample_test = File::Spec->catfile(
+ split /\//,
+ ( $ENV{PERL_CORE} ? 'lib' : 't' ) . '/sample-tests/simple'
+ );
+
+ @SCHEDULE = (
+ { name => 'Create empty',
+ args => [$sample_test],
+ expect => [
+ [ 'new',
+ 'TAP::Parser::Iterator::Process',
+ { merge => undef,
+ command => [
+ 'PERL',
+ $sample_test
+ ],
+ setup => \'CODE',
+ teardown => \'CODE',
+
+ }
+ ]
+ ]
+ },
+ );
+
+ 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';
+
+ 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/lib.ble/Test/Harness/t/prove.t perl-5.10.0/lib/Test/Harness/t/prove.t
--- perl-5.10.0/lib.ble/Test/Harness/t/prove.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/prove.t 2008-06-18 01:27:30.000000000 +0200
@@ -0,0 +1,1387 @@
+#!/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;
+
+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 ( @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 },
+ '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 },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just quiet',
+ args => {
+ argv => [qw( one two three )],
+ quiet => 1,
+ },
+ expect => {
+ quiet => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -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
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just recurse',
+ args => {
+ argv => [qw( one two three )],
+ recurse => 1,
+ },
+ expect => {
+ recurse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just reverse',
+ args => {
+ argv => [qw( one two three )],
+ backwards => 1,
+ },
+ expect => {
+ backwards => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ 'three', 'two', 'one'
+ ]
+ ],
+ },
+
+ { name => 'Just shuffle',
+ args => {
+ argv => [qw( one two three )],
+ shuffle => 1,
+ },
+ expect => {
+ shuffle => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ '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
+ },
+ '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
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just verbose',
+ args => {
+ argv => [qw( one two three )],
+ verbose => 1,
+ },
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 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
+ },
+ '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
+ },
+ '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
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --verbose',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--verbose', $dummy_test ],
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -s',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-s', $dummy_test ],
+ expect => { shuffle => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ '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 },
+ '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
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -r',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-r', $dummy_test ],
+ expect => { recurse => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --recurse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--recurse', $dummy_test ],
+ expect => { recurse => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --reverse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--reverse', @dummy_tests ],
+ expect => { backwards => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ '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
+ },
+ '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
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -q',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-q', $dummy_test ],
+ expect => { quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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
+ },
+ '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 },
+ '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
+ },
+ '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 },
+ '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 },
+ '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 },
+ '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 },
+ '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 },
+ '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';
+
+ 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/lib.ble/Test/Harness/t/regression.t perl-5.10.0/lib/Test/Harness/t/regression.t
--- perl-5.10.0/lib.ble/Test/Harness/t/regression.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/regression.t 2008-06-18 01:26:43.000000000 +0200
@@ -0,0 +1,3181 @@
+#!/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} ? 'lib' : '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,
+ },
+
+ 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/lib.ble/Test/Harness/t/results.t perl-5.10.0/lib/Test/Harness/t/results.t
--- perl-5.10.0/lib.ble/Test/Harness/t/results.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/results.t 2008-06-22 14:21:19.000000000 +0200
@@ -0,0 +1,294 @@
+#!/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/lib.ble/Test/Harness/t/scheduler.t perl-5.10.0/lib/Test/Harness/t/scheduler.t
--- perl-5.10.0/lib.ble/Test/Harness/t/scheduler.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/scheduler.t 2008-06-18 01:27:24.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/source.t perl-5.10.0/lib/Test/Harness/t/source.t
--- perl-5.10.0/lib.ble/Test/Harness/t/source.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/source.t 2008-06-22 14:32:27.000000000 +0200
@@ -0,0 +1,98 @@
+#!/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 => 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} ? 'lib' : 't' ), 'source_tests',
+ 'source'
+);
+
+my $perl = $^X;
+
+can_ok 'TAP::Parser::Source', 'new';
+my $source = TAP::Parser::Source->new( { parser => $parser } );
+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;
+
+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( { parser => $parser } );
+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;
+
+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/lib.ble/Test/Harness/t/spool.t perl-5.10.0/lib/Test/Harness/t/spool.t
--- perl-5.10.0/lib.ble/Test/Harness/t/spool.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/spool.t 2008-06-18 01:27:24.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/state.t perl-5.10.0/lib/Test/Harness/t/state.t
--- perl-5.10.0/lib.ble/Test/Harness/t/state.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/state.t 2008-06-18 01:27:15.000000000 +0200
@@ -0,0 +1,252 @@
+#!/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;
+
+sub mn {
+ my $pfx = $ENV{PERL_CORE} ? '../lib/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',
+ ],
+ },
+);
+
+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 {
+ 'generation' => '51',
+ '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/lib.ble/Test/Harness/t/streams.t perl-5.10.0/lib/Test/Harness/t/streams.t
--- perl-5.10.0/lib.ble/Test/Harness/t/streams.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/streams.t 2008-06-22 14:21:19.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/taint.t perl-5.10.0/lib/Test/Harness/t/taint.t
--- perl-5.10.0/lib.ble/Test/Harness/t/taint.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/taint.t 2008-06-18 01:27:26.000000000 +0200
@@ -0,0 +1,79 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+# Test that options in PERL5LIB and PERL5OPT are propogated to tainted
+# tests
+
+use strict;
+use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 3 ) );
+
+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 } );
+ 1 while $p->next;
+ ok !$p->has_problems;
+
+ unlink $test_file;
+}
+
+{
+ local $ENV{PERL5LIB} = join $Config{path_sep}, grep defined, 'wibble',
+ $ENV{PERL5LIB};
+ run_test_file( <<'END', $lib_path );
+#!/usr/bin/perl -T
+
+BEGIN { unshift @INC, ( %s ); }
+use Test::More tests => 1;
+
+ok grep(/^wibble$/, @INC) or diag join "\n", @INC;
+END
+}
+
+{
+ my $perl5lib = $ENV{PERL5LIB};
+ local $ENV{PERL5LIB};
+ local $ENV{PERLLIB} = join $Config{path_sep}, grep defined, 'wibble',
+ $perl5lib;
+ run_test_file( <<'END', $lib_path );
+#!/usr/bin/perl -T
+
+BEGIN { unshift @INC, ( %s ); }
+use Test::More tests => 1;
+
+ok grep(/^wibble$/, @INC) or diag join "\n", @INC;
+END
+}
+
+{
+ local $ENV{PERL5LIB} = join $Config{path_sep}, @INC;
+ 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/lib.ble/Test/Harness/t/testargs.t perl-5.10.0/lib/Test/Harness/t/testargs.t
--- perl-5.10.0/lib.ble/Test/Harness/t/testargs.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/testargs.t 2008-06-18 01:26:34.000000000 +0200
@@ -0,0 +1,131 @@
+#!/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} ? 'lib' : '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/lib.ble/Test/Harness/t/unicode.t perl-5.10.0/lib/Test/Harness/t/unicode.t
--- perl-5.10.0/lib.ble/Test/Harness/t/unicode.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/unicode.t 2008-06-18 01:26:35.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/utils.t perl-5.10.0/lib/Test/Harness/t/utils.t
--- perl-5.10.0/lib.ble/Test/Harness/t/utils.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/utils.t 2008-06-18 01:26:51.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/yamlish-output.t perl-5.10.0/lib/Test/Harness/t/yamlish-output.t
--- perl-5.10.0/lib.ble/Test/Harness/t/yamlish-output.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/yamlish-output.t 2008-06-18 01:27:18.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/yamlish.t perl-5.10.0/lib/Test/Harness/t/yamlish.t
--- perl-5.10.0/lib.ble/Test/Harness/t/yamlish.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/yamlish.t 2008-06-22 03:03:49.000000000 +0200
@@ -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/lib.ble/Test/Harness/t/yamlish-writer.t perl-5.10.0/lib/Test/Harness/t/yamlish-writer.t
--- perl-5.10.0/lib.ble/Test/Harness/t/yamlish-writer.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness/t/yamlish-writer.t 2008-06-18 01:26:15.000000000 +0200
@@ -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/lib.ble/Test/Harness.pm perl-5.10.0/lib/Test/Harness.pm
--- perl-5.10.0/lib.ble/Test/Harness.pm 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Test/Harness.pm 2008-06-18 01:27:15.000000000 +0200
@@ -0,0 +1,601 @@
+package Test::Harness;
+
+require 5.00405;
+
+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
+ $Color
+ $Directives
+ $Timer
+ $Strap
+ $has_time_hires
+ $IgnoreExit
+);
+
+# $ML $Last_ML_Print
+
+BEGIN {
+ eval q{use Time::HiRes 'time'};
+ $has_time_hires = !$@;
+}
+
+=head1 NAME
+
+Test::Harness - Run Perl standard test scripts with statistics
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+# Backwards compatibility for exportable variable names.
+*verbose = *Verbose;
+*switches = *Switches;
+*debug = *Debug;
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+@ISA = ('Exporter');
+@EXPORT = qw(&runtests);
+@EXPORT_OK = qw(&execute_tests $verbose $switches);
+
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
+$Debug = $ENV{HARNESS_DEBUG} || 0;
+$Switches = '-w';
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Columns--; # Some shells have trouble with a full line of text.
+$Timer = $ENV{HARNESS_TIMER} || 0;
+$Color = $ENV{HARNESS_COLOR} || 0;
+$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
+
+=head1 SYNOPSIS
+
+ use Test::Harness;
+
+ runtests(@test_files);
+
+=head1 DESCRIPTION
+
+Although, for historical reasons, the L<Test::Harness> distribution
+takes its name from this module it now exists only to provide
+L<TAP::Harness> with an interface that is somewhat backwards compatible
+with L<Test::Harness> 2.xx. If you're writing new code consider using
+L<TAP::Harness> directly instead.
+
+Emulation is provided for C<runtests> and C<execute_tests> but the
+pluggable 'Straps' interface that previous versions of L<Test::Harness>
+supported is not reproduced here. Straps is now available as a stand
+alone module: L<Test::Harness::Straps>.
+
+See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
+distribution.
+
+=head1 FUNCTIONS
+
+The following functions are available.
+
+=head2 runtests( @test_files )
+
+This runs all the given I<@test_files> and divines whether they passed
+or failed based on their output to STDOUT (details above). It prints
+out each individual test which failed along with a summary report and
+a how long it all took.
+
+It returns true if everything was ok. Otherwise it will C<die()> with
+one of the messages in the DIAGNOSTICS section.
+
+=cut
+
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
+}
+
+sub _aggregate {
+ my ( $harness, $aggregate, @tests ) = @_;
+
+ # Don't propagate to our children
+ local $ENV{HARNESS_OPTIONS};
+
+ if (IS_VMS) {
+
+ # Jiggery pokery doesn't appear to work on VMS - so disable it
+ # pending investigation.
+ _aggregate_tests( $harness, $aggregate, @tests );
+ }
+ else {
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+ my @extra_inc = _filtered_inc();
+
+ # Supply -I switches in taint mode
+ $harness->callback(
+ parser_args => sub {
+ my ( $args, $test ) = @_;
+ if ( _has_taint( $test->[0] ) ) {
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
+ }
+ );
+
+ my $previous = $ENV{PERL5LIB};
+ local $ENV{PERL5LIB};
+
+ if ($previous) {
+ push @extra_inc, split( $path_pat, $previous );
+ }
+
+ if (@extra_inc) {
+ $ENV{PERL5LIB} = join( $path_sep, @extra_inc );
+ }
+
+ _aggregate_tests( $harness, $aggregate, @tests );
+ }
+}
+
+sub _aggregate_tests {
+ my ( $harness, $aggregate, @tests ) = @_;
+ $aggregate->start();
+ $harness->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop();
+
+}
+
+sub runtests {
+ my @tests = @_;
+
+ # shield against -l
+ local ( $\, $, );
+
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ _aggregate( $harness, $aggregate, @tests );
+
+ $harness->formatter->summary($aggregate);
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+ my $failed = $aggregate->failed;
+
+ my @parsers = $aggregate->parsers;
+
+ my $num_bad = 0;
+ for my $parser (@parsers) {
+ $num_bad++ if $parser->has_problems;
+ }
+
+ die(sprintf(
+ "Failed %d/%d test programs. %d/%d subtests failed.\n",
+ $num_bad, scalar @parsers, $failed, $total
+ )
+ ) if $num_bad;
+
+ return $total && $total == $passed;
+}
+
+sub _canon {
+ my @list = sort { $a <=> $b } @_;
+ my @ranges = ();
+ my $count = scalar @list;
+ my $pos = 0;
+
+ while ( $pos < $count ) {
+ my $end = $pos + 1;
+ $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
+ push @ranges, ( $end == $pos + 1 )
+ ? $list[$pos]
+ : join( '-', $list[$pos], $list[ $end - 1 ] );
+ $pos = $end;
+ }
+
+ return join( ' ', @ranges );
+}
+
+sub _new_harness {
+ my $sub_args = shift || {};
+
+ my ( @lib, @switches );
+ for my $opt ( split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ) ) {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, $1;
+ }
+ else {
+ push @switches, $opt;
+ }
+ }
+
+ # Do things the old way on VMS...
+ push @lib, _filtered_inc() if IS_VMS;
+
+ # If $Verbose isn't numeric default to 1. This helps core.
+ my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
+
+ my $args = {
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ color => $Color,
+ verbosity => $verbosity,
+ ignore_exit => $IgnoreExit,
+ };
+
+ $args->{stdout} = $sub_args->{out}
+ if exists $sub_args->{out};
+
+ 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";
+ }
+ }
+ }
+
+ return TAP::Harness->new($args);
+}
+
+# Get the parts of @INC which are changed from the stock list AND
+# preserve reordering of stock directories.
+sub _filtered_inc {
+ my @inc = grep { !ref } @INC; #28567
+
+ if (IS_VMS) {
+
+ # VMS has a 255-byte limit on the length of %ENV entries, so
+ # toss the ones that involve perl_root, the install location
+ @inc = grep !/perl_root/i, @inc;
+
+ }
+ elsif (IS_WIN32) {
+
+ # Lose any trailing backslashes in the Win32 paths
+ s/[\\\/+]$// foreach @inc;
+ }
+
+ my @default_inc = _default_inc();
+
+ my @new_inc;
+ my %seen;
+ for my $dir (@inc) {
+ next if $seen{$dir}++;
+
+ if ( $dir eq ( $default_inc[0] || '' ) ) {
+ shift @default_inc;
+ }
+ else {
+ push @new_inc, $dir;
+ }
+
+ shift @default_inc while @default_inc and $seen{ $default_inc[0] };
+ }
+
+ return @new_inc;
+}
+
+{
+
+ # Cache this to avoid repeatedly shelling out to Perl.
+ my @inc;
+
+ sub _default_inc {
+ return @inc if @inc;
+ my $perl = $ENV{HARNESS_PERL} || $^X;
+ chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` );
+ return @inc;
+ }
+}
+
+sub _check_sequence {
+ my @list = @_;
+ my $prev;
+ while ( my $next = shift @list ) {
+ return if defined $prev && $next <= $prev;
+ $prev = $next;
+ }
+
+ return 1;
+}
+
+sub execute_tests {
+ my %args = @_;
+
+ my $harness = _new_harness( \%args );
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ my %tot = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ bad => 0,
+ good => 0,
+ files => 0,
+ tests => 0,
+ sub_skipped => 0,
+ todo => 0,
+ skipped => 0,
+ bench => undef,
+ );
+
+ # Install a callback so we get to see any plans the
+ # harness executes.
+ $harness->callback(
+ made_parser => sub {
+ my $parser = shift;
+ $parser->callback(
+ plan => sub {
+ my $plan = shift;
+ if ( $plan->directive eq 'SKIP' ) {
+ $tot{skipped}++;
+ }
+ }
+ );
+ }
+ );
+
+ _aggregate( $harness, $aggregate, @{ $args{tests} } );
+
+ $tot{bench} = $aggregate->elapsed;
+ my @tests = $aggregate->descriptions;
+
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = scalar @tests;
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test (@tests) {
+ my ($parser) = $aggregate->parsers($test);
+
+ my @failed = $parser->failed;
+
+ my $wstat = $parser->wait;
+ my $estat = $parser->exit;
+ my $planned = $parser->tests_planned;
+ my @errors = $parser->parse_errors;
+ my $passed = $parser->passed;
+ my $actual_passed = $parser->actual_passed;
+
+ my $ok_seq = _check_sequence( $parser->actual_passed );
+
+ # Duplicate exit, wait status semantics of old version
+ $estat ||= '' unless $wstat;
+ $wstat ||= '';
+
+ $tot{max} += ( $planned || 0 );
+ $tot{bonus} += $parser->todo_passed;
+ $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
+ $tot{sub_skipped} += $parser->skipped;
+ $tot{todo} += $parser->todo;
+
+ if ( @failed || $estat || @errors ) {
+ $tot{bad}++;
+
+ my $huh_planned = $planned ? undef : '??';
+ my $huh_errors = $ok_seq ? undef : '??';
+
+ $failedtests{$test} = {
+ 'canon' => $huh_planned
+ || $huh_errors
+ || _canon(@failed)
+ || '??',
+ 'estat' => $estat,
+ 'failed' => $huh_planned
+ || $huh_errors
+ || scalar @failed,
+ 'max' => $huh_planned || $planned,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ else {
+ $tot{good}++;
+ }
+
+ my @todo = $parser->todo_passed;
+ if (@todo) {
+ $todo_passed{$test} = {
+ 'canon' => _canon(@todo),
+ 'estat' => $estat,
+ 'failed' => scalar @todo,
+ 'max' => scalar $parser->todo,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ }
+
+ return ( \%tot, \%failedtests, \%todo_passed );
+}
+
+=head2 execute_tests( tests => \@test_files, out => \*FH )
+
+Runs all the given C<@test_files> (just like C<runtests()>) but
+doesn't generate the final report. During testing, progress
+information will be written to the currently selected output
+filehandle (usually C<STDOUT>), or to the filehandle given by the
+C<out> parameter. The I<out> is optional.
+
+Returns a list of two values, C<$total> and C<$failed>, describing the
+results. C<$total> is a hash ref summary of all the tests run. Its
+keys and values are this:
+
+ bonus Number of individual todo tests unexpectedly passed
+ max Number of individual tests ran
+ ok Number of individual tests passed
+ sub_skipped Number of individual tests skipped
+ todo Number of individual todo tests
+
+ files Number of test files ran
+ good Number of test files passed
+ bad Number of test files failed
+ tests Number of test files originally given
+ skipped Number of test files skipped
+
+If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
+got a successful test.
+
+C<$failed> is a hash ref of all the test scripts that failed. Each key
+is the name of a test script, each value is another hash representing
+how that script failed. Its keys are these:
+
+ name Name of the test which failed
+ estat Script's exit value
+ wstat Script's wait status
+ max Number of individual tests
+ failed Number which failed
+ canon List of tests which failed (as string).
+
+C<$failed> should be empty if everything passed.
+
+=cut
+
+1;
+__END__
+
+=head1 EXPORT
+
+C<&runtests> is exported by C<Test::Harness> by default.
+
+C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
+exported upon request.
+
+=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
+
+C<Test::Harness> sets these before executing the individual tests.
+
+=over 4
+
+=item C<HARNESS_ACTIVE>
+
+This is set to a true value. It allows the tests to determine if they
+are being executed through the harness or by any other means.
+
+=item C<HARNESS_VERSION>
+
+This is the version of C<Test::Harness>.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
+
+=over 4
+
+=item C<HARNESS_TIMER>
+
+Setting this to true will make the harness display the number of
+milliseconds each test took. You can also use F<prove>'s C<--timer>
+switch.
+
+=item C<HARNESS_VERBOSE>
+
+If true, C<Test::Harness> will output the verbose results of running
+its tests. Setting C<$Test::Harness::verbose> will override this,
+or you can use the C<-v> switch in the F<prove> utility.
+
+=item C<HARNESS_OPTIONS>
+
+Provide additional options to the harness. Currently supported options are:
+
+=over
+
+=item C<< j<n> >>
+
+Run <n> (default 9) parallel jobs.
+
+=item C<< f >>
+
+Use forked parallelism.
+
+=back
+
+Multiple options may be separated by colons:
+
+ HARNESS_OPTIONS=j9:f make test
+
+=back
+
+=head1 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> C<Test::Harness> (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.
+
+=head1 SEE ALSO
+
+L<TAP::Harness>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
+notified, and then you'll automatically be notified of progress on your bug
+as I make changes.
+
+=head1 AUTHORS
+
+Andy Armstrong C<< <andy@hexten.net> >>
+
+L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
+module is based) has this attribution:
+
+ Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+ sure is, that it was inspired by Larry Wall's F<TEST> script that came
+ with perl distributions for ages. Numerous anonymous contributors
+ exist. Andreas Koenig held the torch for many years, and then
+ Michael G Schwern.
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
diff -up perl-5.10.0/MANIFEST.ble perl-5.10.0/MANIFEST
--- perl-5.10.0/MANIFEST.ble 2008-07-01 13:08:16.000000000 +0200
+++ perl-5.10.0/MANIFEST 2008-07-01 13:10:35.000000000 +0200
@@ -2593,34 +2593,40 @@ lib/Test/Builder/Module.pm Base class fo
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/App/Prove.pm Test::Harness::App
+lib/App/Prove/State.pm
+lib/TAP/Base.pm
+lib/TAP/Formatter/Color.pm
+lib/TAP/Formatter/Console.pm
+lib/TAP/Formatter/Console/ParallelSession.pm
+lib/TAP/Formatter/Console/Session.pm
+lib/TAP/Harness.pm
+lib/TAP/Parser.pm
+lib/TAP/Parser/Aggregator.pm
+lib/TAP/Parser/Grammar.pm
+lib/TAP/Parser/Iterator.pm
+lib/TAP/Parser/Iterator/Array.pm
+lib/TAP/Parser/Iterator/Process.pm
+lib/TAP/Parser/Iterator/Stream.pm
+lib/TAP/Parser/Multiplexer.pm
+lib/TAP/Parser/Result.pm
+lib/TAP/Parser/Result/Bailout.pm
+lib/TAP/Parser/Result/Comment.pm
+lib/TAP/Parser/Result/Plan.pm
+lib/TAP/Parser/Result/Pragma.pm
+lib/TAP/Parser/Result/Test.pm
+lib/TAP/Parser/Result/Unknown.pm
+lib/TAP/Parser/Result/Version.pm
+lib/TAP/Parser/Result/YAML.pm
+lib/TAP/Parser/Scheduler.pm
+lib/TAP/Parser/Scheduler/Job.pm
+lib/TAP/Parser/Scheduler/Spinner.pm
+lib/TAP/Parser/Source.pm
+lib/TAP/Parser/Source/Perl.pm
+lib/TAP/Parser/Utils.pm
+lib/TAP/Parser/YAMLish/Reader.pm
+lib/TAP/Parser/YAMLish/Writer.pm
+lib/Test/Harness.pm
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 -up perl-5.10.0/lib/Module/Build/t/compat.t.ble perl-5.10.0/lib/Module/Build/t/compat.t
--- perl-5.10.0/lib/Module/Build/t/compat.t.ble 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/Module/Build/t/compat.t 2008-07-01 15:40:50.000000000 +0200
@@ -174,8 +174,7 @@ ok $mb, "Module::Build->new_from_context
$output = stdout_of( sub { $ran_ok = $mb->do_system(@make, 'test', 'TEST_VERBOSE=0') } );
ok $ran_ok, "make test without verbose ran ok";
$output =~ s/^/# /gm; # Don't confuse our own test output
- like $output, qr/(?:# .+basic\.+ok\s+(?:[\d.]+\s*m?s\s*)?)# All tests/,
- 'Should be non-verbose';
+ ##like $output, qr/(?:# .+basic\.+ok\s+(?:[\d.]+\s*m?s\s*)?)# All tests/, 'Should be non-verbose';
$mb->delete_filetree($libdir);
ok ! -e $libdir, "Sample installation directory should be cleaned up";
diff -up perl-5.10.0/lib/Module/Build/t/compat.t.ble perl-5.10.0/lib/Module/Build/t/compat.t
--- perl-5.10.0/lib/Module/Build/t/compat.t.ble 2008-07-01 15:58:56.000000000 +0200
+++ perl-5.10.0/lib/Module/Build/t/compat.t 2008-07-01 15:59:05.000000000 +0200
@@ -15,7 +15,7 @@ delete @ENV{@makefile_keys};
my @makefile_types = qw(small passthrough traditional);
my $tests_per_type = 14;
if ( $Config{make} && find_in_path($Config{make}) ) {
- plan tests => 38 + @makefile_types*$tests_per_type*2;
+ plan tests => 38 + @makefile_types*$tests_per_type*2 - 1;
} else {
plan skip_all => "Don't know how to invoke 'make'";
}
Reference in New Issue View Git Blame Copy Permalink