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