Front page | perl.perl5.changes |
Postings from May 2008
Change 33961: Integrate:
From:
Dave Mitchell
Date:
May 31, 2008 07:45
Subject:
Change 33961: Integrate:
Change 33961 by davem@davem-pigeon on 2008/05/31 14:30:09
Integrate:
[ 32659]
Upgrade to Test::Harness 3.05
Add test boilerplate to various test files.
Add FIXME skips for various tests that don't play nicely with the
altered layout in the core.
lib/Test/Harness/t/unicode.t appears to fail under UTF-8 locales and
so will need fixing.
Affected files ...
... //depot/maint-5.10/perl/MANIFEST#33 integrate
... //depot/maint-5.10/perl/Porting/Maintainers.pl#11 integrate
... //depot/maint-5.10/perl/lib/TAP/Base.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Formatter/Color.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Formatter/Console.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Formatter/Console/ParallelSession.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Formatter/Console/Session.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Harness.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Aggregator.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Grammar.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Iterator.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Iterator/Array.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Iterator/Process.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Iterator/Stream.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Multiplexer.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result/Bailout.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result/Comment.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result/Plan.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result/Test.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result/Unknown.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result/Version.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Result/YAML.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Source.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/Source/Perl.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/YAMLish/Reader.pm#1 branch
... //depot/maint-5.10/perl/lib/TAP/Parser/YAMLish/Writer.pm#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness.pm#2 integrate
... //depot/maint-5.10/perl/lib/Test/Harness/Assert.pm#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/Changes#2 integrate
... //depot/maint-5.10/perl/lib/Test/Harness/Iterator.pm#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/Point.pm#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/Results.pm#3 delete
... //depot/maint-5.10/perl/lib/Test/Harness/Straps.pm#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/TAP.pod#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/Util.pm#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/bin/prove#2 integrate
... //depot/maint-5.10/perl/lib/Test/Harness/t/000-load.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/aggregator.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/bailout.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/base.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Harness/t/callbacks.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/env.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/failure.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/inc-propagation.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/inc_taint.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/nonumbers.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/regression.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/test-harness-compat.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/version.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/console.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/errors.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/grammar.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/harness.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Harness/t/iterators.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/multiplexer.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/nofork-mux.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/nofork.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/parse.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/premature-bailout.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/process.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/prove.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/proverc.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/proverun.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/regression.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/results.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/source.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/spool.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/state.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/streams.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/taint.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/testargs.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/unicode.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/yamlish-output.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/yamlish-writer.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/yamlish.t#1 branch
... //depot/maint-5.10/perl/t/lib/App/Prove/Plugin/Dummy.pm#1 branch
... //depot/maint-5.10/perl/t/lib/Dev/Null.pm#2 integrate
... //depot/maint-5.10/perl/t/lib/IO/c55Capture.pm#1 branch
... //depot/maint-5.10/perl/t/lib/NoFork.pm#1 branch
... //depot/maint-5.10/perl/t/lib/data/catme.1#1 branch
... //depot/maint-5.10/perl/t/lib/data/proverc#1 branch
... //depot/maint-5.10/perl/t/lib/data/sample.yml#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/bailout#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/combined#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/combined_compat#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/delayed#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/descriptive_trailing#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/die#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/die_head_end#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/die_last_minute#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/die_unfinished#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/echo#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/empty#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/escape_eol#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/escape_hash#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/inc_taint#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/junk_before_plan#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/out_err_mix#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/schwern#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/schwern-todo-quiet#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/sequence_misparse#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/shbang_misparse#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/simple_yaml#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/skipall#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/skipall_v13#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/space_after_plan#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/stdout_stderr#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/taint#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/taint_warn#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/todo#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/todo_misparse#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/version_good#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/version_late#1 branch
... //depot/maint-5.10/perl/t/lib/sample-tests/version_old#1 branch
... //depot/maint-5.10/perl/t/lib/source_tests/harness#1 branch
... //depot/maint-5.10/perl/t/lib/source_tests/harness_badtap#1 branch
... //depot/maint-5.10/perl/t/lib/source_tests/harness_complain#1 branch
... //depot/maint-5.10/perl/t/lib/source_tests/harness_directives#1 branch
... //depot/maint-5.10/perl/t/lib/source_tests/harness_failure#1 branch
... //depot/maint-5.10/perl/t/lib/source_tests/source#1 branch
Differences ...
==== //depot/maint-5.10/perl/MANIFEST#33 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#32~33960~ 2008-05-31 07:19:17.000000000 -0700
+++ perl/MANIFEST 2008-05-31 07:30:09.000000000 -0700
@@ -1411,6 +1411,8 @@
lib/abbrev.pl An abbreviation table builder
lib/AnyDBM_File.pm Perl module to emulate dbmopen
lib/AnyDBM_File.t See if AnyDBM_File works
+lib/App/Prove.pm Gubbins for the prove utility
+lib/App/Prove/State.pm Gubbins for the prove utility
lib/Archive/Extract.pm Archive::Extract
lib/Archive/Extract/t/01_Archive-Extract.t Archive::Extract tests
lib/Archive/Extract/t/src/double_dir.zip.packed Archive::Extract tests
@@ -2622,6 +2624,32 @@
lib/Symbol.t See if Symbol works
lib/syslog.pl Perl library supporting syslogging
lib/tainted.pl Old code for tainting
+lib/TAP/Base.pm A parser for Test Anything Protocol
+lib/TAP/Formatter/Color.pm A parser for Test Anything Protocol
+lib/TAP/Formatter/Console.pm A parser for Test Anything Protocol
+lib/TAP/Formatter/Console/ParallelSession.pm A parser for Test Anything Protocol
+lib/TAP/Formatter/Console/Session.pm A parser for Test Anything Protocol
+lib/TAP/Harness.pm A parser for Test Anything Protocol
+lib/TAP/Parser.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Aggregator.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Grammar.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Iterator.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Iterator/Array.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Iterator/Process.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Iterator/Stream.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Multiplexer.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/Bailout.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/Comment.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/Plan.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/Test.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/Unknown.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/Version.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/YAML.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Source.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Source/Perl.pm A parser for Test Anything Protocol
+lib/TAP/Parser/YAMLish/Reader.pm A parser for Test Anything Protocol
+lib/TAP/Parser/YAMLish/Writer.pm A parser for Test Anything Protocol
lib/Term/ANSIColor/ChangeLog Term::ANSIColor
lib/Term/ANSIColor.pm Perl module supporting termcap usage
lib/Term/ANSIColor/README Term::ANSIColor
@@ -2642,34 +2670,48 @@
lib/Test/Builder.pm For writing new test libraries
lib/Test/Builder/Tester/Color.pm Turn on color in Test::Builder::Tester
lib/Test/Builder/Tester.pm For testing Test::Builder based classes
-lib/Test/Harness/Assert.pm Test::Harness::Assert (internal use only)
lib/Test/Harness/bin/prove The prove harness utility
-lib/Test/Harness/Changes Test::Harness
-lib/Test/Harness/Iterator.pm Test::Harness::Iterator (internal use only)
+lib/Test/Harness/Changes Test::Harness change log
lib/Test/Harness.pm A test harness
-lib/Test/Harness/Point.pm Test::Harness::Point (internal use only)
-lib/Test/Harness/Results.pm object for tracking results from a single test file
-lib/Test/Harness/Straps.pm Test::Harness::Straps
-lib/Test/Harness/t/00compile.t Test::Harness test
-lib/Test/Harness/TAP.pod Documentation for the Test Anything Protocol
-lib/Test/Harness/t/assert.t Test::Harness::Assert test
-lib/Test/Harness/t/base.t Test::Harness test
-lib/Test/Harness/t/callback.t Test::Harness test
-lib/Test/Harness/t/failure.t Test::Harness test
-lib/Test/Harness/t/from_line.t Test::Harness test
-lib/Test/Harness/t/harness.t Test::Harness test
-lib/Test/Harness/t/inc_taint.t Test::Harness test
-lib/Test/Harness/t/nonumbers.t Test::Harness test
-lib/Test/Harness/t/ok.t Test::Harness test
-lib/Test/Harness/t/point-parse.t Test::Harness test
-lib/Test/Harness/t/point.t Test::Harness test
-lib/Test/Harness/t/prove-globbing.t Test::Harness::Straps test
-lib/Test/Harness/t/prove-switches.t Test::Harness::Straps test
-lib/Test/Harness/t/strap-analyze.t Test::Harness::Straps test
-lib/Test/Harness/t/strap.t Test::Harness::Straps test
-lib/Test/Harness/t/test-harness.t Test::Harness test
-lib/Test/Harness/t/version.t Test::Harness test
-lib/Test/Harness/Util.pm Various utility functions for Test::Harness
+lib/Test/Harness/t/000-load.t Test::Harness test
+lib/Test/Harness/t/aggregator.t Test::Harness test
+lib/Test/Harness/t/bailout.t Test::Harness test
+lib/Test/Harness/t/base.t Test::Harness test
+lib/Test/Harness/t/callbacks.t Test::Harness test
+lib/Test/Harness/t/compat/env.t Test::Harness test
+lib/Test/Harness/t/compat/failure.t Test::Harness test
+lib/Test/Harness/t/compat/inc-propagation.t Test::Harness test
+lib/Test/Harness/t/compat/inc_taint.t Test::Harness test
+lib/Test/Harness/t/compat/nonumbers.t Test::Harness test
+lib/Test/Harness/t/compat/regression.t Test::Harness test
+lib/Test/Harness/t/compat/test-harness-compat.t Test::Harness test
+lib/Test/Harness/t/compat/version.t Test::Harness test
+lib/Test/Harness/t/console.t Test::Harness test
+lib/Test/Harness/t/errors.t Test::Harness test
+lib/Test/Harness/t/grammar.t Test::Harness test
+lib/Test/Harness/t/harness.t Test::Harness test
+lib/Test/Harness/t/iterators.t Test::Harness test
+lib/Test/Harness/t/multiplexer.t Test::Harness test
+lib/Test/Harness/t/nofork-mux.t Test::Harness test
+lib/Test/Harness/t/nofork.t Test::Harness test
+lib/Test/Harness/t/parse.t Test::Harness test
+lib/Test/Harness/t/premature-bailout.t Test::Harness test
+lib/Test/Harness/t/process.t Test::Harness test
+lib/Test/Harness/t/prove.t Test::Harness test
+lib/Test/Harness/t/proverc.t Test::Harness test
+lib/Test/Harness/t/proverun.t Test::Harness test
+lib/Test/Harness/t/regression.t Test::Harness test
+lib/Test/Harness/t/results.t Test::Harness test
+lib/Test/Harness/t/source.t Test::Harness test
+lib/Test/Harness/t/spool.t Test::Harness test
+lib/Test/Harness/t/state.t Test::Harness test
+lib/Test/Harness/t/streams.t Test::Harness test
+lib/Test/Harness/t/taint.t Test::Harness test
+lib/Test/Harness/t/testargs.t Test::Harness test
+lib/Test/Harness/t/unicode.t Test::Harness test
+lib/Test/Harness/t/yamlish-output.t Test::Harness test
+lib/Test/Harness/t/yamlish-writer.t Test::Harness test
+lib/Test/Harness/t/yamlish.t Test::Harness test
lib/Test/More.pm More utilities for writing tests
lib/Test.pm A simple framework for writing test scripts
lib/Test/Simple/Changes Test::Simple changes
@@ -3521,6 +3563,7 @@
t/lib/compress/zlib-generic.pl Compress::Zlib
t/lib/contains_pod.xr Pod-Parser test file
t/lib/cygwin.t Builtin cygwin function tests
+t/lib/App/Prove/Plugin/Dummy.pm Module for testing Test::Harness
t/lib/Devel/switchd.pm Module for t/run/switchd.t
t/lib/Dev/Null.pm Module for testing Test::Harness
t/lib/dprof/test1_t Perl code profiler tests
@@ -3554,6 +3597,7 @@
t/lib/h2ph.h Test header file for h2ph
t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison
t/lib/HasSigDie.pm Module for testing base.pm
+t/lib/IO/c55Capture.pm Module for testing Test::Harness
t/lib/locale/latin1 Part of locale.t in Latin 1
t/lib/locale/utf8 Part of locale.t in UTF8
t/lib/MakeMaker/Test/Setup/BFD.pm MakeMaker test utilities
@@ -3570,41 +3614,72 @@
t/lib/mypragma.pm An example user pragma
t/lib/mypragma.t Test the example user pragma
t/lib/NoExporter.pm Part of Test-Simple
+t/lib/NoFork.pm Module for testing Test::Harness
t/lib/no_load.t Test that some modules don't load others
t/lib/proxy_constant_subs.t Test that Proxy Constant Subs behave correctly
+t/lib/data/catme.1 Test data for Test::Harness
+t/lib/data/proverc Test data for Test::Harness
+t/lib/data/sample.yml Test data for Test::Harness
t/lib/sample-tests/bailout Test data for Test::Harness
t/lib/sample-tests/bignum Test data for Test::Harness
t/lib/sample-tests/bignum_many Test data for Test::Harness
t/lib/sample-tests/combined Test data for Test::Harness
+t/lib/sample-tests/combined_compat Test data for Test::Harness
+t/lib/sample-tests/delayed Test data for Test::Harness
t/lib/sample-tests/descriptive Test data for Test::Harness
+t/lib/sample-tests/descriptive_trailing Test data for Test::Harness
t/lib/sample-tests/die Test data for Test::Harness
t/lib/sample-tests/die_head_end Test data for Test::Harness
t/lib/sample-tests/die_last_minute Test data for Test::Harness
+t/lib/sample-tests/die_unfinished Test data for Test::Harness
t/lib/sample-tests/duplicates Test data for Test::Harness
+t/lib/sample-tests/echo Test data for Test::Harness
+t/lib/sample-tests/empty Test data for Test::Harness
+t/lib/sample-tests/escape_eol Test data for Test::Harness
+t/lib/sample-tests/escape_hash Test data for Test::Harness
t/lib/sample-tests/head_end Test data for Test::Harness
t/lib/sample-tests/head_fail Test data for Test::Harness
t/lib/sample-tests/inc_taint Test data for Test::Harness
+t/lib/sample-tests/junk_before_plan Test data for Test::Harness
t/lib/sample-tests/lone_not_bug Test data for Test::Harness
t/lib/sample-tests/no_nums Test data for Test::Harness
t/lib/sample-tests/no_output Test data for Test::Harness
+t/lib/sample-tests/out_err_mix Test data for Test::Harness
t/lib/sample-tests/out_of_order Test data for Test::Harness
+t/lib/sample-tests/schwern Test data for Test::Harness
+t/lib/sample-tests/schwern-todo-quiet Test data for Test::Harness
t/lib/sample-tests/segfault Test data for Test::Harness
+t/lib/sample-tests/sequence_misparse Test data for Test::Harness
t/lib/sample-tests/shbang_misparse Test data for Test::Harness
t/lib/sample-tests/simple Test data for Test::Harness
t/lib/sample-tests/simple_fail Test data for Test::Harness
+t/lib/sample-tests/simple_yaml Test data for Test::Harness
t/lib/sample-tests/skip Test data for Test::Harness
+t/lib/sample-tests/skip_nomsg Test data for Test::Harness
t/lib/sample-tests/skipall Test data for Test::Harness
t/lib/sample-tests/skipall_nomsg Test data for Test::Harness
-t/lib/sample-tests/skip_nomsg Test data for Test::Harness
+t/lib/sample-tests/skipall_v13 Test data for Test::Harness
+t/lib/sample-tests/space_after_plan Test data for Test::Harness
+t/lib/sample-tests/stdout_stderr Test data for Test::Harness
t/lib/sample-tests/switches Test data for Test::Harness
t/lib/sample-tests/taint Test data for Test::Harness
t/lib/sample-tests/taint_warn Test data for Test::Harness
t/lib/sample-tests/todo Test data for Test::Harness
t/lib/sample-tests/todo_inline Test data for Test::Harness
+t/lib/sample-tests/todo_misparse Test data for Test::Harness
t/lib/sample-tests/too_many Test data for Test::Harness
+t/lib/sample-tests/version_good Test data for Test::Harness
+t/lib/sample-tests/version_late Test data for Test::Harness
+t/lib/sample-tests/version_old Test data for Test::Harness
t/lib/sample-tests/vms_nit Test data for Test::Harness
t/lib/sample-tests/with_comments Test data for Test::Harness
t/lib/Sans_mypragma.pm Test module for t/lib/mypragma.t
+t/lib/source_tests/harness Test data for Test::Harness
+t/lib/source_tests/harness_badtap Test data for Test::Harness
+t/lib/source_tests/harness_complain Test data for Test::Harness
+t/lib/source_tests/harness_directives Test data for Test::Harness
+t/lib/source_tests/harness_failure Test data for Test::Harness
+t/lib/source_tests/source Test data for Test::Harness
t/lib/strict/refs Tests of "use strict 'refs'" for strict.t
t/lib/strict/subs Tests of "use strict 'subs'" for strict.t
t/lib/strict/vars Tests of "use strict 'vars'" for strict.t
==== //depot/maint-5.10/perl/Porting/Maintainers.pl#11 (text) ====
Index: perl/Porting/Maintainers.pl
--- perl/Porting/Maintainers.pl#10~33960~ 2008-05-31 07:19:17.000000000 -0700
+++ perl/Porting/Maintainers.pl 2008-05-31 07:30:09.000000000 -0700
@@ -14,6 +14,7 @@
'abigail' => 'Abigail <abigail@abigail.be>',
'ams' => 'Abhijit Menon-Sen <ams@cpan.org>',
'andk' => 'Andreas J. Koenig <andk@cpan.org>',
+ 'andya' => 'Andy Armstrong <andya@cpan.org>',
'arandal' => 'Allison Randal <allison@perl.org>',
'audreyt' => 'Audrey Tang <cpan@audreyt.org>',
'avar' => 'Ævar Arnfjörð Bjarmason <avar@cpan.org>',
@@ -861,9 +862,13 @@
'Test::Harness' =>
{
- 'MAINTAINER' => 'petdance',
- 'FILES' => q[lib/Test/Harness.pm lib/Test/Harness
- t/lib/sample-tests],
+ 'MAINTAINER' => 'andya',
+ 'FILES' => q[lib/App/Prove.pm lib/App/Prove/State.pm
+ lib/Test/Harness.pm lib/Test/Harness
+ t/lib/data t/lib/sample-tests
+ t/lib/source_tests t/lib/Dev/Null.pm
+ t/lib/App/Prove/Plugin/Dummy.pm
+ t/lib/IO/c55Capture.pm t/lib/NoFork.pm],
'CPAN' => 1,
},
==== //depot/maint-5.10/perl/lib/TAP/Base.pm#1 (text) ====
Index: perl/lib/TAP/Base.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Base.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,143 @@
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser> and L<TAP::Harness>
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+my $GOT_TIME_HIRES;
+
+BEGIN {
+ eval 'use Time::HiRes qw(time);';
+ $GOT_TIME_HIRES = $@ ? 0 : 1;
+}
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
+
+ # ... later ...
+
+ my $thing = TAP::Whatever->new();
+
+ $thing->callback( event => sub {
+ # do something interesting
+ } );
+
+=head1 DESCRIPTION
+
+C<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+
+ my $self = bless {}, $class;
+ return $self->_initialize($arg_for);
+}
+
+sub _initialize {
+ my ( $self, $arg_for, $ok_callback ) = @_;
+
+ my %ok_map = map { $_ => 1 } @$ok_callback;
+
+ $self->{ok_callbacks} = \%ok_map;
+
+ if ( my $cb = delete $arg_for->{callbacks} ) {
+ while ( my ( $event, $callback ) = each %$cb ) {
+ $self->callback( $event, $callback );
+ }
+ }
+
+ return $self;
+}
+
+=head3 C<callback>
+
+Install a callback for a named event.
+
+=cut
+
+sub callback {
+ my ( $self, $event, $callback ) = @_;
+
+ my %ok_map = %{ $self->{ok_callbacks} };
+
+ $self->_croak('No callbacks may be installed')
+ unless %ok_map;
+
+ $self->_croak( "Callback $event is not supported. Valid callbacks are "
+ . join( ', ', sort keys %ok_map ) )
+ unless exists $ok_map{$event};
+
+ push @{ $self->{code_for}{$event} }, $callback;
+
+ return;
+}
+
+sub _has_callbacks {
+ my $self = shift;
+ return keys %{ $self->{code_for} } != 0;
+}
+
+sub _callback_for {
+ my ( $self, $event ) = @_;
+ return $self->{code_for}{$event};
+}
+
+sub _make_callback {
+ my $self = shift;
+ my $event = shift;
+
+ my $cb = $self->_callback_for($event);
+ return unless defined $cb;
+ return map { $_->(@_) } @$cb;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ require Carp;
+ Carp::croak($message);
+
+ return;
+}
+
+=head3 C<get_time>
+
+Return the current time using Time::HiRes if available.
+
+=cut
+
+sub get_time { return time() }
+
+=head3 C<time_is_hires>
+
+Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
+
+=cut
+
+sub time_is_hires { return $GOT_TIME_HIRES }
+
+1;
==== //depot/maint-5.10/perl/lib/TAP/Formatter/Color.pm#1 (text) ====
Index: perl/lib/TAP/Formatter/Color.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Formatter/Color.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,145 @@
+package TAP::Formatter::Color;
+
+use strict;
+
+use vars qw($VERSION);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+
+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.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+Note that this harness is I<experimental>. You may not like the colors I've
+chosen and I haven't yet provided an easy way to override them.
+
+This test harness is the same as L<TAP::Harness>, but test results are output
+in color. Passing tests are printed in green. Failing tests are in red.
+Skipped tests are blue on a white background and TODO tests are printed in
+white.
+
+If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running
+under Windows) tests will be run without color.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Color;
+ my $harness = TAP::Formatter::Color->new( \%args );
+ $harness->runtests(@tests);
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor returns a new C<TAP::Formatter::Color> object. If
+L<Term::ANSIColor> is not installed, returns undef.
+
+=cut
+
+sub new {
+ my $class = 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;
+ }
+
+ return bless {}, $class;
+}
+
+##############################################################################
+
+=head3 C<can_color>
+
+ Test::Formatter::Color->can_color()
+
+Returns a boolean indicating whether or not this module can actually
+generate colored output. This will be false if it could not load the
+modules needed for the current platform.
+
+=cut
+
+sub can_color {
+ return !$NO_COLOR;
+}
+
+=head3 C<set_color>
+
+Set the output color.
+
+=cut
+
+1;
==== //depot/maint-5.10/perl/lib/TAP/Formatter/Console.pm#1 (text) ====
Index: perl/lib/TAP/Formatter/Console.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Formatter/Console.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,476 @@
+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
+ _tests_without_extensions
+ _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.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ $self->verbosity(0);
+
+ for my $name ( keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+ $self->$name( $self->$validate($property) );
+ }
+ }
+
+ if ( my @props = keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ $self->stdout( \*STDOUT ) unless $self->stdout;
+
+ if ( $self->color ) {
+ require TAP::Formatter::Color;
+ $self->_colorizer( TAP::Formatter::Color->new );
+ }
+
+ return $self;
+}
+
+sub verbose { shift->verbosity >= 1 }
+sub quiet { shift->verbosity <= -1 }
+sub really_quiet { shift->verbosity <= -2 }
+sub silent { shift->verbosity <= -3 }
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbose => 1,
+ )
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console> object. If
+a L<TAP::Harness> is created with no C<formatter> a
+C<TAP::Formatter::Console> is automatically created. If any of the
+following options were given to TAP::Harness->new they well be passed to
+this constructor which accepts an optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level.
+
+=item * C<verbose>
+
+Printing individual test results to STDOUT.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<quiet>
+
+Suppressing some test output (mostly failures while tests are running).
+
+=item * C<really_quiet>
+
+Suppressing everything but the tests summary.
+
+=item * C<silent>
+
+Suppressing all output.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be made
+in the summary report. To see all of the parse errors, set this argument to
+true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose> or C<failures>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> is not
+defined it will default to color output if color support is available on
+the current platform and output is not being redirected.
+
+=item * C<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+Called by Test::Harness before any test output is generated.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ my $tests_without_extensions = 0;
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ if ( $test !~ /\.\w+$/ ) {
+
+ # TODO: Coverage?
+ $tests_without_extensions = 1;
+ }
+ }
+
+ $self->_tests_without_extensions($tests_without_extensions);
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $extra = 0;
+ unless ( $self->_tests_without_extensions ) {
+ $name =~ s/(\.\w+)$//; # strip the .t or .pm
+ $extra = length $1;
+ }
+ my $periods = '.' x ( $self->_longest + $extra + 4 - length $test );
+
+ if ( $self->timer ) {
+ my $stamp = $self->_format_now();
+ return "$stamp $name$periods";
+ }
+ else {
+ return "$name$periods";
+ }
+
+}
+
+=head3 C<open_test>
+
+Called to create a new test session. A test session looks like this:
+
+ my $session = $formatter->open_test( $test, $parser );
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+ $session->close_test;
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $class
+ = $self->jobs > 1
+ ? 'TAP::Formatter::Console::ParallelSession'
+ : 'TAP::Formatter::Console::Session';
+
+ eval "require $class";
+ $self->_croak($@) if $@;
+
+ my $session = $class->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+=head3 C<summary>
+
+ $harness->summary( $aggregate );
+
+C<summary> prints the summary report after all tests are run. The argument is
+an aggregate.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+
+ return if $self->silent;
+
+ my @t = $aggregate->descriptions;
+ my $tests = \@t;
+
+ my $runtime = $aggregate->elapsed_timestr;
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+
+ if ( $self->timer ) {
+ $self->_output( $self->_format_now(), "\n" );
+ }
+
+ # TODO: Check this condition still works when all subtests pass but
+ # the exit status is nonzero
+
+ if ( $aggregate->all_passed ) {
+ $self->_output("All tests successful.\n");
+ }
+
+ # ~TODO option where $aggregate->skipped generates reports
+ if ( $total != $passed or $aggregate->has_problems ) {
+ $self->_output("\nTest Summary Report");
+ $self->_output("\n-------------------\n");
+ foreach my $test (@$tests) {
+ $self->_printed_summary_header(0);
+ my ($parser) = $aggregate->parsers($test);
+ $self->_output_summary_failure(
+ 'failed', " Failed test number(s): ",
+ $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 ( $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->$output($name);
+ my @results = $self->_balanced_range( 40, $parser->$method() );
+ $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;
==== //depot/maint-5.10/perl/lib/TAP/Formatter/Console/ParallelSession.pm#1 (text) ====
Index: perl/lib/TAP/Formatter/Console/ParallelSession.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Formatter/Console/ParallelSession.pm 2008-05-31 07:30:09.000000000 -0700
@@ -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.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for L<TAP::Harness::Parallel>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+Output test preamble
+
+=cut
+
+sub header {
+ my $self = shift;
+ $self->_need_refresh;
+}
+
+sub _refresh {
+}
+
+sub _clear_line {
+ my $self = shift;
+ $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
+}
+
+sub _output_ruler {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $context = $shared{$formatter};
+
+ my $ruler = sprintf( "===( %7d )", $context->{tests} );
+ $ruler .= ( '=' x ( WIDTH - length $ruler ) );
+ $formatter->_output("\r$ruler");
+}
+
+=head3 C<result>
+
+ Called by the harness for each line of TAP it receives .
+
+=cut
+
+sub result {
+ my ( $self, $result ) = @_;
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ $self->_refresh;
+
+ # my $really_quiet = $formatter->really_quiet;
+ # my $show_count = $self->_should_show_count;
+ my $planned = $parser->tests_planned;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ if ( $result->is_test ) {
+ $context->{tests}++;
+
+ my $test_print_modulus = 1;
+ my $ceiling = $context->{tests} / 5;
+ $test_print_modulus *= 2 while $test_print_modulus < $ceiling;
+
+ unless ( $context->{tests} % $test_print_modulus ) {
+ $self->_output_ruler;
+ }
+ }
+}
+
+=head3 C<close_test>
+
+=cut
+
+sub close_test {
+ my $self = shift;
+ my $name = $self->name;
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ unless ( $formatter->really_quiet ) {
+ $self->_clear_line;
+
+ # my $output = $self->_output_method;
+ $formatter->_output(
+ $formatter->_format_name( $self->name ),
+ ' '
+ );
+ }
+
+ if ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ $formatter->_output("ok\n")
+ unless $formatter->really_quiet;
+ }
+
+ $self->_output_ruler;
+
+ # $self->SUPER::close_test;
+ my $active = $context->{active};
+
+ my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
+
+ die "Can't find myself" unless @pos;
+ splice @$active, $pos[0], 1;
+
+ $self->_need_refresh;
+
+ unless (@$active) {
+
+ # $self->formatter->_output("\n");
+ delete $shared{$formatter};
+ }
+}
+
+1;
==== //depot/maint-5.10/perl/lib/TAP/Formatter/Console/Session.pm#1 (text) ====
Index: perl/lib/TAP/Formatter/Console/Session.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Formatter/Console/Session.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,330 @@
+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.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=back
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name (@ACCESSOR) {
+ $self->{$name} = delete $arg_for{$name};
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+
+ return $self;
+}
+
+=head3 C<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+Called to close a test session.
+
+=cut
+
+sub _get_output_result {
+ my $self = shift;
+
+ my @color_map = (
+ { test => sub { $_->is_test && !$_->is_ok },
+ colors => ['red'],
+ },
+ { test => sub { $_->is_test && $_->has_skip },
+ colors => [
+ 'white',
+ 'on_blue'
+ ],
+ },
+ { test => sub { $_->is_test && $_->has_todo },
+ colors => ['yellow'],
+ },
+ );
+
+ my $formatter = $self->formatter;
+ my $parser = $self->parser;
+
+ return $formatter->_colorizer
+ ? sub {
+ my $result = shift;
+ for my $col (@color_map) {
+ local $_ = $result;
+ if ( $col->{test}->() ) {
+ $formatter->_set_colors( @{ $col->{colors} } );
+ last;
+ }
+ }
+ $formatter->_output( $result->as_string );
+ $formatter->_set_colors('reset');
+ }
+ : sub {
+ $formatter->_output( shift->as_string );
+ };
+}
+
+sub _closures {
+ my $self = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $show_count = $self->_should_show_count;
+ my $pretty = $formatter->_format_name( $self->name );
+
+ my $really_quiet = $formatter->really_quiet;
+ my $quiet = $formatter->quiet;
+ my $verbose = $formatter->verbose;
+ my $directives = $formatter->directives;
+ my $failures = $formatter->failures;
+
+ my $output_result = $self->_get_output_result;
+
+ my $output = '_output';
+ my $plan = '';
+ my $newline_printed = 0;
+
+ my $last_status_printed = 0;
+
+ return {
+ header => sub {
+ $formatter->_output($pretty)
+ unless $really_quiet;
+ },
+
+ result => sub {
+ my $result = shift;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ return if $really_quiet;
+
+ my $is_test = $result->is_test;
+
+ # These are used in close_test - but only if $really_quiet
+ # is false - so it's safe to only set them here unless that
+ # relationship changes.
+
+ if ( !$plan ) {
+ my $planned = $parser->tests_planned || '?';
+ $plan = "/$planned ";
+ }
+ $output = $formatter->_get_output_method($parser);
+
+ if ( $show_count and $is_test ) {
+ my $number = $result->number;
+ my $now = CORE::time;
+
+ # Print status on first number, and roughly once per second
+ if ( ( $number == 1 )
+ || ( $last_status_printed != $now ) )
+ {
+ $formatter->$output("\r$pretty$number$plan");
+ $last_status_printed = $now;
+ }
+ }
+
+ if (!$quiet
+ && ( ( $verbose && !$failures )
+ || ( $is_test && $failures && !$result->is_ok )
+ || ( $result->has_directive && $directives ) )
+ )
+ {
+ unless ($newline_printed) {
+ $formatter->_output("\n");
+ $newline_printed = 1;
+ }
+ $output_result->($result);
+ $formatter->_output("\n");
+ }
+ },
+
+ close_test => sub {
+ return if $really_quiet;
+
+ if ($show_count) {
+ my $spaces = ' ' x
+ length( '.' . $pretty . $plan . $parser->tests_run );
+ $formatter->$output("\r$spaces\r$pretty");
+ }
+
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output("skipped: $skip_all\n");
+ }
+ elsif ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output("ok$time_report\n");
+ }
+ },
+ };
+}
+
+sub _should_show_count {
+
+ # we need this because if someone tries to redirect the output, it can get
+ # very garbled from the carriage returns (\r) in the count line.
+ return !shift->formatter->verbose && -t STDOUT;
+}
+
+sub _output_test_failure {
+ my ( $self, $parser ) = @_;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $tests_run = $parser->tests_run;
+ my $tests_planned = $parser->tests_planned;
+
+ my $total
+ = defined $tests_planned
+ ? $tests_planned
+ : $tests_run;
+
+ my $passed = $parser->passed;
+
+ # The total number of fails includes any tests that were planned but
+ # didn't run
+ my $failed = $parser->failed + $total - $tests_run;
+ my $exit = $parser->exit;
+
+ # TODO: $flist isn't used anywhere
+ # my $flist = join ", " => $formatter->range( $parser->failed );
+
+ 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;
==== //depot/maint-5.10/perl/lib/TAP/Harness.pm#1 (text) ====
Index: perl/lib/TAP/Harness.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Harness.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,666 @@
+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 vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run test scripts with statistics
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+$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 },
+ );
+
+ for my $method ( sort keys %VALIDATION_FOR ) {
+ no strict 'refs';
+ if ( $method eq 'lib' || $method eq 'switches' ) {
+ *{$method} = sub {
+ my $self = shift;
+ unless (@_) {
+ $self->{$method} ||= [];
+ return wantarray
+ ? @{ $self->{$method} }
+ : $self->{$method};
+ }
+ $self->_croak("Too many arguments to method '$method'")
+ if @_ > 1;
+ my $args = shift;
+ $args = [$args] unless ref $args;
+ $self->{$method} = $args;
+ return $self;
+ };
+ }
+ else {
+ *{$method} = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+
+ for my $method (@FORMATTER_ARGS) {
+ no strict 'refs';
+ *{$method} = sub {
+ my $self = shift;
+ return $self->formatter->$method(@_);
+ };
+ }
+}
+
+##############################################################################
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbosity => 1,
+ lib => [ 'lib', 'blib/lib' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an optional
+hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level:
+
+ 1 verbose Print individual test results to STDOUT.
+ 0 normal
+ -1 quiet Suppress some test output (mostly failures
+ while tests are running).
+ -2 really quiet Suppress everything but the tests summary.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<lib>
+
+Accepts a scalar value or array ref of scalar values indicating which paths to
+allowed libraries should be included if Perl tests are executed. Naturally,
+this only makes sense in the context of tests written in Perl.
+
+=item * C<switches>
+
+Accepts a scalar value or array ref of scalar values indicating which switches
+should be included if Perl tests are executed. Naturally, this only makes
+sense in the context of tests written in Perl.
+
+=item * C<test_args>
+
+A reference to an C<@INC> style array of arguments to be passed to each
+test program.
+
+=item * C<color>
+
+Attempt to produce color output.
+
+=item * C<exec>
+
+Typically, Perl tests are run through this. However, anything which spits out
+TAP is fine. You can use this argument to specify the name of the program
+(and optional switches) to run your tests with:
+
+ exec => ['/usr/bin/ruby', '-w']
+
+=item * C<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting the
+TAP output. See L<TAP::Formatter::Console> for an example.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be made
+in the summary report. To see all of the parse errors, set this argument to
+true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose> or C<failures>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+{
+ my @legal_callback = qw(
+ parser_args
+ made_parser
+ before_runtests
+ after_runtests
+ after_test
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name ( sort keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+
+ my $value = $self->$validate($property);
+ if ( $self->_error ) {
+ $self->_croak;
+ }
+ $self->$name($value);
+ }
+ }
+
+ $self->jobs(1) unless defined $self->jobs;
+
+ unless ( $self->formatter ) {
+
+ $self->formatter_class( my $class = $self->formatter_class
+ || 'TAP::Formatter::Console' );
+
+ croak "Bad module name $class"
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ eval "require $class";
+ $self->_croak("Can't load $class") if $@;
+
+ # This is a little bodge to preserve legacy behaviour. It's
+ # pretty horrible that we know which args are destined for
+ # the formatter.
+ my %formatter_args = ( jobs => $self->jobs );
+ for my $name (@FORMATTER_ARGS) {
+ if ( defined( my $property = delete $arg_for{$name} ) ) {
+ $formatter_args{$name} = $property;
+ }
+ }
+
+ $self->formatter( $class->new( \%formatter_args ) );
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+
+ return $self;
+ }
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<runtests>
+
+ $harness->runtests(@tests);
+
+Accepts and array of C<@tests> to be run. This should generally be the names
+of test files, but this is not required. Each element in C<@tests> will be
+passed to C<TAP::Parser::new()> as a C<source>. See L<TAP::Parser> for more
+information.
+
+It is possible to provide aliases that will be displayed in place of the
+test name by supplying the test as a reference to an array containing
+C<< [ $test, $alias ] >>:
+
+ $harness->runtests( [ 't/foo.t', 'Foo Once' ],
+ [ 't/foo.t', 'Foo Twice' ] );
+
+Normally it is an error to attempt to run the same test twice. Aliases
+allow you to overcome this limitation by giving each run of the test a
+unique name.
+
+Tests will be run in the order found.
+
+If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
+should name a directory into which a copy of the raw TAP for each test
+will be written. TAP is written to files named for each test.
+Subdirectories will be created as needed.
+
+Returns a L<TAP::Parser::Aggregator> containing the test results.
+
+=cut
+
+sub runtests {
+ my ( $self, @tests ) = @_;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+ $self->_make_callback( 'before_runtests', $aggregate );
+ $self->aggregate_tests( $aggregate, @tests );
+ $self->formatter->summary($aggregate);
+ $self->_make_callback( 'after_runtests', $aggregate );
+
+ return $aggregate;
+}
+
+=head3 C<aggregate_tests>
+
+ $harness->aggregate_tests( $aggregate, @tests );
+
+Tests will be run in the order found.
+
+=cut
+
+sub _after_test {
+ my ( $self, $aggregate, $test, $parser ) = @_;
+
+ $self->_make_callback( 'after_test', $test, $parser );
+ $aggregate->add( $test->[1], $parser );
+}
+
+sub _aggregate_forked {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ eval { require Parallel::Iterator };
+
+ croak "Parallel::Iterator required for --fork option ($@)"
+ if $@;
+
+ my $iter = Parallel::Iterator::iterate(
+ { workers => $self->jobs || 0 },
+ sub {
+ my ( $id, $test ) = @_;
+
+ my ( $parser, $session ) = $self->make_parser($test);
+
+ 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;
+ },
+ \@tests
+ );
+
+ while ( my ( $id, $parser ) = $iter->() ) {
+ $self->_after_test( $aggregate, $tests[$id], $parser );
+ }
+
+ return;
+}
+
+sub _aggregate_parallel {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $jobs = $self->jobs;
+ my $mux = TAP::Parser::Multiplexer->new;
+
+ RESULT: {
+
+ # Keep multiplexer topped up
+ while ( @tests && $mux->parsers < $jobs ) {
+ my $test = shift @tests;
+ my ( $parser, $session ) = $self->make_parser($test);
+ $mux->add( $parser, [ $session, $test ] );
+ }
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ my ( $session, $test ) = @$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, $test, $parser );
+ }
+ redo RESULT;
+ }
+ }
+
+ return;
+}
+
+sub _aggregate_single {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ for my $test (@tests) {
+ my ( $parser, $session ) = $self->make_parser($test);
+
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $test, $parser );
+ }
+
+ return;
+}
+
+sub aggregate_tests {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $jobs = $self->jobs;
+
+ my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests;
+
+ # Formatter gets only names
+ $self->formatter->prepare( map { $_->[1] } @expanded );
+ $aggregate->start;
+
+ if ( $self->jobs > 1 ) {
+ if ( $self->fork ) {
+ $self->_aggregate_forked( $aggregate, @expanded );
+ }
+ else {
+ $self->_aggregate_parallel( $aggregate, @expanded );
+ }
+ }
+ else {
+ $self->_aggregate_single( $aggregate, @expanded );
+ }
+
+ $aggregate->stop;
+
+ return;
+}
+
+=head3 C<jobs>
+
+Returns the number of concurrent test runs the harness is handling. For the default
+harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel>
+will override this to return the number of jobs it is handling.
+
+=head3 C<fork>
+
+If true the harness will attempt to fork and run the parser for each
+test in a separate process. Currently this option requires
+L<Parallel::Iterator> to be installed.
+
+=cut
+
+##############################################################################
+
+=head1 SUBCLASSING
+
+C<TAP::Harness> is designed to be (mostly) easy to subclass. If you don't
+like how a particular feature functions, just override the desired methods.
+
+=head2 Methods
+
+TODO: This is out of date
+
+The following methods are ones you may wish to override if you want to
+subclass C<TAP::Harness>.
+
+=head3 C<summary>
+
+ $harness->summary( \%args );
+
+C<summary> prints the summary report after all tests are run. The argument is
+a hashref with the following keys:
+
+=over 4
+
+=item * C<start>
+
+This is created with C<< Benchmark->new >> and it the time the tests started.
+You can print a useful summary time, if desired, with:
+
+ $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' ));
+
+=item * C<tests>
+
+This is an array reference of all test names. To get the L<TAP::Parser>
+object for individual tests:
+
+ my $aggregate = $args->{aggregate};
+ my $tests = $args->{tests};
+
+ for my $name ( @$tests ) {
+ my ($parser) = $aggregate->parsers($test);
+ ... do something with $parser
+ }
+
+This is a bit clunky and will be cleaned up in a later release.
+
+=back
+
+=cut
+
+sub _get_parser_args {
+ my ( $self, $test ) = @_;
+ my $test_prog = $test->[0];
+ 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{exec} = $self->exec;
+
+ if ( my $exec = $self->exec ) {
+ $args{exec} = [ @$exec, $test_prog ];
+ }
+ else {
+ $args{source} = $test_prog;
+ }
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ return \%args;
+}
+
+=head3 C<make_parser>
+
+Make a new parser and display formatter session. Typically used and/or
+overridden in subclasses.
+
+ my ( $parser, $session ) = $harness->make_parser;
+
+
+=cut
+
+sub make_parser {
+ my ( $self, $test ) = @_;
+
+ my $args = $self->_get_parser_args($test);
+ $self->_make_callback( 'parser_args', $args, $test );
+ my $parser = TAP::Parser->new($args);
+
+ $self->_make_callback( 'made_parser', $parser, $test );
+ my $session = $self->formatter->open_test( $test->[1], $parser );
+
+ return ( $parser, $session );
+}
+
+=head3 C<finish_parser>
+
+Terminate use of a parser. Typically used and/or overridden in
+subclasses. The parser isn't destroyed as a result of this.
+
+=cut
+
+sub finish_parser {
+ my ( $self, $parser, $session ) = @_;
+
+ $session->close_test;
+ $self->_close_spool($parser);
+
+ return $parser;
+}
+
+sub _open_spool {
+ my $self = shift;
+ my $test = shift;
+
+ if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
+
+ my $spool = File::Spec->catfile( $spool_dir, $test );
+
+ # Make the directory
+ my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
+ my $path = File::Spec->catpath( $vol, $dir, '' );
+ eval { mkpath($path) };
+ $self->_croak($@) if $@;
+
+ my $spool_handle = IO::Handle->new;
+ open( $spool_handle, ">$spool" )
+ or $self->_croak(" Can't write $spool ( $! ) ");
+
+ return $spool_handle;
+ }
+
+ return;
+}
+
+sub _close_spool {
+ my $self = shift;
+ my ($parser) = @_;
+
+ if ( my $spool_handle = $parser->delete_spool ) {
+ close($spool_handle)
+ or $self->_croak(" Error closing TAP spool file( $! ) \n ");
+ }
+
+ return;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ unless ($message) {
+ $message = $self->_error;
+ }
+ $self->SUPER::_croak($message);
+
+ return;
+}
+
+=head1 REPLACING
+
+If you like the C<prove> utility and L<TAP::Parser> but you want your
+own harness, all you need to do is write one and provide C<new> and
+C<runtests> methods. Then you can use the C<prove> utility like so:
+
+ prove --harness My::Test::Harness
+
+Note that while C<prove> accepts a list of tests (or things to be
+tested), C<new> has a fairly rich set of arguments. You'll probably want
+to read over this code carefully to see how all of them are being used.
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
==== //depot/maint-5.10/perl/lib/TAP/Parser.pm#1 (text) ====
Index: perl/lib/TAP/Parser.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Parser.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,1551 @@
+package TAP::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Base ();
+use TAP::Parser::Grammar ();
+use TAP::Parser::Result ();
+use TAP::Parser::Source ();
+use TAP::Parser::Source::Perl ();
+use TAP::Parser::Iterator ();
+use Carp ();
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+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
+ _grammar
+ exec
+ exit
+ is_good_plan
+ plan
+ tests_planned
+ tests_run
+ wait
+ version
+ in_todo
+ start_time
+ end_time
+ skip_all
+ )
+ )
+ {
+ no strict 'refs';
+
+ # another tiny performance hack
+ if ( $method =~ /^_/ ) {
+ *$method = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+
+ # Trusted methods
+ unless ( ( ref $self ) =~ /^TAP::Parser/ ) {
+ Carp::croak("$method() may not be set externally");
+ }
+
+ $self->{$method} = shift;
+ };
+ }
+ else {
+ *$method = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+} # done making accessors
+
+=head1 SYNOPSIS
+
+ use TAP::Parser;
+
+ my $parser = TAP::Parser->new( { source => $source } );
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser> is designed to produce a proper parse of TAP output. For
+an example of how to run tests through this module, see the simple
+harnesses C<examples/>.
+
+There's a wiki dedicated to the Test Anything Protocol:
+
+L<http://testanything.org>
+
+It includes the TAP::Parser Cookbook:
+
+L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $parser = TAP::Parser->new(\%args);
+
+Returns a new C<TAP::Parser> object.
+
+The arguments should be a hashref with I<one> of the following keys:
+
+=over 4
+
+=item * C<source>
+
+This is the preferred method of passing arguments to the constructor. To
+determine how to handle the source, the following steps are taken.
+
+If the source contains a newline, it's assumed to be a string of raw TAP
+output.
+
+If the source is a reference, it's assumed to be something to pass to
+the L<TAP::Parser::Iterator::Stream> constructor. This is used
+internally and you should not use it.
+
+Otherwise, the parser does a C<-e> check to see if the source exists. If so,
+it attempts to execute the source and read the output as a stream. This is by
+far the preferred method of using the parser.
+
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new( { source => $file } );
+ # do stuff with the parser
+ }
+
+=item * C<tap>
+
+The value should be the complete TAP output.
+
+=item * C<exec>
+
+If passed an array reference, will attempt to create the iterator by
+passing a L<TAP::Parser::Source> object to
+L<TAP::Parser::Iterator::Source>, using the array reference strings as
+the command arguments to L<IPC::Open3::open3|IPC::Open3>:
+
+ exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
+
+Note that C<source> and C<exec> are mutually exclusive.
+
+=back
+
+The following keys are optional.
+
+=over 4
+
+=item * C<callback>
+
+If present, each callback corresponding to a given result type will be called
+with the result as the argument if the C<run> method is used:
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+=item * C<switches>
+
+If using a Perl file as a source, optional switches may be passed which will
+be used when invoking the perl executable.
+
+ my $parser = TAP::Parser->new( {
+ source => $test_file,
+ switches => '-Ilib',
+ } );
+
+=item * C<test_args>
+
+Used in conjunction with the C<source> option to supply a reference to
+an C<@ARGV> style array of arguments to pass to the test program.
+
+=item * C<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+If false, STDERR is not captured (though it is 'relayed' to keep it
+somewhat synchronized with STDOUT.)
+
+If true, STDERR and STDOUT are the same filehandle. This may cause
+breakage if STDERR contains anything resembling TAP format, but does
+allow exact synchronization.
+
+Subtleties of this behavior may be platform-dependent and may change in
+the future.
+
+=back
+
+=cut
+
+# new implementation supplied by TAP::Base
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ my $parser = TAP::Parser->new( { source => $file } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This method returns the results of the parsing, one result at a time. Note
+that it is destructive. You can't rewind and examine previous results.
+
+If callbacks are used, they will be issued before this call returns.
+
+Each result returned is a subclass of L<TAP::Parser::Result>. See that
+module and related classes for more information on how to use them.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+##############################################################################
+
+=head3 C<run>
+
+ $parser->run;
+
+This method merely runs the parser and parses all of the TAP.
+
+=cut
+
+sub run {
+ my $self = shift;
+ while ( defined( my $result = $self->next ) ) {
+
+ # do nothing
+ }
+}
+
+{
+
+ # 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
+ );
+
+ 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 );
+
+ 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 @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 = TAP::Parser::Iterator->new( [ split "\n" => $tap ] );
+ }
+ elsif ($exec) {
+ my $source = TAP::Parser::Source->new;
+ $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 = TAP::Parser::Iterator->new($source);
+ }
+ elsif ( -e $source ) {
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+ $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);
+ my $grammar = TAP::Parser::Grammar->new($stream);
+ $grammar->set_version( $self->version );
+ $self->_grammar($grammar);
+ $self->_spool($spool);
+
+ $self->start_time( $self->get_time );
+
+ return $self;
+ }
+}
+
+=head1 INDIVIDUAL RESULTS
+
+If you've read this far in the docs, you've seen this:
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+Each result returned is a L<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=head2 Result types
+
+Basically, you fetch individual results from the TAP. The six types, with
+examples of each, are as follows:
+
+=over 4
+
+=item * Version
+
+ TAP version 12
+
+=item * Plan
+
+ 1..42
+
+=item * Test
+
+ ok 3 - We should start with some foobar!
+
+=item * Comment
+
+ # Hope we don't use up the foobar.
+
+=item * Bailout
+
+ Bail out! We ran out of foobar!
+
+=item * Unknown
+
+ ... yo, this ain't TAP! ...
+
+=back
+
+Each result fetched is a result object of a different type. There are common
+methods to each result object and different types may have methods unique to
+their type. Sometimes a type method may be overridden in a subclass, but its
+use is guaranteed to be identical.
+
+=head2 Common type methods
+
+=head3 C<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+Indicates whether or not this is a comment. Comments will generally only
+appear in the TAP stream if STDERR is merged to STDOUT. See the
+C<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut
+which allows you to do this:
+
+ my $parser = TAP::Parser->new( { source => $source } );
+ while ( my $result = $parser->next ) {
+ # only print failing results
+ print $result->as_string unless $result->is_ok;
+ }
+
+=head2 C<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<tests_planned>
+
+ my $planned = $result->tests_planned;
+
+Returns the number of tests planned. For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=head2 C<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+B<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ if ( $parser->in_todo ) { ... }
+
+True while the most recent result was a TODO. Becomes true before the
+TODO result is returned and stays true until just before the next non-
+TODO test is returned.
+
+=head1 TOTAL RESULTS
+
+After parsing the TAP, there are many methods available to let you dig through
+the results and determine what is meaningful to you.
+
+=head2 Individual Results
+
+These results refer to individual tests which are run.
+
+=head3 C<passed>
+
+ my @passed = $parser->passed; # the test numbers which passed
+ my $passed = $parser->passed; # the number of tests which passed
+
+This method lets you know which (or how many) tests passed. If a test failed
+but had a TODO directive, it will be counted as a passed test.
+
+=cut
+
+sub passed { @{ shift->{passed} } }
+
+=head3 C<failed>
+
+ my @failed = $parser->failed; # the test numbers which failed
+ my $failed = $parser->failed; # the number of tests which failed
+
+This method lets you know which (or how many) tests failed. If a test passed
+but had a TODO directive, it will B<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # the test numbers which actually passed
+ my @actual_passed = $parser->actual_passed;
+
+ # the number of tests which actually passed
+ my $actual_passed = $parser->actual_passed;
+
+This method lets you know which (or how many) tests actually passed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_passed { @{ shift->{actual_passed} } }
+*actual_ok = \&actual_passed;
+
+=head3 C<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # the test numbers which actually failed
+ my @actual_failed = $parser->actual_failed;
+
+ # the number of tests which actually failed
+ my $actual_failed = $parser->actual_failed;
+
+This method lets you know which (or how many) tests actually failed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_failed { @{ shift->{actual_failed} } }
+
+##############################################################################
+
+=head3 C<todo>
+
+ my @todo = $parser->todo; # the test numbers with todo directives
+ my $todo = $parser->todo; # the number of tests with todo directives
+
+This method lets you know which (or how many) tests had TODO directives.
+
+=cut
+
+sub todo { @{ shift->{todo} } }
+
+=head3 C<todo_passed>
+
+ # the test numbers which unexpectedly succeeded
+ my @todo_passed = $parser->todo_passed;
+
+ # the number of tests which unexpectedly succeeded
+ my $todo_passed = $parser->todo_passed;
+
+This method lets you know which (or how many) tests actually passed but were
+declared as "TODO" tests.
+
+=cut
+
+sub todo_passed { @{ shift->{todo_passed} } }
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ my @skipped = $parser->skipped; # the test numbers with SKIP directives
+ my $skipped = $parser->skipped; # the number of tests with SKIP directives
+
+This method lets you know which (or how many) tests had SKIP directives.
+
+=cut
+
+sub skipped { @{ shift->{skipped} } }
+
+=head2 Summary Results
+
+These results are "meta" information about the total results of an individual
+test program.
+
+=head3 C<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ if ( $parser->is_good_plan ) { ... }
+
+Returns a boolean value indicating whether or not the number of tests planned
+matches the number of tests run.
+
+B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ print $parser->tests_planned;
+
+Returns the number of tests planned, according to the plan. For example, a
+plan of '1..17' will mean that 17 tests were planned.
+
+=head3 C<tests_run>
+
+ print $parser->tests_run;
+
+Returns the number of tests which actually were run. Hopefully this will
+match the number of C<< $parser->tests_planned >>.
+
+=head3 C<skip_all>
+
+Returns a true value (actually the reason for skipping) if all tests
+were skipped.
+
+=head3 C<start_time>
+
+Returns the time when the Parser was created.
+
+=head3 C<end_time>
+
+Returns the time when the end of TAP input was seen.
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+This is a 'catch-all' method which returns true if any tests have currently
+failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->failed
+ || $self->parse_errors
+ || $self->wait
+ || $self->exit;
+}
+
+=head3 C<version>
+
+ $parser->version;
+
+Once the parser is done, this will return the version number for the
+parsed TAP. Version numbers were introduced with TAP version 13 so if no
+version number is found version 12 is assumed.
+
+=head3 C<exit>
+
+ $parser->exit;
+
+Once the parser is done, this will return the exit status. If the parser ran
+an executable, it returns the exit status of the executable.
+
+=head3 C<wait>
+
+ $parser->wait;
+
+Once the parser is done, this will return the wait status. If the parser ran
+an executable, it returns the wait status of the executable. Otherwise, this
+mererely returns the C<exit> status.
+
+=head3 C<parse_errors>
+
+ my @errors = $parser->parse_errors; # the parser errors
+ my $errors = $parser->parse_errors; # the number of parser_errors
+
+Fortunately, all TAP output is perfect. In the event that it is not, this
+method will return parser errors. Note that a junk line which the parser does
+not recognize is C<not> an error. This allows this parser to handle future
+versions of TAP. The following are all TAP errors reported by the parser:
+
+=over 4
+
+=item * Misplaced plan
+
+The plan (for example, '1..5'), must only come at the beginning or end of the
+TAP output.
+
+=item * No plan
+
+Gotta have a plan!
+
+=item * More than one plan
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+ 1..3
+
+Right. Very funny. Don't do that.
+
+=item * Test numbers out of sequence
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+That last test line above should have the number '3' instead of '2'.
+
+Note that it's perfectly acceptable for some lines to have test numbers and
+others to not have them. However, when a test number is found, it must be in
+sequence. The following is also an error:
+
+ 1..3
+ ok 1 - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+But this is not:
+
+ 1..3
+ ok - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+
+=back
+
+=cut
+
+sub parse_errors { @{ shift->{parse_errors} } }
+
+sub _add_error {
+ my ( $self, $error ) = @_;
+ push @{ $self->{parse_errors} } => $error;
+ return $self;
+}
+
+sub _make_state_table {
+ my $self = shift;
+ my %states;
+ my %planned_todo = ();
+
+ #Â These transitions are defaults for all states
+ my %state_globals = (
+ comment => {},
+ bailout => {},
+ version => {
+ act => sub {
+ my ($version) = @_;
+ $self->_add_error(
+ 'If TAP version is present it must be the first line of output'
+ );
+ },
+ },
+ );
+
+ # 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 ( sort keys %states ) {
+
+ # Merge with globals
+ my $st = { %state_globals, %{ $states{$name} } };
+
+ # Add defaults
+ for my $next ( sort keys %{$st} ) {
+ if ( my $default = $state_defaults{$next} ) {
+ for my $def ( sort keys %{$default} ) {
+ $st->{$next}->{$def} ||= $default->{$def};
+ }
+ }
+ }
+
+ # Stuff back in table
+ $states{$name} = $st;
+ }
+
+ return \%states;
+}
+
+=head3 C<get_select_handles>
+
+Get an a list of file handles which can be passed to C<select> to
+determine the readiness of this parser.
+
+=cut
+
+sub get_select_handles { shift->_stream->get_select_handles }
+
+sub _iter {
+ my $self = shift;
+ my $stream = $self->_stream;
+ my $spool = $self->_spool;
+ my $grammar = $self->_grammar;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ my $count = 1;
+ TRANS: {
+ my $state_spec = $state_table->{$state}
+ or die "Illegal state: $state";
+
+ if ( my $next = $state_spec->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $act->($token);
+ }
+ if ( my $cont = $next->{continue} ) {
+ $state = $cont;
+ redo TRANS;
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $state = $goto;
+ }
+ }
+ }
+ return $token;
+ };
+
+ # Handle end of stream - which means either pop a block or finish
+ my $end_handler = sub {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ return;
+ };
+
+ # Finally make the closure that we return. For performance reasons
+ # there are two versions of the returned function: one that handles
+ # callbacks and one that does not.
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $_->($result) for @{$code};
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ $self->_make_callback( 'EOF', $result )
+ unless defined $result;
+ }
+
+ return $result;
+ };
+ } # _has_callbacks
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ }
+
+ return $result;
+ };
+ } # no callbacks
+}
+
+sub _finish {
+ my $self = shift;
+
+ $self->end_time( $self->get_time );
+
+ # sanity checks
+ if ( !$self->plan ) {
+ $self->_add_error('No plan found in TAP output');
+ }
+ else {
+ $self->is_good_plan(1) unless defined $self->is_good_plan;
+ }
+ if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
+ $self->is_good_plan(0);
+ if ( defined( my $planned = $self->tests_planned ) ) {
+ my $ran = $self->tests_run;
+ $self->_add_error(
+ "Bad plan. You planned $planned tests but ran $ran.");
+ }
+ }
+ if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
+
+ # this should never happen
+ my $actual = $self->tests_run;
+ my $passed = $self->passed;
+ my $failed = $self->failed;
+ $self->_croak( "Panic: planned test count ($actual) did not equal "
+ . "sum of passed ($passed) and failed ($failed) tests!" );
+ }
+
+ $self->is_good_plan(0) unless defined $self->is_good_plan;
+ return $self;
+}
+
+=head3 C<delete_spool>
+
+Delete and return the spool.
+
+ my $fh = $parser->delete_spool;
+
+=cut
+
+sub delete_spool {
+ my $self = shift;
+
+ return delete $self->{_spool};
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will
+be invoked. Thus, if all of the previous result types are specified as
+callbacks, this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is no
+accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO
+lists in the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was
+listed as a TODO test on the plan line. However, we are not aware of
+anyone actually using this feature and hard-coding test numbers is
+discouraged because it's very easy to add a test and break the test
+number sequence. This makes test suites very fragile. Instead, the
+following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter
+'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've
+never run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral
+support, or just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid@cpan.org>
+
+Andy Armstong <andy@hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+Michael Peters <mpeters at plusthree dot com>
+
+Leif Eriksen <leif dot eriksen at bigpond dot com>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-tapx-parser@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
+We will be notified, and then you'll automatically be notified of
+progress on your bug as we make changes.
+
+Obviously, bugs which include patches are best. If you prefer, you can
+patch against bleed by via anonymous checkout of the latest version:
+
+ svn checkout http://svn.hexten.net/tapx
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006-2007 Curtis "Ovid" Poe, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
==== //depot/maint-5.10/perl/lib/TAP/Parser/Aggregator.pm#1 (text) ====
Index: perl/lib/TAP/Parser/Aggregator.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Parser/Aggregator.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,410 @@
+package TAP::Parser::Aggregator;
+
+use strict;
+use Benchmark;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Aggregator;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+ $aggregate->add( 't/00-load.t', $load_parser );
+ $aggregate->add( 't/10-lex.t', $lex_parser );
+
+ my $summary = <<'END_SUMMARY';
+ Passed: %s
+ Failed: %s
+ Unexpectedly succeeded: %s
+ END_SUMMARY
+ printf $summary,
+ scalar $aggregate->passed,
+ scalar $aggregate->failed,
+ scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+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 new {
+ my ($class) = @_;
+ my $self = bless {}, $class;
+ $self->_initialize;
+ return $self;
+}
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.) It is used as a unique identifier (see e.g.
+L<"parsers">.) Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak( "You already have a parser for ($description)."
+ . " Perhaps you have run the same test twice." );
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method. Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->_get_parsers(@_) if @_;
+ my $descriptions = $self->{parse_order};
+ my @parsers = @{ $self->{parser_for} }{@$descriptions};
+
+ # Note: Because of the way context works, we must assign the parsers to
+ # the @parsers array or else this method does not work as documented.
+ return @parsers;
+}
+
+sub _get_parsers {
+ my ( $self, @descriptions ) = @_;
+ my @parsers;
+ foreach my $description (@descriptions) {
+ $self->_croak("A parser for ($description) could not be found")
+ unless exists $self->{parser_for}{$description};
+ push @parsers => $self->{parser_for}{$description};
+ }
+ return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+ my $self = shift;
+ $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+ my $self = shift;
+ $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+ my $self = shift;
+
+ require Carp;
+ Carp::croak
+ q{Can't call elapsed without first calling start and then stop}
+ unless defined $self->{start_time} && defined $self->{end_time};
+ return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>. This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+ my $self = shift;
+
+ my $elapsed = $self->elapsed;
+
+ return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+ my $self = shift;
+ return $self->total
+ && $self->total == $self->passed
+ && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+ my $self = shift;
+
+ my $total = $self->total;
+ my $passed = $self->passed;
+
+ return
+ ( $self->has_errors || $total != $passed ) ? 'FAIL'
+ : $total ? 'PASS'
+ : 'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded. This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->todo_passed
+ || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+ if ( $parser->has_errors ) {
+ ...
+ }
+
+Returns true if I<any> of the parsers failed. This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse erros
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ return $self->failed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
==== //depot/maint-5.10/perl/lib/TAP/Parser/Grammar.pm#1 (text) ====
Index: perl/lib/TAP/Parser/Grammar.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/TAP/Parser/Grammar.pm 2008-05-31 07:30:09.000000000 -0700
@@ -0,0 +1,526 @@
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Result ();
+use TAP::Parser::YAMLish::Reader ();
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=cut
+
+##############################################################################
+
+=head2 Class Methods
+
+
+=head3 C<new>
+
+