From 325b0b76528f8d6768e28648ce474202cfed7413 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcela=20Ma=C5=A1l=C3=A1=C5=88ov=C3=A1?= Date: Wed, 2 Jul 2008 14:02:55 +0000 Subject: [PATCH] - 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! --- perl-5.10.0-TestHarness3.12.patch | 29416 ++++++++++++++++++++++++++ perl-5.10.0-removeTestHarness.patch | 5972 ++++++ perl.spec | 24 +- 3 files changed, 35409 insertions(+), 3 deletions(-) create mode 100644 perl-5.10.0-TestHarness3.12.patch create mode 100644 perl-5.10.0-removeTestHarness.patch diff --git a/perl-5.10.0-TestHarness3.12.patch b/perl-5.10.0-TestHarness3.12.patch new file mode 100644 index 0000000..aac9322 --- /dev/null +++ b/perl-5.10.0-TestHarness3.12.patch @@ -0,0 +1,29416 @@ +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 < 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 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 is true. In this case the effect is ++the same as of ++ ++ use MODULE ARGUMENTS; ++ ++Above C<< => >> provides necessary quoting of C. If not used (e.g., ++no ARGUMENTS to give), you'd better quote C yourselves. ++ ++=head1 BUGS ++ ++The current implementation does not allow specification of the ++required version of the module. ++ ++=head1 AUTHOR ++ ++Ilya Zakharevich L. ++ ++=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 <>= 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 < '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 < \\ ++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 < 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 < 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 < 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 < 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 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[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 This mechanism is I 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 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. ++ ++=head2 Construction ++ ++=over 4 ++ ++=item B ++ ++ 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 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. ++ ++=cut ++ ++my $Test = Test::Builder->new; ++ ++sub new { ++ my ($class) = shift; ++ $Test ||= $class->create; ++ return $Test; ++} ++ ++=item B ++ ++ 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 if you're testing ++a Test::Builder based module, but otherwise you probably want C. ++ ++B: the implementation is not complete. C, for example, is ++still shared amongst B 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 ++ ++ $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 ++ ++ 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 ++ ++ $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 ++ ++ 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 ++ ++ $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 ++ ++ $plan = $Test->has_plan ++ ++Find out whether a plan has been defined. $plan is either C (no plan has been set), C (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 ++ ++ $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 ++ ++ $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(<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 ++ ++ $Test->is_eq($got, $expected, $name); ++ ++Like Test::More's is(). Checks if $got eq $expected. This is the ++string version. ++ ++=item B ++ ++ $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 < ++ ++ $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 ++ ++ $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 ++ ++ $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 ++ ++ $Test->unlike($this, qr/$regex/, $name); ++ $Test->unlike($this, '/$regex/', $name); ++ ++Like Test::More's unlike(). Checks if $this B 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 ++ ++ $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 <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 ++ ++ $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 ++ ++ $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 ++ ++ $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 ++ ++ $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 ++ ++ $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 < ++ ++ 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 ++ ++ 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 ++ ++ $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 ++ ++ $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 ++ ++ $Test->no_diag($no_diag); ++ ++If set true no diagnostics will be printed. This includes calls to ++diag(). ++ ++=item B ++ ++ $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 ++ ++ $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 ++ ++ $Test->diag(@msgs); ++ ++Prints out the given @msgs. Like C, 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) it "passes through" the failure. ++ ++ return ok(...) || diag(...); ++ ++=for blame transfer ++Mark Fowler ++ ++=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 ++ ++ $Test->output($fh); ++ $Test->output($file); ++ ++Where normal "ok/not ok" test output should go. ++ ++Defaults to STDOUT. ++ ++=item B ++ ++ $Test->failure_output($fh); ++ $Test->failure_output($file); ++ ++Where diagnostic output on test failures and diag() should go. ++ ++Defaults to STDERR. ++ ++=item B ++ ++ $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 ++ ++ 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 ++ ++ 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
++ ++ 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 ++ ++ 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 ++ ++ 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 ++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 ++Eschwern@pobox.comE ++ ++=head1 COPYRIGHT ++ ++Copyright 2002, 2004 by chromatic Echromatic@wgz.orgE and ++ Michael G Schwern Eschwern@pobox.comE. ++ ++This program is free software; you can redistribute it and/or ++modify it under the same terms as Perl itself. ++ ++See F ++ ++=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 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 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 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: using no_plan requires a Test::Harness upgrade else it will ++think everything has failed. See L). ++ ++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 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($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 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 ++ ++=item B ++ ++ is ( $got, $expected, $test_name ); ++ isnt( $got, $expected, $test_name ); ++ ++Similar to ok(), is() and isnt() compare their two arguments ++with C and C 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 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 ++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( $got, qr/expected/, $test_name ); ++ ++Similar to ok(), like() matches $got against the regex C. ++ ++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) 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( $got, qr/expected/, $test_name ); ++ ++Works exactly as like(), only it checks if $got B match the ++given pattern. ++ ++=cut ++ ++sub unlike ($$;$) { ++ my $tb = Test::More->builder; ++ ++ $tb->unlike(@_); ++} ++ ++=item B ++ ++ 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 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($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($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 <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 ++ ++=item B ++ ++ 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 and C. ++ ++=over 4 ++ ++=item B ++ ++ 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 <ok( !$@, "use $module;" ); ++ ++ unless ($ok) { ++ chomp $@; ++ $@ =~ s{^BEGIN failed--compilation aborted at .*$} ++ {BEGIN failed--compilation aborted at $filename line $line.}m; ++ $tb->diag(< ++ ++ 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 <ok( !$@, "require $module;" ); ++ ++ unless ($ok) { ++ chomp $@; ++ $tb->diag(< I'm not quite sure what will happen with filehandles. ++ ++=over 4 ++ ++=item B ++ ++ 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 = <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. ++ ++=over 4 ++ ++=item B ++ ++ diag(@diagnostic_message); ++ ++Prints a diagnostic message which is guaranteed not to interfere with ++test output. Like C @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 with the mnemonic C. ++ ++B 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. ++ ++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: { ++ 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. 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 $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, 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: { ++ 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: TODO tests require a Test::Harness upgrade else it will ++treat it as a normal failure. See L). ++ ++ ++=item B ++ ++ 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 with and using C. 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 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, 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, 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($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 can do that better and with diagnostics. ++ ++ is_deeply( \@got, \@expected ); ++ ++They may be deprecated in future versions. ++ ++=over 4 ++ ++=item B ++ ++ 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 < ++ ++ 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 ++ ++ my $is_eq = eq_set(\@got, \@expected); ++ ++Similar to eq_array(), except the order of the elements is B ++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 By historical accident, this is not a true set comparison. ++While the order of elements does not matter, duplicate elements do. ++ ++B 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. ++ ++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 ++ ++ 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 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 (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 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 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 is the old testing module. Its main benefit is that it has ++been distributed with Perl since 5.004_05. ++ ++L for details on how your test results are interpreted ++by Perl. ++ ++L for more ways to test complex data structures. ++And it plays well with Test::More. ++ ++L is like XUnit but more perlish. ++ ++L gives you more powerful complex data structure testing. ++ ++L is XUnit style testing. ++ ++L shows the idea of embedded testing. ++ ++L installs a whole bunch of useful test modules. ++ ++ ++=head1 AUTHORS ++ ++Michael G Schwern Eschwern@pobox.comE 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 to report and view bugs. ++ ++ ++=head1 COPYRIGHT ++ ++Copyright 2001-2002, 2004-2006 by Michael G Schwern Eschwern@pobox.comE. ++ ++This program is free software; you can redistribute it and/or ++modify it under the same terms as Perl itself. ++ ++See F ++ ++=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 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( $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. ++ ++ ++=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 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. 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 ++ ++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 ++ ++The original Perl testing module. ++ ++=item L ++ ++Elaborate unit testing. ++ ++=item L, L ++ ++Embed tests in your code! ++ ++=item L ++ ++Interprets the output of your test program. ++ ++=back ++ ++ ++=head1 AUTHORS ++ ++Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern ++Eschwern@pobox.comE, wardrobe by Calvin Klein. ++ ++ ++=head1 COPYRIGHT ++ ++Copyright 2001, 2002, 2004 by Michael G Schwern Eschwern@pobox.comE. ++ ++This program is free software; you can redistribute it and/or ++modify it under the same terms as Perl itself. ++ ++See F ++ ++=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 command. ++ ++=head1 VERSION ++ ++Version 3.12 ++ ++=cut ++ ++$VERSION = '3.12'; ++ ++=head1 DESCRIPTION ++ ++The C 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 ++ ++=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 ++ ++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 a list of switch options to the state. ++ ++=over ++ ++=item C ++ ++Run in the same order as last time ++ ++=item C ++ ++Run only the failed tests from last time ++ ++=item C ++ ++Run only the passed tests from last time ++ ++=item C ++ ++Run all tests in normal order ++ ++=item C ++ ++Run the tests that most recently failed first ++ ++=item C ++ ++Run the tests ordered by number of todos. ++ ++=item C ++ ++Run the tests in slowest to fastest order. ++ ++=item C ++ ++Run test tests in fastest to slowest order. ++ ++=item C ++ ++Run the tests in newest to oldest order. ++ ++=item C ++ ++Run the tests in oldest to newest order. ++ ++=item C ++ ++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 ++ ++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 => ; ++ 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 ++ ++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 ++ ++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 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 = ; ++ 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 command. ++ ++=head1 VERSION ++ ++Version 3.12 ++ ++=cut ++ ++$VERSION = '3.12'; ++ ++=head1 DESCRIPTION ++ ++L provides a command, C, which runs a TAP based ++test suite and prints a report. The C 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 ++ ++Create a new C. 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 ++ ++ $prove->add_rc_file('myproj/.proverc'); ++ ++Called before C 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 = ) ) { ++ push @{ $self->{rc_opts} }, grep $_ && $_ !~ /^#/, ++ $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S*) }xg; ++ } ++ close RC; ++} ++ ++=head3 C ++ ++ $prove->process_args(@args); ++ ++Processes the command-line arguments. Attributes will be set ++appropriately. Any filenames may be found in the C 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 ++ ++Perform whatever actions the command line args specified. The C ++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 ++ ++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 ++ ++Display the version numbers of the loaded L 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. ++ ++=over ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=item C ++ ++=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 and L ++ ++=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 provides callback management. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++=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 ++ ++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 ++ ++Return the current time using Time::HiRes if available. ++ ++=cut ++ ++sub get_time { return time() } ++ ++=head3 C ++ ++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. 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, 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 cannot be found (or L 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 ++ ++The constructor returns a new C object. If ++L 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 ++ ++ 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 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. ++ ++=head1 SYNOPSIS ++ ++=cut ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C
++ ++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 ++ ++ 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 ++ ++=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 ++ ++ my %args = ( ++ formatter => $self, ++ ) ++ my $harness = TAP::Formatter::Console::Session->new( \%args ); ++ ++The constructor returns a new C object. ++ ++=over 4 ++ ++=item * C ++ ++=item * C ++ ++=item * C ++ ++=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
++ ++Output test preamble ++ ++=head3 C ++ ++Called by the harness for each line of TAP it receives. ++ ++=head3 C ++ ++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 ++ ++ my %args = ( ++ verbose => 1, ++ ) ++ my $harness = TAP::Formatter::Console->new( \%args ); ++ ++The constructor returns a new C object. If ++a L is created with no C a ++C 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 ++ ++Set the verbosity level. ++ ++=item * C ++ ++Printing individual test results to STDOUT. ++ ++=item * C ++ ++Append run time for each test to output. Uses L if available. ++ ++=item * C ++ ++Only show test failures (this is a no-op if C is selected). ++ ++=item * C ++ ++Suppressing some test output (mostly failures while tests are running). ++ ++=item * C ++ ++Suppressing everything but the tests summary. ++ ++=item * C ++ ++Suppressing all output. ++ ++=item * C ++ ++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 ++ ++If set to a true value, only test results with directives will be displayed. ++This overrides other settings such as C or C. ++ ++=item * C ++ ++A filehandle for catching standard output. ++ ++=item * C ++ ++If defined specifies whether color output is desired. If C 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 ++ ++The number of concurrent jobs this formatter will handle. ++ ++=back ++ ++Any keys for which the value is C will be ignored. ++ ++=cut ++ ++# new supplied by TAP::Base ++ ++=head3 C ++ ++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 ++ ++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 ++ ++ $harness->summary( $aggregate ); ++ ++C 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 ++ ++ my %args = ( ++ verbosity => 1, ++ lib => [ 'lib', 'blib/lib' ], ++ ) ++ my $harness = TAP::Harness->new( \%args ); ++ ++The constructor returns a new C object. It accepts an optional ++hashref whose allowed keys are: ++ ++=over 4 ++ ++=item * C ++ ++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 ++ ++Append run time for each test to output. Uses L if available. ++ ++=item * C ++ ++Only show test failures (this is a no-op if C is selected). ++ ++=item * C ++ ++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 ++ ++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 ++ ++A reference to an C<@INC> style array of arguments to be passed to each ++test program. ++ ++=item * C ++ ++Attempt to produce color output. ++ ++=item * C ++ ++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, 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 ++ ++If C is true the harness will create parsers that merge STDOUT ++and STDERR together for any processes they start. ++ ++=item * C ++ ++The name of the class to use to format output. The default is ++L. ++ ++=item * C ++ ++If set C must be an object that is capable of formatting the ++TAP output. See L for an example. ++ ++=item * C ++ ++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 ++ ++If set to a true value, only test results with directives will be displayed. ++This overrides other settings such as C or C. ++ ++=item * C ++ ++If set to a true value instruct C to ignore exit and wait ++status from test scripts. ++ ++=item * C ++ ++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 ++ ++A filehandle for catching standard output. ++ ++=back ++ ++Any keys for which the value is C 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 ++ ++ $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 as a C. See L 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 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 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 ++ ++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 ++ ++ $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. ++C may be called multiple times to run several sets of ++tests. Multiple C 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 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. ++ ++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 ++ ++Called by the harness when it needs to create a ++L. Override in a subclass to provide an ++alternative scheduler. C is passed the list of tests ++that was passed to C. ++ ++=cut ++ ++sub make_scheduler { ++ my ( $self, @tests ) = @_; ++ return TAP::Parser::Scheduler->new( ++ tests => [ $self->_add_descriptions(@tests) ], ++ rules => $self->rules ++ ); ++} ++ ++=head3 C ++ ++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 ++will override this to return the number of jobs it is handling. ++ ++=head3 C ++ ++If true the harness will attempt to fork and run the parser for each ++test in a separate process. Currently this option requires ++L to be installed. ++ ++=cut ++ ++############################################################################## ++ ++=head1 SUBCLASSING ++ ++C 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. ++ ++=head3 C ++ ++ $harness->summary( \%args ); ++ ++C prints the summary report after all tests are run. The argument is ++a hashref with the following keys: ++ ++=over 4 ++ ++=item * C ++ ++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 ++ ++This is an array reference of all test names. To get the L ++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 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 ++ ++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 utility and L but you want your ++own harness, all you need to do is write one and provide C and ++C methods. Then you can use the C utility like so: ++ ++ prove --harness My::Test::Harness ++ ++Note that while C accepts a list of tests (or things to be ++tested), C 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 ++ ++=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 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 provides a default constructor and exception model for all ++C classes. Exceptions are raised using L. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++Create a new object. Any arguments passed to C will be passed on to the ++L 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 L expects you to return C<$self> or raise an exception. See ++L, and L. ++ ++=cut ++ ++sub _initialize { ++ return $_[0]; ++} ++ ++=head3 C<_croak> ++ ++Raise an exception using C from L, eg: ++ ++ $self->_croak( 'why me?', 'aaarrgh!' ); ++ ++May also be called as a I 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 collects parser objects and allows ++reporting/querying their aggregate results. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++ my $aggregate = TAP::Parser::Aggregator->new; ++ ++Returns a new C 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 ++ ++ $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 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 ++ ++ 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 ++ ++Get an array of descriptions in the order in which they were added to the aggregator. ++ ++=cut ++ ++sub descriptions { @{ shift->{parse_order} || [] } } ++ ++=head3 C ++ ++Call C 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 ++ ++Call C immediately after adding all test results to the aggregator. ++ ++=cut ++ ++sub stop { ++ my $self = shift; ++ $self->{end_time} = Benchmark->new; ++} ++ ++=head3 C ++ ++Elapsed returns a L object that represents the running time ++of the aggregated tests. In order for C to be valid you must ++call C before running the tests and C 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 ++ ++Returns a formatted string representing the runtime returned by ++C. This lets the caller not worry about Benchmark. ++ ++=cut ++ ++sub elapsed_timestr { ++ my $self = shift; ++ ++ my $elapsed = $self->elapsed; ++ ++ return timestr($elapsed); ++} ++ ++=head3 C ++ ++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 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. ++ ++=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 ++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 and C 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 ++ ++ my $tests_run = $aggregate->total; ++ ++Returns the total number of tests run. ++ ++=cut ++ ++sub total { shift->{total} } ++ ++############################################################################## ++ ++=head3 C ++ ++ if ( $parser->has_problems ) { ++ ... ++ } ++ ++Identical to C, 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 ++ ++ if ( $parser->has_errors ) { ++ ... ++ } ++ ++Returns true if I 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 ++ ++ # 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. ++ ++=cut ++ ++sub todo_failed { ++ warn ++ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; ++ goto &todo_passed; ++} ++ ++=head1 See Also ++ ++L ++ ++L ++ ++=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 tokenizes lines from a TAP stream and constructs ++L 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 ++ ++ my $grammar = TAP::Parser::Grammar->new({ ++ stream => $stream, ++ parser => $parser, ++ version => $version, ++ }); ++ ++Returns L grammar object that will parse the specified stream. ++Both C and C are required arguments. If C is not set ++it defaults to C<12> (see L 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 ++ ++ $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 ++ ++ my $token = $grammar->tokenize; ++ ++This method will return a L 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 ++ ++ 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 ++ ++ 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 ++ ++ 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 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 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. It is I 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 for a subclassing overview. ++ ++If you I want to subclass L'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, ++L, ++L, ++L, ++ ++=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. Unless you're subclassing, you probably won't need to use ++this module directly. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++Create an iterator. Takes one argument: an C<$array_ref> ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++Iterate through it, of course. ++ ++=head3 C ++ ++Iterate raw input without applying any fixes for quirky input syntax. ++ ++=head3 C ++ ++Get the wait status for this iterator. For an array iterator this will always ++be zero. ++ ++=head3 C ++ ++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. ++ ++=head1 SEE ALSO ++ ++L, ++L, ++L, ++L, ++ ++=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. Unless you're subclassing, you probably won't need to use ++this module directly. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++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 & L to communicate with the spawned ++process if they are available. Falls back onto C. ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++Iterate through the process output, of course. ++ ++=head3 C ++ ++Iterate raw input without applying any fixes for quirky input syntax. ++ ++=head3 C ++ ++Get the wait status for this iterator's process. ++ ++=head3 C ++ ++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 ++ ++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 ++ ++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. ++ ++=head1 SEE ALSO ++ ++L, ++L, ++L, ++L, ++ ++=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. Unless you're subclassing, you probably won't need to use ++this module directly. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++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 ++ ++Iterate through it, of course. ++ ++=head3 C ++ ++Iterate raw input without applying any fixes for quirky input syntax. ++ ++=head3 C ++ ++Get the wait status for this iterator. Always returns zero. ++ ++=head3 C ++ ++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. ++ ++=head1 SEE ALSO ++ ++L, ++L, ++L, ++L, ++ ++=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 ++ ++Creates a new factory class. ++I You currently don't need to instantiate a factory in order to use it. ++ ++=head3 C ++ ++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 iterator (see L). ++ ++ my $iter = TAP::Parser::Iterator->make_iterator( $array_reference ); ++ ++Creates an I iterator (see L). ++ ++ my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference ); ++ ++Creates a I iterator (see L). ++ ++=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 a new stream iterator and return it. Passes through any arguments given. ++Defaults to a L. ++ ++=head3 C ++ ++Make a new array iterator and return it. Passes through any arguments given. ++Defaults to a L. ++ ++=head3 C ++ ++Make a new process iterator and return it. Passes through any arguments given. ++Defaults to a L. ++ ++=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 for a subclassing overview. ++ ++There are a few things to bear in mind when creating your own ++C: ++ ++=over 4 ++ ++=item 1 ++ ++The factory itself is never instantiated (this I 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. ++ ++=head1 SEE ALSO ++ ++L, ++L, ++L, ++L, ++L, ++L, ++ ++=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's iterator ++API. See C for the preferred way of creating ++iterators. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++Create an iterator. Provided by L. ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ while ( my $item = $iter->next ) { ... } ++ ++Iterate through it, of course. ++ ++=head3 C ++ ++B 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 ++ ++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 ++ ++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 ++ ++B this method is abstract and should be overridden. ++ ++ my $wait_status = $iter->wait; ++ ++Return the C status for this iterator. ++ ++=head3 C ++ ++B this method is abstract and should be overridden. ++ ++ my $wait_status = $iter->exit; ++ ++Return the C 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 for a subclassing overview. ++ ++You must override the abstract methods as noted above. ++ ++=head2 Example ++ ++L is probably the easiest example to follow. ++There's not much point repeating it here. ++ ++=head1 SEE ALSO ++ ++L, ++L, ++L, ++L, ++L, ++L, ++ ++=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 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 for an example of its use. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++ my $mux = TAP::Parser::Multiplexer->new; ++ ++Returns a new C 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 ++ ++ $mux->add( $parser, $stash ); ++ ++Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque ++reference that will be returned from C 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 ++ ++ 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 ++ ++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 ++ ++L ++ ++=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. 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 ++ ++=back ++ ++=cut ++ ++############################################################################## ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ 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. 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 ++ ++Note that this method merely returns the comment preceded by a '# '. ++ ++=back ++ ++=cut ++ ++############################################################################## ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ 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. 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 ++ ++=item * C ++ ++=back ++ ++=cut ++ ++############################################################################## ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ if ( $result->is_plan ) { ++ print $result->plan; ++ } ++ ++This is merely a synonym for C. ++ ++=cut ++ ++sub plan { '1..' . shift->{tests_planned} } ++ ++############################################################################## ++ ++=head3 C ++ ++ 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 ++ ++ 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 ++ ++ if ( $result->has_skip ) { ... } ++ ++Returns a boolean value indicating whether or not this test has a SKIP ++directive. ++ ++=head3 C ++ ++ 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 ++ ++ 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. 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 ++ ++=item * C ++ ++=back ++ ++=cut ++ ++############################################################################## ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++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. 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 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 ++ ++ my $ok = $result->ok; ++ ++Returns the literal text of the C or C status. ++ ++=cut ++ ++sub ok { shift->{ok} } ++ ++############################################################################## ++ ++=head3 C ++ ++ 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 ++ ++ 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 ++ ++ my $directive = $result->directive; ++ ++Returns either C or C if either directive was present for a test ++line. ++ ++=cut ++ ++sub directive { shift->{directive} } ++ ++############################################################################## ++ ++=head3 C ++ ++ my $explanation = $result->explanation; ++ ++If a test had either a C or C 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. ++ ++=cut ++ ++sub explanation { shift->{explanation} } ++ ++############################################################################## ++ ++=head3 C ++ ++ 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. ++ ++=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 ++ ++ 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 ++ ++Deprecated. Please use C instead. ++ ++=cut ++ ++sub actual_passed { ++ warn 'actual_passed() is deprecated. Please use "is_actual_ok()"'; ++ goto &is_actual_ok; ++} ++ ++############################################################################## ++ ++=head3 C ++ ++ 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 ++ ++ # 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. ++ ++=cut ++ ++sub todo_failed { ++ warn 'todo_failed() is deprecated. Please use "todo_passed()"'; ++ goto &todo_passed; ++} ++ ++############################################################################## ++ ++=head3 C ++ ++ if ( $result->has_skip ) { ... } ++ ++Returns a boolean value indicating whether or not this test has a SKIP ++directive. ++ ++=head3 C ++ ++ if ( $result->has_todo ) { ... } ++ ++Returns a boolean value indicating whether or not this test has a TODO ++directive. ++ ++=head3 C ++ ++ 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 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 ++ ++ 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 return false for C, ++regardless of whether or not the test C. ++ ++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. 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 ++ ++=item * C ++ ++=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. 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 ++ ++=item * C ++ ++=back ++ ++=cut ++ ++############################################################################## ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ if ( $result->is_version ) { ++ print $result->version; ++ } ++ ++This is merely a synonym for C. ++ ++=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. 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 ++ ++=item * C ++ ++=back ++ ++=cut ++ ++############################################################################## ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ 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 subclass ++representing the current bit of test data from TAP (usually a single line). ++It is used primarily by L. Unless you're subclassing, ++you probably won't need to use this module directly. ++ ++=head2 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++Creates a new factory class. ++I You currently don't need to instantiate a factory in order to use it. ++ ++=head3 C ++ ++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 ++ ++Takes one argument: C<$type>. Returns the class for this $type, or Cs ++with an error. ++ ++=head3 C ++ ++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. ++ ++=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 for a subclassing overview. ++ ++There are a few things to bear in mind when creating your own ++C: ++ ++=over 4 ++ ++=item 1 ++ ++The factory itself is never instantiated (this I change in the future). ++This means that C<_initialize> is never called. ++ ++=item 2 ++ ++Cnew> is never called, $tokens are reblessed. ++This I change in a future version! ++ ++=item 3 ++ ++L subclasses will register themselves with ++L 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, ++L, ++L ++ ++=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 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 ++ ++ # 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 ++ ++Indicates whether or not this is the test plan line. ++ ++ 1..3 ++ ++=item * C ++ ++Indicates whether or not this is a pragma line. ++ ++ pragma +strict ++ ++=item * C ++ ++Indicates whether or not this is a test line. ++ ++ ok 1 Is OK! ++ ++=item * C ++ ++Indicates whether or not this is a comment. ++ ++ # this is a comment ++ ++=item * C ++ ++Indicates whether or not this is bailout line. ++ ++ Bail out! We're out of dilithium crystals. ++ ++=item * C ++ ++Indicates whether or not this is a TAP version line. ++ ++ TAP version 4 ++ ++=item * C ++ ++Indicates whether or not the current line could be parsed. ++ ++ ... this line is junk ... ++ ++=item * C ++ ++Indicates whether or not this is a YAML chunk. ++ ++=back ++ ++=cut ++ ++############################################################################## ++ ++=head3 C ++ ++ print $result->raw; ++ ++Returns the original line of text which was parsed. ++ ++=cut ++ ++sub raw { shift->{raw} } ++ ++############################################################################## ++ ++=head3 C ++ ++ my $type = $result->type; ++ ++Returns the "type" of a token, such as C or C. ++ ++=cut ++ ++sub type { shift->{type} } ++ ++############################################################################## ++ ++=head3 C ++ ++ 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 method. ++ ++=cut ++ ++sub as_string { shift->{raw} } ++ ++############################################################################## ++ ++=head3 C ++ ++ if ( $result->is_ok ) { ... } ++ ++Reports whether or not a given result has passed. Anything which is B a ++test result returns true. This is merely provided as a convenient shortcut. ++ ++=cut ++ ++sub is_ok {1} ++ ++############################################################################## ++ ++=head3 C ++ ++Deprecated. Please use C instead. ++ ++=cut ++ ++sub passed { ++ warn 'passed() is deprecated. Please use "is_ok()"'; ++ shift->is_ok; ++} ++ ++############################################################################## ++ ++=head3 C ++ ++ 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 ++ ++ 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 ++ ++ 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 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 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. ++ ++If you're creating a completely new result I, you'll probably need to ++subclass L 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, ++L, ++L, ++L, ++L, ++L, ++L, ++L, ++L, ++L, ++L, ++ ++=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 ++ ++ my $job = TAP::Parser::Scheduler::Job->new( ++ $name, $desc ++ ); ++ ++Returns a new C object. ++ ++=cut ++ ++sub new { ++ my ( $class, $name, $desc, @ctx ) = @_; ++ return bless { ++ filename => $name, ++ description => $desc, ++ context => \@ctx, ++ }, $class; ++} ++ ++=head3 C ++ ++Register a closure to be called when this job is destroyed. ++ ++=cut ++ ++sub on_finish { ++ my ( $self, $cb ) = @_; ++ $self->{on_finish} = $cb; ++} ++ ++=head3 C ++ ++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 ++ ++=head3 C ++ ++=head3 C ++ ++=cut ++ ++sub filename { shift->{filename} } ++sub description { shift->{description} } ++sub context { @{ shift->{context} } } ++ ++=head3 C ++ ++For backwards compatibility in callbacks. ++ ++=cut ++ ++sub as_array_ref { ++ my $self = shift; ++ return [ $self->filename, $self->description, $self->context ]; ++} ++ ++=head3 C ++ ++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 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 ++ ++ my $job = TAP::Parser::Scheduler::Spinner->new; ++ ++Returns a new C object. ++ ++=cut ++ ++sub new { bless {}, shift } ++ ++=head3 C ++ ++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 ++ ++ my $sched = TAP::Parser::Scheduler->new; ++ ++Returns a new C 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 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 ++ ++Return the next available job or C if none are available. Returns ++a C 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 ++ ++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. See that module for ++more methods. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++ my $perl = TAP::Parser::Source::Perl->new({ parser => $parser }); ++ ++Returns a new C object. ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++Getter/setter the name of the test program and any arguments it requires. ++ ++ my ($filename, @args) = @{ $perl->source }; ++ $perl->source( [ $filename, @args ] ); ++ ++Cs 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 ++ ++ 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 ++ ++ my $stream = $source->get_stream; ++ ++Returns a stream of the output generated by executing C. ++ ++=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 ++ ++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 = ; ++ 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 ++ ++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 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, ++L, ++L, ++ ++=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 ++ ++ my $source = TAP::Parser::Source->new({ parser => $parser }); ++ ++Returns a new C 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 ++ ++ 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 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 ++ ++ my $stream = $source->get_stream; ++ ++Returns a L stream of the output generated by executing ++C. Cs 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 ++ ++ 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 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, ++L, ++L, ++ ++=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 ++ ++=head2 INTERFACE ++ ++=head3 C ++ ++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 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 with the ++permission of Adam Kennedy. ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++The constructor C creates and returns an empty ++C object. ++ ++ my $reader = TAP::Parser::YAMLish::Reader->new; ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ my $got = $reader->read($stream); ++ ++Read YAMLish from a L and return the data structure it ++represents. ++ ++=head3 C ++ ++ my $source = $reader->get_source; ++ ++Return the raw YAMLish source from the most recent C. ++ ++=head1 AUTHOR ++ ++Andy Armstrong, ++ ++Adam Kennedy wrote L which provided the template and many of ++the YAML matching regular expressions for this module. ++ ++=head1 SEE ALSO ++ ++L, L, L, L, L, ++L ++ ++=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 ++ ++ my $writer = TAP::Parser::YAMLish::Writer->new; ++ ++The constructor C creates and returns an empty ++C object. ++ ++=head2 Instance Methods ++ ++=head3 C ++ ++ $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, ++ ++=head1 SEE ALSO ++ ++L, L, L, L, L, ++L ++ ++=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 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 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. ++ ++There's a wiki dedicated to the Test Anything Protocol: ++ ++L ++ ++It includes the TAP::Parser Cookbook: ++ ++L ++ ++=head1 METHODS ++ ++=head2 Class Methods ++ ++=head3 C ++ ++ my $parser = TAP::Parser->new(\%args); ++ ++Returns a new C object. ++ ++The arguments should be a hashref with I of the following keys: ++ ++=over 4 ++ ++=item * C ++ ++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 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 ++ ++The value should be the complete TAP output. ++ ++=item * C ++ ++If passed an array reference, will attempt to create the iterator by ++passing a L object to ++L, using the array reference strings as ++the command arguments to L: ++ ++ exec => [ '/usr/bin/ruby', 't/my_test.rb' ] ++ ++Note that C and C are mutually exclusive. ++ ++=back ++ ++The following keys are optional. ++ ++=over 4 ++ ++=item * C ++ ++If present, each callback corresponding to a given result type will be called ++with the result as the argument if the C 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 ++ ++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 ++ ++Used in conjunction with the C option to supply a reference to ++an C<@ARGV> style array of arguments to pass to the test program. ++ ++=item * C ++ ++If passed a filehandle will write a copy of all parsed TAP to that handle. ++ ++=item * C ++ ++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 ++ ++This option was introduced to let you easily customize which I class ++the parser should use. It defaults to L. ++ ++See also L. ++ ++=item * C ++ ++This option was introduced to let you easily customize which I ++class the parser should use. It defaults to L. ++ ++See also L. ++ ++=item * C ++ ++This option was introduced to let you easily customize which I class ++the parser should use. It defaults to L. ++ ++See also L. ++ ++=item * C ++ ++This option was introduced to let you easily customize which I ++factory class the parser should use. It defaults to ++L. ++ ++See also L. ++ ++=item * C ++ ++This option was introduced to let you easily customize which I ++factory class the parser should use. It defaults to ++L. ++ ++See also L. ++ ++=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 ++ ++ 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. 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 ++ ++ $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 a new L object and return it. Passes through any ++arguments given. ++ ++The C can be customized, as described in L. ++ ++=head3 C ++ ++Make a new L object and return it. Passes through ++any arguments given. ++ ++The C can be customized, as described in L. ++ ++=head3 C ++ ++Make a new L object and return it. Passes through any ++arguments given. ++ ++The C can be customized, as described in L. ++ ++=head3 C ++ ++Make a new L object using the parser's ++L, and return it. Passes through any arguments ++given. ++ ++The C can be customized, as described in L. ++ ++=head3 C ++ ++Make a new L object using the parser's ++L, and return it. Passes through any arguments ++given. ++ ++The C can be customized, as described in L. ++ ++=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 subclass, referred to as ++I. ++ ++=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 ++ ++Returns the type of result, such as C or C. ++ ++=head3 C ++ ++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 method. ++ ++=head3 C ++ ++Returns the original line of text which was parsed. ++ ++=head3 C ++ ++Indicates whether or not this is the test plan line. ++ ++=head3 C ++ ++Indicates whether or not this is a test line. ++ ++=head3 C ++ ++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 option. ++ ++=head3 C ++ ++Indicates whether or not this is bailout line. ++ ++=head3 C ++ ++Indicates whether or not the current item is a YAML block. ++ ++=head3 C ++ ++Indicates whether or not the current line could be parsed. ++ ++=head3 C ++ ++ if ( $result->is_ok ) { ... } ++ ++Reports whether or not a given result has passed. Anything which is B 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 methods ++ ++ if ( $result->is_plan ) { ... } ++ ++If the above evaluates as true, the following methods will be available on the ++C<$result> object. ++ ++=head3 C ++ ++ if ( $result->is_plan ) { ++ print $result->plan; ++ } ++ ++This is merely a synonym for C. ++ ++=head3 C ++ ++ 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 ++ ++ my $explanation = $result->explanation; ++ ++If a SKIP directive was included with the plan, this method will return the ++explanation, if any. ++ ++=head2 C methods ++ ++ if ( $result->is_pragma ) { ... } ++ ++If the above evaluates as true, the following methods will be available on the ++C<$result> object. ++ ++=head3 C ++ ++Returns a list of pragmas each of which is a + or - followed by the ++pragma name. ++ ++=head2 C methods ++ ++ if ( $result->is_comment ) { ... } ++ ++If the above evaluates as true, the following methods will be available on the ++C<$result> object. ++ ++=head3 C ++ ++ if ( $result->is_comment ) { ++ my $comment = $result->comment; ++ print "I have something to say: $comment"; ++ } ++ ++=head2 C methods ++ ++ if ( $result->is_bailout ) { ... } ++ ++If the above evaluates as true, the following methods will be available on the ++C<$result> object. ++ ++=head3 C ++ ++ 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 methods ++ ++ if ( $result->is_unknown ) { ... } ++ ++There are no unique methods for unknown results. ++ ++=head2 C methods ++ ++ if ( $result->is_test ) { ... } ++ ++If the above evaluates as true, the following methods will be available on the ++C<$result> object. ++ ++=head3 C ++ ++ my $ok = $result->ok; ++ ++Returns the literal text of the C or C status. ++ ++=head3 C ++ ++ my $test_number = $result->number; ++ ++Returns the number of the test, even if the original TAP output did not supply ++that number. ++ ++=head3 C ++ ++ 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 ++ ++ my $directive = $result->directive; ++ ++Returns either C or C if either directive was present for a test ++line. ++ ++=head3 C ++ ++ my $explanation = $result->explanation; ++ ++If a test had either a C or C 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. ++ ++=head3 C ++ ++ 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 this was formerly C. The latter method is deprecated and ++will issue a warning. ++ ++=head3 C ++ ++ if ( $result->is_actual_ok ) { ... } ++ ++Returns a boolean value indicating whether or not the test passed, regardless ++of its TODO status. ++ ++B this was formerly C. The latter method is deprecated ++and will issue a warning. ++ ++=head3 C ++ ++ 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 return false for C, ++regardless of whether or not the test C (see ++L for more information about this). ++ ++=head3 C ++ ++ if ( $result->has_skip ) { ... } ++ ++Returns a boolean value indicating whether or not this test had a SKIP ++directive. ++ ++=head3 C ++ ++ if ( $result->has_todo ) { ... } ++ ++Returns a boolean value indicating whether or not this test had a TODO ++directive. ++ ++Note that TODO tests I pass. If you need to know whether or not ++they really passed, check the C method. ++ ++=head3 C ++ ++ 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 ++ ++ 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 ++ ++ 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 be counted as a failed test. ++ ++=cut ++ ++sub failed { @{ shift->{failed} } } ++ ++=head3 C ++ ++ # 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 ++ ++This method is a synonym for C. ++ ++=head3 C ++ ++ # 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 ++ ++ 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 ++ ++ # 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 ++ ++ # 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. ++ ++=cut ++ ++sub todo_failed { ++ warn ++ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; ++ goto &todo_passed; ++} ++ ++=head3 C ++ ++ 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 ++ ++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 ++ ++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 ++ ++ my $plan = $parser->plan; ++ ++Returns the test plan, if found. ++ ++=head3 C ++ ++Deprecated. Use C instead. ++ ++=cut ++ ++sub good_plan { ++ warn 'good_plan() is deprecated. Please use "is_good_plan()"'; ++ goto &is_good_plan; ++} ++ ++############################################################################## ++ ++=head3 C ++ ++ 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 this was formerly C. The latter method is deprecated and ++will issue a warning. ++ ++And since we're on that subject ... ++ ++=head3 C ++ ++ 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 ++ ++ 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 ++ ++Returns a true value (actually the reason for skipping) if all tests ++were skipped. ++ ++=head3 C ++ ++Returns the time when the Parser was created. ++ ++=head3 C ++ ++Returns the time when the end of TAP input was seen. ++ ++=head3 C ++ ++ 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 ++ ++ $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 ++ ++ $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 ++ ++ $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 status. ++ ++=head2 C ++ ++ $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 ++ ++ 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 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 an a list of file handles which can be passed to C