--- /dev/null
+#!/usr/bin/perl -w
+
+eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
+ if 0; # not running under some shell
+
+use strict;
+use lib 't/lib';
+use App::Prove;
+
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+$app->run;
+
+__END__
+
+=head1 NAME
+
+prove - Run tests through a TAP harness.
+
+=head1 USAGE
+
+ prove [options] [files or directories]
+
+=head1 OPTIONS
+
+Boolean options:
+
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' to the path for your tests (-Iblib/lib).
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ -f, --failures Only show failed tests.
+ --fork Fork to run harness in multiple processes
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+
+Options that take arguments:
+
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See TAP::Harness.
+ -a, --archive Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+
+=head2 Reading from C<STDIN>
+
+If you have a list of tests (or URLs, or anything else you want to test) in a
+file, you can add them to your tests by using a '-':
+
+ prove - < my_list_of_things_to_test.txt
+
+See the C<README> in the C<examples> directory of this distribution.
+
+=head1 NOTES
+
+=head2 Default Test Directory
+
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
+
+=head2 Colored Test Output
+
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
+
+Color support requires L<Term::ANSIColor> on Unix-like platforms and
+L<Win32::Console> windows. If the necessary module is not installed
+colored output will not be available.
+
+=head2 C<--exec>
+
+Normally you can just pass a list of Perl tests and the harness will know how
+to execute them. However, if your tests are not written in Perl or if you
+want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
+switch:
+
+ prove --exec '/usr/bin/ruby -w' t/
+ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
+ prove --exec '/path/to/my/customer/exec'
+
+=head2 C<--merge>
+
+If you need to make sure your diagnostics are displayed in the correct
+order relative to test results you can use the C<--merge> option to
+merge the test scripts' STDERR into their STDOUT.
+
+This guarantees that STDOUT (where the test results appear) and STDOUT
+(where the diagnostics appear) will stay in sync. The harness will
+display any diagnostics your tests emit on STDERR.
+
+Caveat: this is a bit of a kludge. In particular note that if anything
+that appears on STDERR looks like a test result the test harness will
+get confused. Use this option only if you understand the consequences
+and can live with the risk.
+
+=head1 PERFORMANCE
+
+Because of its design, C<TAP::Parser> collects more information than
+C<Test::Harness>. However, the trade-off is sometimes slightly slower
+performance than when using the C<prove> utility which is bundled with
+L<Test::Harness>. For small tests suites, this is usually not a problem.
+However, enabling the C<--quiet> or C<--QUIET> options can sometimes speed up
+the test suite, sometimes running faster than C<prove>.
+
+=head1 SEE ALSO
+
+C<prove>, which comes with L<Test::Harness> and whose code I've nicked in a
+few places (thanks Andy!).
+
+=head1 CAVEATS
+
+This is alpha code. You've been warned.
+
+=cut
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+package App::Prove;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Harness;
+use TAP::Parser::Utils qw( split_shell );
+use File::Spec;
+use Getopt::Long;
+use App::Prove::State;
+use Carp;
+
+=head1 NAME
+
+App::Prove - Implements the C<prove> command.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+L<Test::Harness> provides a command, C<prove>, which runs a TAP based
+test suite and prints a report. The C<prove> command is a minimal
+wrapper around an instance of this module.
+
+=head1 SYNOPSIS
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ $app->run;
+
+=cut
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => $^O eq 'VMS';
+use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
+
+use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
+use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
+
+use constant PLUGINS => 'App::Prove::Plugin';
+
+my @ATTR;
+
+BEGIN {
+ @ISA = qw(TAP::Object);
+
+ @ATTR = qw(
+ archive argv blib show_count color directives exec failures comments
+ formatter harness includes modules plugins jobs lib merge parse quiet
+ really_quiet recurse backwards shuffle taint_fail taint_warn timer
+ verbose warnings_fail warnings_warn show_help show_man show_version
+ state_class test_args state dry extension ignore_exit rules state_manager
+ normalize
+ );
+ __PACKAGE__->mk_methods(@ATTR);
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new C<App::Prove>. Optionally a hash ref of attribute
+initializers may be passed.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ my $args = shift || {};
+
+ # setup defaults:
+ for my $key (qw( argv rc_opts includes modules state plugins rules )) {
+ $self->{$key} = [];
+ }
+ $self->{harness_class} = 'TAP::Harness';
+
+ for my $attr (@ATTR) {
+ if ( exists $args->{$attr} ) {
+
+ # TODO: Some validation here
+ $self->{$attr} = $args->{$attr};
+ }
+ }
+
+ my %env_provides_default = (
+ HARNESS_TIMER => 'timer',
+ );
+
+ while ( my ( $env, $attr ) = each %env_provides_default ) {
+ $self->{$attr} = 1 if $ENV{$env};
+ }
+ $self->state_class('App::Prove::State');
+ return $self;
+}
+
+=head3 C<state_class>
+
+Getter/setter for the name of the class used for maintaining state. This
+class should either subclass from C<App::Prove::State> or provide an identical
+interface.
+
+=head3 C<state_manager>
+
+Getter/setter for the instance of the C<state_class>.
+
+=cut
+
+=head3 C<add_rc_file>
+
+ $prove->add_rc_file('myproj/.proverc');
+
+Called before C<process_args> to prepend the contents of an rc file to
+the options.
+
+=cut
+
+sub add_rc_file {
+ my ( $self, $rc_file ) = @_;
+
+ local *RC;
+ open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
+ while ( defined( my $line = <RC> ) ) {
+ push @{ $self->{rc_opts} },
+ grep { defined and not /^#/ }
+ $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
+ }
+ close RC;
+}
+
+=head3 C<process_args>
+
+ $prove->process_args(@args);
+
+Processes the command-line arguments. Attributes will be set
+appropriately. Any filenames may be found in the C<argv> attribute.
+
+Dies on invalid arguments.
+
+=cut
+
+sub process_args {
+ my $self = shift;
+
+ my @rc = RC_FILE;
+ unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
+
+ # Preprocess meta-args.
+ my @args;
+ while ( defined( my $arg = shift ) ) {
+ if ( $arg eq '--norc' ) {
+ @rc = ();
+ }
+ elsif ( $arg eq '--rc' ) {
+ defined( my $rc = shift )
+ or croak "Missing argument to --rc";
+ push @rc, $rc;
+ }
+ elsif ( $arg =~ m{^--rc=(.+)$} ) {
+ push @rc, $1;
+ }
+ else {
+ push @args, $arg;
+ }
+ }
+
+ # Everything after the arisdottle '::' gets passed as args to
+ # test programs.
+ if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
+ my @test_args = splice @args, $stop_at;
+ shift @test_args;
+ $self->{test_args} = \@test_args;
+ }
+
+ # Grab options from RC files
+ $self->add_rc_file($_) for grep -f, @rc;
+ unshift @args, @{ $self->{rc_opts} };
+
+ if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
+ die "Long options should be written with two dashes: ",
+ join( ', ', @bad ), "\n";
+ }
+
+ # And finally...
+
+ {
+ local @ARGV = @args;
+ Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
+
+ # Don't add coderefs to GetOptions
+ GetOptions(
+ 'v|verbose' => \$self->{verbose},
+ 'f|failures' => \$self->{failures},
+ 'o|comments' => \$self->{comments},
+ 'l|lib' => \$self->{lib},
+ 'b|blib' => \$self->{blib},
+ 's|shuffle' => \$self->{shuffle},
+ 'color!' => \$self->{color},
+ 'colour!' => \$self->{color},
+ 'count!' => \$self->{show_count},
+ 'c' => \$self->{color},
+ 'D|dry' => \$self->{dry},
+ 'ext=s' => \$self->{extension},
+ 'harness=s' => \$self->{harness},
+ 'ignore-exit' => \$self->{ignore_exit},
+ 'formatter=s' => \$self->{formatter},
+ 'r|recurse' => \$self->{recurse},
+ 'reverse' => \$self->{backwards},
+ 'p|parse' => \$self->{parse},
+ 'q|quiet' => \$self->{quiet},
+ 'Q|QUIET' => \$self->{really_quiet},
+ 'e|exec=s' => \$self->{exec},
+ 'm|merge' => \$self->{merge},
+ 'I=s@' => $self->{includes},
+ 'M=s@' => $self->{modules},
+ 'P=s@' => $self->{plugins},
+ 'state=s@' => $self->{state},
+ 'directives' => \$self->{directives},
+ 'h|help|?' => \$self->{show_help},
+ 'H|man' => \$self->{show_man},
+ 'V|version' => \$self->{show_version},
+ 'a|archive=s' => \$self->{archive},
+ 'j|jobs=i' => \$self->{jobs},
+ 'timer' => \$self->{timer},
+ 'T' => \$self->{taint_fail},
+ 't' => \$self->{taint_warn},
+ 'W' => \$self->{warnings_fail},
+ 'w' => \$self->{warnings_warn},
+ 'normalize' => \$self->{normalize},
+ 'rules=s@' => $self->{rules},
+ ) or croak('Unable to continue');
+
+ # Stash the remainder of argv for later
+ $self->{argv} = [@ARGV];
+ }
+
+ return;
+}
+
+sub _first_pos {
+ my $want = shift;
+ for ( 0 .. $#_ ) {
+ return $_ if $_[$_] eq $want;
+ }
+ return;
+}
+
+sub _help {
+ my ( $self, $verbosity ) = @_;
+
+ eval('use Pod::Usage 1.12 ()');
+ if ( my $err = $@ ) {
+ die 'Please install Pod::Usage for the --help option '
+ . '(or try `perldoc prove`.)'
+ . "\n ($@)";
+ }
+
+ Pod::Usage::pod2usage( { -verbose => $verbosity } );
+
+ return;
+}
+
+sub _color_default {
+ my $self = shift;
+
+ return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32;
+}
+
+sub _get_args {
+ my $self = shift;
+
+ my %args;
+
+ if ( defined $self->color ? $self->color : $self->_color_default ) {
+ $args{color} = 1;
+ }
+ if ( !defined $self->show_count ) {
+ $args{show_count} = 1;
+ }
+ else {
+ $args{show_count} = $self->show_count;
+ }
+
+ if ( $self->archive ) {
+ $self->require_harness( archive => 'TAP::Harness::Archive' );
+ $args{archive} = $self->archive;
+ }
+
+ if ( my $jobs = $self->jobs ) {
+ $args{jobs} = $jobs;
+ }
+
+ if ( my $harness_opt = $self->harness ) {
+ $self->require_harness( harness => $harness_opt );
+ }
+
+ if ( my $formatter = $self->formatter ) {
+ $args{formatter_class} = $formatter;
+ }
+
+ if ( $self->ignore_exit ) {
+ $args{ignore_exit} = 1;
+ }
+
+ if ( $self->taint_fail && $self->taint_warn ) {
+ die '-t and -T are mutually exclusive';
+ }
+
+ if ( $self->warnings_fail && $self->warnings_warn ) {
+ die '-w and -W are mutually exclusive';
+ }
+
+ for my $a (qw( lib switches )) {
+ my $method = "_get_$a";
+ my $val = $self->$method();
+ $args{$a} = $val if defined $val;
+ }
+
+ # Handle verbose, quiet, really_quiet flags
+ my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
+
+ my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
+ keys %verb_map;
+
+ die "Only one of verbose, quiet or really_quiet should be specified\n"
+ if @verb_adj > 1;
+
+ $args{verbosity} = shift @verb_adj || 0;
+
+ for my $a (qw( merge failures comments timer directives normalize )) {
+ $args{$a} = 1 if $self->$a();
+ }
+
+ $args{errors} = 1 if $self->parse;
+
+ # defined but zero-length exec runs test files as binaries
+ $args{exec} = [ split( /\s+/, $self->exec ) ]
+ if ( defined( $self->exec ) );
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ if ( @{ $self->rules } ) {
+ my @rules;
+ for ( @{ $self->rules } ) {
+ if (/^par=(.*)/) {
+ push @rules, $1;
+ }
+ elsif (/^seq=(.*)/) {
+ push @rules, { seq => $1 };
+ }
+ }
+ $args{rules} = { par => [@rules] };
+ }
+
+ return ( \%args, $self->{harness_class} );
+}
+
+sub _find_module {
+ my ( $self, $class, @search ) = @_;
+
+ croak "Bad module name $class"
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ for my $pfx (@search) {
+ my $name = join( '::', $pfx, $class );
+ eval "require $name";
+ return $name unless $@;
+ }
+
+ eval "require $class";
+ return $class unless $@;
+ return;
+}
+
+sub _load_extension {
+ my ( $self, $name, @search ) = @_;
+
+ my @args = ();
+ if ( $name =~ /^(.*?)=(.*)/ ) {
+ $name = $1;
+ @args = split( /,/, $2 );
+ }
+
+ if ( my $class = $self->_find_module( $name, @search ) ) {
+ $class->import(@args);
+ if ( $class->can('load') ) {
+ $class->load( { app_prove => $self, args => [@args] } );
+ }
+ }
+ else {
+ croak "Can't load module $name";
+ }
+}
+
+sub _load_extensions {
+ my ( $self, $ext, @search ) = @_;
+ $self->_load_extension( $_, @search ) for @$ext;
+}
+
+=head3 C<run>
+
+Perform whatever actions the command line args specified. The C<prove>
+command line tool consists of the following code:
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ exit( $app->run ? 0 : 1 ); # if you need the exit code
+
+=cut
+
+sub run {
+ my $self = shift;
+
+ unless ( $self->state_manager ) {
+ $self->state_manager(
+ $self->state_class->new( { store => STATE_FILE } ) );
+ }
+
+ if ( $self->show_help ) {
+ $self->_help(1);
+ }
+ elsif ( $self->show_man ) {
+ $self->_help(2);
+ }
+ elsif ( $self->show_version ) {
+ $self->print_version;
+ }
+ elsif ( $self->dry ) {
+ print "$_\n" for $self->_get_tests;
+ }
+ else {
+
+ $self->_load_extensions( $self->modules );
+ $self->_load_extensions( $self->plugins, PLUGINS );
+
+ local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
+
+ return $self->_runtests( $self->_get_args, $self->_get_tests );
+ }
+
+ return 1;
+}
+
+sub _get_tests {
+ my $self = shift;
+
+ my $state = $self->state_manager;
+ my $ext = $self->extension;
+ $state->extension($ext) if defined $ext;
+ if ( defined( my $state_switch = $self->state ) ) {
+ $state->apply_switch(@$state_switch);
+ }
+
+ my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
+
+ $self->_shuffle(@tests) if $self->shuffle;
+ @tests = reverse @tests if $self->backwards;
+
+ return @tests;
+}
+
+sub _runtests {
+ my ( $self, $args, $harness_class, @tests ) = @_;
+ my $harness = $harness_class->new($args);
+
+ my $state = $self->state_manager;
+
+ $harness->callback(
+ after_test => sub {
+ $state->observe_test(@_);
+ }
+ );
+
+ $harness->callback(
+ after_runtests => sub {
+ $state->commit(@_);
+ }
+ );
+
+ my $aggregator = $harness->runtests(@tests);
+
+ return !$aggregator->has_errors;
+}
+
+sub _get_switches {
+ my $self = shift;
+ my @switches;
+
+ # notes that -T or -t must be at the front of the switches!
+ if ( $self->taint_fail ) {
+ push @switches, '-T';
+ }
+ elsif ( $self->taint_warn ) {
+ push @switches, '-t';
+ }
+ if ( $self->warnings_fail ) {
+ push @switches, '-W';
+ }
+ elsif ( $self->warnings_warn ) {
+ push @switches, '-w';
+ }
+
+ push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
+
+ return @switches ? \@switches : ();
+}
+
+sub _get_lib {
+ my $self = shift;
+ my @libs;
+ if ( $self->lib ) {
+ push @libs, 'lib';
+ }
+ if ( $self->blib ) {
+ push @libs, 'blib/lib', 'blib/arch';
+ }
+ if ( @{ $self->includes } ) {
+ push @libs, @{ $self->includes };
+ }
+
+ #24926
+ @libs = map { File::Spec->rel2abs($_) } @libs;
+
+ # Huh?
+ return @libs ? \@libs : ();
+}
+
+sub _shuffle {
+ my $self = shift;
+
+ # Fisher-Yates shuffle
+ my $i = @_;
+ while ($i) {
+ my $j = rand $i--;
+ @_[ $i, $j ] = @_[ $j, $i ];
+ }
+ return;
+}
+
+=head3 C<require_harness>
+
+Load a harness replacement class.
+
+ $prove->require_harness($for => $class_name);
+
+=cut
+
+sub require_harness {
+ my ( $self, $for, $class ) = @_;
+
+ my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
+
+ # Emulate Perl's -MModule=arg1,arg2 behaviour
+ $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
+
+ eval("use $class;");
+ die "$class_name is required to use the --$for feature: $@" if $@;
+
+ $self->{harness_class} = $class_name;
+
+ return;
+}
+
+=head3 C<print_version>
+
+Display the version numbers of the loaded L<TAP::Harness> and the
+current Perl.
+
+=cut
+
+sub print_version {
+ my $self = shift;
+ printf(
+ "TAP::Harness v%s and Perl v%vd\n",
+ $TAP::Harness::VERSION, $^V
+ );
+
+ return;
+}
+
+1;
+
+# vim:ts=4:sw=4:et:sta
+
+__END__
+
+=head2 Attributes
+
+After command line parsing the following attributes reflect the values
+of the corresponding command line switches. They may be altered before
+calling C<run>.
+
+=over
+
+=item C<archive>
+
+=item C<argv>
+
+=item C<backwards>
+
+=item C<blib>
+
+=item C<color>
+
+=item C<directives>
+
+=item C<dry>
+
+=item C<exec>
+
+=item C<extension>
+
+=item C<failures>
+
+=item C<comments>
+
+=item C<formatter>
+
+=item C<harness>
+
+=item C<ignore_exit>
+
+=item C<includes>
+
+=item C<jobs>
+
+=item C<lib>
+
+=item C<merge>
+
+=item C<modules>
+
+=item C<parse>
+
+=item C<plugins>
+
+=item C<quiet>
+
+=item C<really_quiet>
+
+=item C<recurse>
+
+=item C<rules>
+
+=item C<show_count>
+
+=item C<show_help>
+
+=item C<show_man>
+
+=item C<show_version>
+
+=item C<shuffle>
+
+=item C<state>
+
+=item C<state_class>
+
+=item C<taint_fail>
+
+=item C<taint_warn>
+
+=item C<test_args>
+
+=item C<timer>
+
+=item C<verbose>
+
+=item C<warnings_fail>
+
+=item C<warnings_warn>
+
+=back
+
+=head1 PLUGINS
+
+C<App::Prove> provides support for 3rd-party plugins. These are currently
+loaded at run-time, I<after> arguments have been parsed (so you can not
+change the way arguments are processed, sorry), typically with the
+C<< -PI<plugin> >> switch, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass an argument to your plugin by appending an C<=> after the plugin
+name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
+
+ prove -PMyPlugin=foo,bar,baz
+
+These are passed in to your plugin's C<load()> class method (if it has one),
+along with a reference to the C<App::Prove> object that is invoking your plugin:
+
+ sub load {
+ my ($class, $p) = @_;
+
+ my @args = @{ $p->{args} };
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ $p->{app_prove}->do_something;
+ ...
+ }
+
+Note that the user's arguments are also passed to your plugin's C<import()>
+function as a list, eg:
+
+ sub import {
+ my ($class, @args) = @_;
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ ...
+ }
+
+This is for backwards compatibility, and may be deprecated in the future.
+
+=head2 Sample Plugin
+
+Here's a sample plugin, for your reference:
+
+ package App::Prove::Plugin::Foo;
+
+ # Sample plugin, try running with:
+ # prove -PFoo=bar -r -j3
+ # prove -PFoo -Q
+ # prove -PFoo=bar,My::Formatter
+
+ use strict;
+ use warnings;
+
+ sub load {
+ my ($class, $p) = @_;
+ my @args = @{ $p->{args} };
+ my $app = $p->{app_prove};
+
+ print "loading plugin: $class, args: ", join(', ', @args ), "\n";
+
+ # turn on verbosity
+ $app->verbose( 1 );
+
+ # set the formatter?
+ $app->formatter( $args[1] ) if @args > 1;
+
+ # print some of App::Prove's state:
+ for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
+ my $val = $app->$attr;
+ $val = 'undef' unless defined( $val );
+ print "$attr: $val\n";
+ }
+
+ return 1;
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<prove>, L<TAP::Harness>
+
+=cut
--- /dev/null
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+
+use App::Prove::State::Result;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+BEGIN {
+ @ISA = qw( TAP::Base );
+ __PACKAGE__->mk_methods('result_class');
+}
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant NEED_GLOB => IS_WIN32;
+
+=head1 NAME
+
+App::Prove::State - State storage for the C<prove> command.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module implements that state
+and the operations that may be performed on it.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Accepts a hashref with the following key/value pairs:
+
+=over 4
+
+=item * C<store>
+
+The filename of the data store holding the data that App::Prove::State reads.
+
+=item * C<extension> (optional)
+
+The test name extension. Defaults to C<.t>.
+
+=item * C<result_class> (optional)
+
+The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
+
+=back
+
+=cut
+
+# override TAP::Base::new:
+sub new {
+ my $class = shift;
+ my %args = %{ shift || {} };
+
+ my $self = bless {
+ select => [],
+ seq => 1,
+ store => delete $args{store},
+ extension => ( delete $args{extension} || '.t' ),
+ result_class =>
+ ( delete $args{result_class} || 'App::Prove::State::Result' ),
+ }, $class;
+
+ $self->{_} = $self->result_class->new(
+ { tests => {},
+ generation => 1,
+ }
+ );
+ my $store = $self->{store};
+ $self->load($store)
+ if defined $store && -f $store;
+
+ return $self;
+}
+
+=head2 C<result_class>
+
+Getter/setter for the name of the class used for tracking test results. This
+class should either subclass from C<App::Prove::State::Result> or provide an
+identical interface.
+
+=cut
+
+=head2 C<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+ my $self = shift;
+ $self->{extension} = shift if @_;
+ return $self->{extension};
+}
+
+=head2 C<results>
+
+Get the results of the last test run. Returns a C<result_class()> instance.
+
+=cut
+
+sub results {
+ my $self = shift;
+ $self->{_} || $self->result_class->new;
+}
+
+=head2 C<commit>
+
+Save the test results. Should be called after all tests have run.
+
+=cut
+
+sub commit {
+ my $self = shift;
+ if ( $self->{should_save} ) {
+ $self->save;
+ }
+}
+
+=head2 Instance Methods
+
+=head3 C<apply_switch>
+
+ $self->apply_switch('failed,save');
+
+Apply a list of switch options to the state, updating the internal
+object state as a result. Nothing is returned.
+
+Diagnostics:
+ - "Illegal state option: %s"
+
+=over
+
+=item C<last>
+
+Run in the same order as last time
+
+=item C<failed>
+
+Run only the failed tests from last time
+
+=item C<passed>
+
+Run only the passed tests from last time
+
+=item C<all>
+
+Run all tests in normal order
+
+=item C<hot>
+
+Run the tests that most recently failed first
+
+=item C<todo>
+
+Run the tests ordered by number of todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order.
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<save>
+
+Save the state on exit.
+
+=back
+
+=cut
+
+sub apply_switch {
+ my $self = shift;
+ my @opts = @_;
+
+ my $last_gen = $self->results->generation - 1;
+ my $last_run_time = $self->results->last_run_time;
+ my $now = $self->get_time;
+
+ my @switches = map { split /,/ } @opts;
+
+ my %handler = (
+ last => sub {
+ $self->_select(
+ where => sub { $_->generation >= $last_gen },
+ order => sub { $_->sequence }
+ );
+ },
+ failed => sub {
+ $self->_select(
+ where => sub { $_->result != 0 },
+ order => sub { -$_->result }
+ );
+ },
+ passed => sub {
+ $self->_select( where => sub { $_->result == 0 } );
+ },
+ all => sub {
+ $self->_select();
+ },
+ todo => sub {
+ $self->_select(
+ where => sub { $_->num_todo != 0 },
+ order => sub { -$_->num_todo; }
+ );
+ },
+ hot => sub {
+ $self->_select(
+ where => sub { defined $_->last_fail_time },
+ order => sub { $now - $_->last_fail_time }
+ );
+ },
+ slow => sub {
+ $self->_select( order => sub { -$_->elapsed } );
+ },
+ fast => sub {
+ $self->_select( order => sub { $_->elapsed } );
+ },
+ new => sub {
+ $self->_select( order => sub { -$_->mtime } );
+ },
+ old => sub {
+ $self->_select( order => sub { $_->mtime } );
+ },
+ fresh => sub {
+ $self->_select( where => sub { $_->mtime >= $last_run_time } );
+ },
+ save => sub {
+ $self->{should_save}++;
+ },
+ adrian => sub {
+ unshift @switches, qw( hot all save );
+ },
+ );
+
+ while ( defined( my $ele = shift @switches ) ) {
+ my ( $opt, $arg )
+ = ( $ele =~ /^([^:]+):(.*)/ )
+ ? ( $1, $2 )
+ : ( $ele, undef );
+ my $code = $handler{$opt}
+ || croak "Illegal state option: $opt";
+ $code->($arg);
+ }
+ return;
+}
+
+sub _select {
+ my ( $self, %spec ) = @_;
+ push @{ $self->{select} }, \%spec;
+}
+
+=head3 C<get_tests>
+
+Given a list of args get the names of tests that should run
+
+=cut
+
+sub get_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my %seen;
+
+ my @selected = $self->_query;
+
+ unless ( @argv || @{ $self->{select} } ) {
+ @argv = $recurse ? '.' : 't';
+ croak qq{No tests named and '@argv' directory not found}
+ unless -d $argv[0];
+ }
+
+ push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
+ return grep { !$seen{$_}++ } @selected;
+}
+
+sub _query {
+ my $self = shift;
+ if ( my @sel = @{ $self->{select} } ) {
+ warn "No saved state, selection will be empty\n"
+ unless $self->results->num_tests;
+ return map { $self->_query_clause($_) } @sel;
+ }
+ return;
+}
+
+sub _query_clause {
+ my ( $self, $clause ) = @_;
+ my @got;
+ my $results = $self->results;
+ my $where = $clause->{where} || sub {1};
+
+ # Select
+ for my $name ( $results->test_names ) {
+ next unless -f $name;
+ local $_ = $results->test($name);
+ push @got, $name if $where->();
+ }
+
+ # Sort
+ if ( my $order = $clause->{order} ) {
+ @got = map { $_->[0] }
+ sort {
+ ( defined $b->[1] <=> defined $a->[1] )
+ || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
+ } map {
+ [ $_,
+ do { local $_ = $results->test($_); $order->() }
+ ]
+ } @got;
+ }
+
+ return @got;
+}
+
+sub _get_raw_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my @tests;
+
+ # Do globbing on Win32.
+ @argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
+
+ for my $arg (@argv) {
+ if ( '-' eq $arg ) {
+ push @argv => <STDIN>;
+ chomp(@argv);
+ next;
+ }
+
+ push @tests,
+ sort -d $arg
+ ? $recurse
+ ? $self->_expand_dir_recursive( $arg, $extension )
+ : glob( File::Spec->catfile( $arg, "*$extension" ) )
+ : $arg;
+ }
+ return @tests;
+}
+
+sub _expand_dir_recursive {
+ my ( $self, $dir, $extension ) = @_;
+
+ my @tests;
+ find(
+ { follow => 1, #21938
+ follow_skip => 2,
+ wanted => sub {
+ -f
+ && /\Q$extension\E$/
+ && push @tests => $File::Find::name;
+ }
+ },
+ $dir
+ );
+ return @tests;
+}
+
+=head3 C<observe_test>
+
+Store the results of a test.
+
+=cut
+
+# Store:
+# last fail time
+# last pass time
+# last run time
+# most recent result
+# most recent todos
+# total failures
+# total passes
+# state generation
+# parser
+
+sub observe_test {
+
+ my ( $self, $test_info, $parser ) = @_;
+ my $name = $test_info->[0];
+ my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
+ my $todo = scalar( $parser->todo );
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time,
+
+ my $test = $self->results->test($name);
+
+ $test->sequence( $self->{seq}++ );
+ $test->generation( $self->results->generation );
+
+ $test->run_time($end_time);
+ $test->result($fail);
+ $test->num_todo($todo);
+ $test->elapsed( $end_time - $start_time );
+
+ $test->parser($parser);
+
+ if ($fail) {
+ $test->total_failures( $test->total_failures + 1 );
+ $test->last_fail_time($end_time);
+ }
+ else {
+ $test->total_passes( $test->total_passes + 1 );
+ $test->last_pass_time($end_time);
+ }
+}
+
+=head3 C<save>
+
+Write the state to a file.
+
+=cut
+
+sub save {
+ my ($self) = @_;
+
+ my $store = $self->{store} or return;
+ $self->results->last_run_time( $self->get_time );
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+ local *FH;
+ open FH, ">$store" or croak "Can't write $store ($!)";
+ $writer->write( $self->results->raw, \*FH );
+ close FH;
+}
+
+=head3 C<load>
+
+Load the state from a file
+
+=cut
+
+sub load {
+ my ( $self, $name ) = @_;
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+ local *FH;
+ open FH, "<$name" or croak "Can't read $name ($!)";
+
+ # XXX this is temporary
+ $self->{_} = $self->result_class->new(
+ $reader->read(
+ sub {
+ my $line = <FH>;
+ defined $line && chomp $line;
+ return $line;
+ }
+ )
+ );
+
+ # $writer->write( $self->{tests} || {}, \*FH );
+ close FH;
+ $self->_regen_seq;
+ $self->_prune_and_stamp;
+ $self->results->generation( $self->results->generation + 1 );
+}
+
+sub _prune_and_stamp {
+ my $self = shift;
+
+ my $results = $self->results;
+ my @tests = $self->results->tests;
+ for my $test (@tests) {
+ my $name = $test->name;
+ if ( my @stat = stat $name ) {
+ $test->mtime( $stat[9] );
+ }
+ else {
+ $results->remove($name);
+ }
+ }
+}
+
+sub _regen_seq {
+ my $self = shift;
+ for my $test ( $self->results->tests ) {
+ $self->{seq} = $test->sequence + 1
+ if defined $test->sequence && $test->sequence >= $self->{seq};
+ }
+}
+
+1;
--- /dev/null
+package App::Prove::State::Result;
+
+use strict;
+use Carp 'croak';
+
+use App::Prove::State::Result::Test;
+use vars qw($VERSION);
+
+use constant STATE_VERSION => 1;
+
+=head1 NAME
+
+App::Prove::State::Result - Individual test suite results.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test suite run.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $result = App::Prove::State::Result->new({
+ generation => $generation,
+ tests => \%tests,
+ });
+
+Returns a new C<App::Prove::State::Result> instance.
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ my %instance_data = %$arg_for; # shallow copy
+ $instance_data{version} = $class->state_version;
+ my $tests = delete $instance_data{tests} || {};
+ my $self = bless \%instance_data => $class;
+ $self->_initialize($tests);
+ return $self;
+}
+
+sub _initialize {
+ my ( $self, $tests ) = @_;
+ my %tests;
+ while ( my ( $name, $test ) = each %$tests ) {
+ $tests{$name} = $self->test_class->new(
+ { %$test,
+ name => $name
+ }
+ );
+ }
+ $self->tests( \%tests );
+ return $self;
+}
+
+=head2 C<state_version>
+
+Returns the current version of state storage.
+
+=cut
+
+sub state_version {STATE_VERSION}
+
+=head2 C<test_class>
+
+Returns the name of the class used for tracking individual tests. This class
+should either subclass from C<App::Prove::State::Result::Test> or provide an
+identical interface.
+
+=cut
+
+sub test_class {
+ return 'App::Prove::State::Result::Test';
+}
+
+my %methods = (
+ generation => { method => 'generation', default => 0 },
+ last_run_time => { method => 'last_run_time', default => undef },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head3 C<generation>
+
+Getter/setter for the "generation" of the test suite run. The first
+generation is 1 (one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_run_time>
+
+Getter/setter for the time of the test suite run.
+
+=head3 C<tests>
+
+Returns the tests for a given generation. This is a hashref or a hash,
+depending on context called. The keys to the hash are the individual
+test names and the value is a hashref with various interesting values.
+Each k/v pair might resemble something like this:
+
+ 't/foo.t' => {
+ elapsed => '0.0428488254547119',
+ gen => '7',
+ last_pass_time => '1219328376.07815',
+ last_result => '0',
+ last_run_time => '1219328376.07815',
+ last_todo => '0',
+ mtime => '1191708862',
+ seq => '192',
+ total_passes => '6',
+ }
+
+=cut
+
+sub tests {
+ my $self = shift;
+ if (@_) {
+ $self->{tests} = shift;
+ return $self;
+ }
+ my %tests = %{ $self->{tests} };
+ my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
+ return wantarray ? @tests : \@tests;
+}
+
+=head3 C<test>
+
+ my $test = $result->test('t/customer/create.t');
+
+Returns an individual C<App::Prove::State::Result::Test> instance for the
+given test name (usually the filename). Will return a new
+C<App::Prove::State::Result::Test> instance if the name is not found.
+
+=cut
+
+sub test {
+ my ( $self, $name ) = @_;
+ croak("test() requires a test name") unless defined $name;
+
+ my $tests = $self->{tests} ||= {};
+ if ( my $test = $tests->{$name} ) {
+ return $test;
+ }
+ else {
+ my $test = $self->test_class->new( { name => $name } );
+ $self->{tests}->{$name} = $test;
+ return $test;
+ }
+}
+
+=head3 C<test_names>
+
+Returns an list of test names, sorted by run order.
+
+=cut
+
+sub test_names {
+ my $self = shift;
+ return map { $_->name } $self->tests;
+}
+
+=head3 C<remove>
+
+ $result->remove($test_name); # remove the test
+ my $test = $result->test($test_name); # fatal error
+
+Removes a given test from results. This is a no-op if the test name is not
+found.
+
+=cut
+
+sub remove {
+ my ( $self, $name ) = @_;
+ delete $self->{tests}->{$name};
+ return $self;
+}
+
+=head3 C<num_tests>
+
+Returns the number of tests for a given test suite result.
+
+=cut
+
+sub num_tests { keys %{ shift->{tests} } }
+
+=head3 C<raw>
+
+Returns a hashref of raw results, suitable for serialization by YAML.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ my %tests;
+ foreach my $test ( $self->tests ) {
+ $tests{ $test->name } = $test->raw;
+ }
+ $raw{tests} = \%tests;
+ return \%raw;
+}
+
+1;
--- /dev/null
+package App::Prove::State::Result::Test;
+
+use strict;
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+App::Prove::State::Result::Test - Individual test results.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+my %methods = (
+ name => { method => 'name' },
+ elapsed => { method => 'elapsed', default => 0 },
+ gen => { method => 'generation', default => 1 },
+ last_pass_time => { method => 'last_pass_time', default => undef },
+ last_fail_time => { method => 'last_fail_time', default => undef },
+ last_result => { method => 'result', default => 0 },
+ last_run_time => { method => 'run_time', default => undef },
+ last_todo => { method => 'num_todo', default => 0 },
+ mtime => { method => 'mtime', default => undef },
+ seq => { method => 'sequence', default => 1 },
+ total_passes => { method => 'total_passes', default => 0 },
+ total_failures => { method => 'total_failures', default => 0 },
+ parser => { method => 'parser' },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ bless $arg_for => $class;
+}
+
+=head2 Instance Methods
+
+=head3 C<name>
+
+The name of the test. Usually a filename.
+
+=head3 C<elapsed>
+
+The total elapsed times the test took to run, in seconds from the epoch..
+
+=head3 C<generation>
+
+The number for the "generation" of the test run. The first generation is 1
+(one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_pass_time>
+
+The last time the test program passed, in seconds from the epoch.
+
+Returns C<undef> if the program has never passed.
+
+=head3 C<last_fail_time>
+
+The last time the test suite failed, in seconds from the epoch.
+
+Returns C<undef> if the program has never failed.
+
+=head3 C<mtime>
+
+Returns the mtime of the test, in seconds from the epoch.
+
+=head3 C<raw>
+
+Returns a hashref of raw test data, suitable for serialization by YAML.
+
+=head3 C<result>
+
+Currently, whether or not the test suite passed with no 'problems' (such as
+TODO passed).
+
+=head3 C<run_time>
+
+The total time it took for the test to run, in seconds. If C<Time::HiRes> is
+available, it will have finer granularity.
+
+=head3 C<num_todo>
+
+The number of tests with TODO directives.
+
+=head3 C<sequence>
+
+The order in which this test was run for the given test suite result.
+
+=head3 C<total_passes>
+
+The number of times the test has passed.
+
+=head3 C<total_failures>
+
+The number of times the test has failed.
+
+=head3 C<parser>
+
+The underlying parser object. This is useful if you need the full
+information for the test program.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ # this is backwards-compatibility hack and is not guaranteed.
+ delete $raw{name};
+ delete $raw{parser};
+ return \%raw;
+}
+
+1;
--- /dev/null
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser>
+and L<TAP::Harness>
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+use constant GOT_TIME_HIRES => do {
+ eval 'use Time::HiRes qw(time);';
+ $@ ? 0 : 1;
+};
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
+
+ # ... later ...
+
+ my $thing = TAP::Whatever->new();
+
+ $thing->callback( event => sub {
+ # do something interesting
+ } );
+
+=head1 DESCRIPTION
+
+C<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for, $ok_callback ) = @_;
+
+ my %ok_map = map { $_ => 1 } @$ok_callback;
+
+ $self->{ok_callbacks} = \%ok_map;
+
+ if ( my $cb = delete $arg_for->{callbacks} ) {
+ while ( my ( $event, $callback ) = each %$cb ) {
+ $self->callback( $event, $callback );
+ }
+ }
+
+ return $self;
+}
+
+=head3 C<callback>
+
+Install a callback for a named event.
+
+=cut
+
+sub callback {
+ my ( $self, $event, $callback ) = @_;
+
+ my %ok_map = %{ $self->{ok_callbacks} };
+
+ $self->_croak('No callbacks may be installed')
+ unless %ok_map;
+
+ $self->_croak( "Callback $event is not supported. Valid callbacks are "
+ . join( ', ', sort keys %ok_map ) )
+ unless exists $ok_map{$event};
+
+ push @{ $self->{code_for}{$event} }, $callback;
+
+ return;
+}
+
+sub _has_callbacks {
+ my $self = shift;
+ return keys %{ $self->{code_for} } != 0;
+}
+
+sub _callback_for {
+ my ( $self, $event ) = @_;
+ return $self->{code_for}{$event};
+}
+
+sub _make_callback {
+ my $self = shift;
+ my $event = shift;
+
+ my $cb = $self->_callback_for($event);
+ return unless defined $cb;
+ return map { $_->(@_) } @$cb;
+}
+
+=head3 C<get_time>
+
+Return the current time using Time::HiRes if available.
+
+=cut
+
+sub get_time { return time() }
+
+=head3 C<time_is_hires>
+
+Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
+
+=cut
+
+sub time_is_hires { return GOT_TIME_HIRES }
+
+1;
--- /dev/null
+package TAP::Formatter::Base;
+
+use strict;
+use TAP::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+my $MAX_ERRORS = 5;
+my %VALIDATION_FOR;
+
+BEGIN {
+ @ISA = qw(TAP::Base);
+
+ %VALIDATION_FOR = (
+ directives => sub { shift; shift },
+ verbosity => sub { shift; shift },
+ normalize => sub { shift; shift },
+ timer => sub { shift; shift },
+ failures => sub { shift; shift },
+ comments => sub { shift; shift },
+ errors => sub { shift; shift },
+ color => sub { shift; shift },
+ jobs => sub { shift; shift },
+ show_count => sub { shift; shift },
+ stdout => sub {
+ my ( $self, $ref ) = @_;
+ $self->_croak("option 'stdout' needs a filehandle")
+ unless ( ref $ref || '' ) eq 'GLOB'
+ or eval { $ref->can('print') };
+ return $ref;
+ },
+ );
+
+ my @getter_setters = qw(
+ _longest
+ _printed_summary_header
+ _colorizer
+ );
+
+ __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
+}
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=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>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (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>, C<failures>, or C<comments>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> is not
+defined it will default to color output if color support is available on
+the current platform and output is not being redirected.
+
+=item * C<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+Called by Test::Harness before any test output is generated.
+
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ }
+
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";
+
+ if ( $self->timer ) {
+ my $stamp = $self->_format_now();
+ return "$stamp $name$periods";
+ }
+ else {
+ return "$name$periods";
+ }
+
+}
+
+=head3 C<open_test>
+
+Called to create a new test session. A test session looks like this:
+
+ my $session = $formatter->open_test( $test, $parser );
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+ $session->close_test;
+
+=cut
+
+sub open_test {
+ die "Unimplemented.";
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_output($msg);
+}
+
+=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_success("All tests successful.\n");
+ }
+
+ # ~TODO option where $aggregate->skipped generates reports
+ if ( $total != $passed or $aggregate->has_problems ) {
+ $self->_output("\nTest Summary Report");
+ $self->_output("\n-------------------\n");
+ foreach my $test (@$tests) {
+ $self->_printed_summary_header(0);
+ my ($parser) = $aggregate->parsers($test);
+ $self->_output_summary_failure(
+ 'failed',
+ [ ' Failed test: ', ' Failed tests: ' ],
+ $test, $parser
+ );
+ $self->_output_summary_failure(
+ 'todo_passed',
+ " TODO passed: ", $test, $parser
+ );
+
+ # ~TODO this cannot be the default
+ #$self->_output_summary_failure( 'skipped', " Tests skipped: " );
+
+ if ( my $exit = $parser->exit ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero exit status: $exit\n");
+ }
+ elsif ( my $wait = $parser->wait ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero wait status: $wait\n");
+ }
+
+ if ( my @errors = $parser->parse_errors ) {
+ my $explain;
+ if ( @errors > $MAX_ERRORS && !$self->errors ) {
+ $explain
+ = "Displayed the first $MAX_ERRORS of "
+ . scalar(@errors)
+ . " TAP syntax errors.\n"
+ . "Re-run prove with the -p option to see them all.\n";
+ splice @errors, $MAX_ERRORS;
+ }
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(
+ sprintf " Parse errors: %s\n",
+ shift @errors
+ );
+ foreach my $error (@errors) {
+ my $spaces = ' ' x 16;
+ $self->_failure_output("$spaces$error\n");
+ }
+ $self->_failure_output($explain) if $explain;
+ }
+ }
+ }
+ my $files = @$tests;
+ $self->_output("Files=$files, Tests=$total, $runtime\n");
+ my $status = $aggregate->get_status;
+ $self->_output("Result: $status\n");
+}
+
+sub _output_summary_failure {
+ my ( $self, $method, $name, $test, $parser ) = @_;
+
+ # ugly hack. Must rethink this :(
+ my $output = $method eq 'failed' ? '_failure_output' : '_output';
+
+ if ( my @r = $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ my ( $singular, $plural )
+ = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
+ $self->$output( @r == 1 ? $singular : $plural );
+ my @results = $self->_balanced_range( 40, @r );
+ $self->$output( sprintf "%s\n" => shift @results );
+ my $spaces = ' ' x 16;
+ while (@results) {
+ $self->$output( sprintf "$spaces%s\n" => shift @results );
+ }
+ }
+}
+
+sub _summary_test_header {
+ my ( $self, $test, $parser ) = @_;
+ return if $self->_printed_summary_header;
+ my $spaces = ' ' x ( $self->_longest - length $test );
+ $spaces = ' ' unless $spaces;
+ my $output = $self->_get_output_method($parser);
+ $self->$output(
+ sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
+ $parser->wait, $parser->tests_run, scalar $parser->failed
+ );
+ $self->_printed_summary_header(1);
+}
+
+sub _output {
+ my $self = shift;
+
+ print { $self->stdout } @_;
+}
+
+sub _failure_output {
+ my $self = shift;
+
+ $self->_output(@_);
+}
+
+sub _balanced_range {
+ my ( $self, $limit, @range ) = @_;
+ @range = $self->_range(@range);
+ my $line = "";
+ my @lines;
+ my $curr = 0;
+ while (@range) {
+ if ( $curr < $limit ) {
+ my $range = ( shift @range ) . ", ";
+ $line .= $range;
+ $curr += length $range;
+ }
+ elsif (@range) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ $line = '';
+ $curr = 0;
+ }
+ }
+ if ($line) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ }
+ return @lines;
+}
+
+sub _range {
+ my ( $self, @numbers ) = @_;
+
+ # shouldn't be needed, but subclasses might call this
+ @numbers = sort { $a <=> $b } @numbers;
+ my ( $min, @range );
+
+ foreach my $i ( 0 .. $#numbers ) {
+ my $num = $numbers[$i];
+ my $next = $numbers[ $i + 1 ];
+ if ( defined $next && $next == $num + 1 ) {
+ if ( !defined $min ) {
+ $min = $num;
+ }
+ }
+ elsif ( defined $min ) {
+ push @range => "$min-$num";
+ undef $min;
+ }
+ else {
+ push @range => $num;
+ }
+ }
+ return @range;
+}
+
+sub _get_output_method {
+ my ( $self, $parser ) = @_;
+ return $parser->has_problems ? '_failure_output' : '_output';
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Color;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+
+@ISA = qw(TAP::Object);
+
+my $NO_COLOR;
+
+BEGIN {
+ $NO_COLOR = 0;
+
+ if (IS_WIN32) {
+ eval 'use Win32::Console';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
+
+ # eval here because we might not know about these variables
+ my $fg = eval '$FG_LIGHTGRAY';
+ my $bg = eval '$BG_BLACK';
+
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+
+ my $var;
+ if ( $color eq 'reset' ) {
+ $fg = eval '$FG_LIGHTGRAY';
+ $bg = eval '$BG_BLACK';
+ }
+ elsif ( $color =~ /^on_(.+)$/ ) {
+ $bg = eval '$BG_' . uc($1);
+ }
+ else {
+ $fg = eval '$FG_' . uc($color);
+ }
+
+ # In case of colors that aren't defined
+ $self->set_color('reset')
+ unless defined $bg && defined $fg;
+
+ $console->Attr( $bg | $fg );
+ };
+ }
+ }
+ else {
+ eval 'use Term::ANSIColor';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+ $output->( color($color) );
+ };
+ }
+ }
+
+ if ($NO_COLOR) {
+ *set_color = sub { };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Color - Run Perl test scripts with color
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+Note that this harness is I<experimental>. You may not like the colors I've
+chosen and I haven't yet provided an easy way to override them.
+
+This test harness is the same as L<TAP::Harness>, but test results are output
+in color. Passing tests are printed in green. Failing tests are in red.
+Skipped tests are blue on a white background and TODO tests are printed in
+white.
+
+If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running
+under Windows) tests will be run without color.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Color;
+ my $harness = TAP::Formatter::Color->new( \%args );
+ $harness->runtests(@tests);
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor returns a new C<TAP::Formatter::Color> object. If
+L<Term::ANSIColor> is not installed, returns undef.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+
+ if ($NO_COLOR) {
+
+ # shorten that message a bit
+ ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
+ warn "Note: Cannot run tests in color: $error\n";
+ return; # abort object construction
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<can_color>
+
+ Test::Formatter::Color->can_color()
+
+Returns a boolean indicating whether or not this module can actually
+generate colored output. This will be false if it could not load the
+modules needed for the current platform.
+
+=cut
+
+sub can_color {
+ return !$NO_COLOR;
+}
+
+=head3 C<set_color>
+
+Set the output color.
+
+=cut
+
+1;
--- /dev/null
+package TAP::Formatter::Console;
+
+use strict;
+use TAP::Formatter::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $class
+ = $self->jobs > 1
+ ? 'TAP::Formatter::Console::ParallelSession'
+ : 'TAP::Formatter::Console::Session';
+
+ eval "require $class";
+ $self->_croak($@) if $@;
+
+ my $session = $class->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ show_count => $self->show_count,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+# Use _colorizer delegate to set output color. NOP if we have no delegate
+sub _set_colors {
+ my ( $self, @colors ) = @_;
+ if ( my $colorizer = $self->_colorizer ) {
+ my $output_func = $self->{_output_func} ||= sub {
+ $self->_output(@_);
+ };
+ $colorizer->set_color( $output_func, $_ ) for @colors;
+ }
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_set_colors('green');
+ $self->_output($msg);
+ $self->_set_colors('reset');
+}
+
+sub _failure_output {
+ my $self = shift;
+ $self->_set_colors('red');
+ my $out = join '', @_;
+ my $has_newline = chomp $out;
+ $self->_output($out);
+ $self->_set_colors('reset');
+ $self->_output($/)
+ if $has_newline;
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Console::ParallelSession;
+
+use strict;
+use File::Spec;
+use File::Path;
+use TAP::Formatter::Console::Session;
+use Carp;
+
+use constant WIDTH => 72; # Because Eric says
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Console::Session);
+
+my %shared;
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ $self->SUPER::_initialize($arg_for);
+ my $formatter = $self->formatter;
+
+ # Horrid bodge. This creates our shared context per harness. Maybe
+ # TAP::Harness should give us this?
+ my $context = $shared{$formatter} ||= $self->_create_shared_context;
+ push @{ $context->{active} }, $self;
+
+ return $self;
+}
+
+sub _create_shared_context {
+ my $self = shift;
+ return {
+ active => [],
+ tests => 0,
+ fails => 0,
+ };
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for L<TAP::Harness>
+when run with multiple L<TAP::Harness/jobs>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+Output test preamble
+
+=cut
+
+sub header {
+}
+
+sub _clear_ruler {
+ my $self = shift;
+ $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
+}
+
+my $now = 0;
+my $start;
+
+my $trailer = '... )===';
+my $chop_length = WIDTH - length $trailer;
+
+sub _output_ruler {
+ my ( $self, $refresh ) = @_;
+ my $new_now = time;
+ return if $new_now == $now and !$refresh;
+ $now = $new_now;
+ $start ||= $now;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $context = $shared{$formatter};
+
+ my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start;
+
+ foreach my $active ( @{ $context->{active} } ) {
+ my $parser = $active->parser;
+ my $tests = $parser->tests_run;
+ my $planned = $parser->tests_planned || '?';
+
+ $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests;
+ }
+ chop $ruler; # Remove a trailing space
+ $ruler .= ')===';
+
+ if ( length $ruler > WIDTH ) {
+ $ruler =~ s/(.{$chop_length}).*/$1$trailer/o;
+ }
+ else {
+ $ruler .= '=' x ( WIDTH - length($ruler) );
+ }
+ $formatter->_output("\r$ruler");
+}
+
+=head3 C<result>
+
+ Called by the harness for each line of TAP it receives .
+
+=cut
+
+sub result {
+ my ( $self, $result ) = @_;
+ my $formatter = $self->formatter;
+
+ # my $really_quiet = $formatter->really_quiet;
+ # my $show_count = $self->_should_show_count;
+
+ if ( $result->is_test ) {
+ my $context = $shared{$formatter};
+ $context->{tests}++;
+
+ my $active = $context->{active};
+ if ( @$active == 1 ) {
+
+ # There is only one test, so use the serial output format.
+ return $self->SUPER::result($result);
+ }
+
+ $self->_output_ruler( $self->parser->tests_run == 1 );
+ }
+ elsif ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+}
+
+=head3 C<clear_for_close>
+
+=cut
+
+sub clear_for_close {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+ my $context = $shared{$formatter};
+ if ( @{ $context->{active} } == 1 ) {
+ $self->SUPER::clear_for_close;
+ }
+ else {
+ $self->_clear_ruler;
+ }
+}
+
+=head3 C<close_test>
+
+=cut
+
+sub close_test {
+ my $self = shift;
+ my $name = $self->name;
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ $self->SUPER::close_test;
+
+ my $active = $context->{active};
+
+ my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
+
+ die "Can't find myself" unless @pos;
+ splice @$active, $pos[0], 1;
+
+ if ( @$active > 1 ) {
+ $self->_output_ruler(1);
+ }
+ elsif ( @$active == 1 ) {
+
+ # Print out "test/name.t ...."
+ $active->[0]->SUPER::header;
+ }
+ else {
+
+ # $self->formatter->_output("\n");
+ delete $shared{$formatter};
+ }
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Console::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+my @ACCESSOR;
+
+BEGIN {
+ my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
+
+ for my $method (@CLOSURE_BINDING) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return ( $self->{_closures} ||= $self->_closures )->{$method}
+ ->(@_);
+ };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::Session - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=cut
+
+sub _get_output_result {
+ my $self = shift;
+
+ my @color_map = (
+ { test => sub { $_->is_test && !$_->is_ok },
+ colors => ['red'],
+ },
+ { test => sub { $_->is_test && $_->has_skip },
+ colors => [
+ 'white',
+ 'on_blue'
+ ],
+ },
+ { test => sub { $_->is_test && $_->has_todo },
+ colors => ['yellow'],
+ },
+ );
+
+ my $formatter = $self->formatter;
+ my $parser = $self->parser;
+
+ return $formatter->_colorizer
+ ? sub {
+ my $result = shift;
+ for my $col (@color_map) {
+ local $_ = $result;
+ if ( $col->{test}->() ) {
+ $formatter->_set_colors( @{ $col->{colors} } );
+ last;
+ }
+ }
+ $formatter->_output( $self->_format_for_output($result) );
+ $formatter->_set_colors('reset');
+ }
+ : sub {
+ $formatter->_output( $self->_format_for_output(shift) );
+ };
+}
+
+sub _closures {
+ my $self = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+ my $show_count = $self->show_count;
+
+ my $really_quiet = $formatter->really_quiet;
+ my $quiet = $formatter->quiet;
+ my $verbose = $formatter->verbose;
+ my $directives = $formatter->directives;
+ my $failures = $formatter->failures;
+ my $comments = $formatter->comments;
+
+ my $output_result = $self->_get_output_result;
+
+ my $output = '_output';
+ my $plan = '';
+ my $newline_printed = 0;
+
+ my $last_status_printed = 0;
+
+ return {
+ header => sub {
+ $formatter->_output($pretty)
+ unless $really_quiet;
+ },
+
+ result => sub {
+ my $result = shift;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ return if $really_quiet;
+
+ my $is_test = $result->is_test;
+
+ # These are used in close_test - but only if $really_quiet
+ # is false - so it's safe to only set them here unless that
+ # relationship changes.
+
+ if ( !$plan ) {
+ my $planned = $parser->tests_planned || '?';
+ $plan = "/$planned ";
+ }
+ $output = $formatter->_get_output_method($parser);
+
+ if ( $show_count and $is_test ) {
+ my $number = $result->number;
+ my $now = CORE::time;
+
+ # Print status roughly once per second.
+ # We will always get the first number as a side effect of
+ # $last_status_printed starting with the value 0, which $now
+ # will never be. (Unless someone sets their clock to 1970)
+ if ( $last_status_printed != $now ) {
+ $formatter->$output("\r$pretty$number$plan");
+ $last_status_printed = $now;
+ }
+ }
+
+ if (!$quiet
+ && ( $verbose
+ || ( $is_test && $failures && !$result->is_ok )
+ || ( $comments && $result->is_comment )
+ || ( $directives && $result->has_directive ) )
+ )
+ {
+ unless ($newline_printed) {
+ $formatter->_output("\n");
+ $newline_printed = 1;
+ }
+ $output_result->($result);
+ $formatter->_output("\n");
+ }
+ },
+
+ clear_for_close => sub {
+ my $spaces
+ = ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
+ $formatter->$output("\r$spaces");
+ },
+
+ close_test => sub {
+ if ( $show_count && !$really_quiet ) {
+ $self->clear_for_close;
+ $formatter->$output("\r$pretty");
+ }
+
+ # Avoid circular references
+ $self->parser(undef);
+ $self->{_closures} = {};
+
+ return if $really_quiet;
+
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output("skipped: $skip_all\n");
+ }
+ elsif ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output("ok$time_report\n");
+ }
+ },
+ };
+}
+
+=head2 C<< clear_for_close >>
+
+=head2 C<< close_test >>
+
+=head2 C<< header >>
+
+=head2 C<< result >>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Formatter::File;
+
+use strict;
+use TAP::Formatter::Base ();
+use TAP::Formatter::File::Session;
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::File - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::File;
+ my $harness = TAP::Formatter::File->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $session = TAP::Formatter::File::Session->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+sub _should_show_count {
+ return 0;
+}
+
+1;
--- /dev/null
+package TAP::Formatter::File::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+=head1 NAME
+
+TAP::Formatter::File::Session - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for L<TAP::Harness>.
+It is particularly important when running with parallel tests, as it
+ensures that test results are not interleaved, even when run
+verbosely.
+
+=cut
+
+=head1 METHODS
+
+=head2 result
+
+Stores results for later output, all together.
+
+=cut
+
+sub result {
+ my $self = shift;
+ my $result = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ return;
+ }
+
+ if (!$formatter->quiet
+ && ( $formatter->verbose
+ || ( $result->is_test && $formatter->failures && !$result->is_ok )
+ || ( $formatter->comments && $result->is_comment )
+ || ( $result->has_directive && $formatter->directives ) )
+ )
+ {
+ $self->{results} .= $self->_format_for_output($result) . "\n";
+ }
+}
+
+=head2 close_test
+
+When the test file finishes, outputs the summary, together.
+
+=cut
+
+sub close_test {
+ my $self = shift;
+
+ # Avoid circular references
+ $self->parser(undef);
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+
+ return if $formatter->really_quiet;
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output( $pretty . "skipped: $skip_all\n" );
+ }
+ elsif ( $parser->has_problems ) {
+ $formatter->_output(
+ $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) );
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output( $pretty
+ . ( $self->{results} ? "\n" . $self->{results} : "" )
+ . "ok$time_report\n" );
+ }
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Session;
+
+use strict;
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+my @ACCESSOR;
+
+BEGIN {
+
+ @ACCESSOR = qw( name formatter parser show_count );
+
+ for my $method (@ACCESSOR) {
+ no strict 'refs';
+ *$method = sub { shift->{$method} };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Session - Abstract base class for harness output delegate
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=item * C<show_count>
+
+=back
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name (@ACCESSOR) {
+ $self->{$name} = delete $arg_for{$name};
+ }
+
+ if ( !defined $self->show_count ) {
+ $self->{show_count} = 1; # defaults to true
+ }
+ if ( $self->show_count ) { # but may be a damned lie!
+ $self->{show_count} = $self->_should_show_count;
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ return $self;
+}
+
+=head3 C<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+Called to close a test session.
+
+=head3 C<clear_for_close>
+
+Called by C<close_test> to clear the line showing test progress, or the parallel
+test ruler, prior to printing the final test result.
+
+=cut
+
+sub header { }
+
+sub result { }
+
+sub close_test { }
+
+sub clear_for_close { }
+
+sub _should_show_count {
+ my $self = shift;
+ return
+ !$self->formatter->verbose
+ && -t $self->formatter->stdout
+ && !$ENV{HARNESS_NOTTY};
+}
+
+sub _format_for_output {
+ my ( $self, $result ) = @_;
+ return $self->formatter->normalize ? $result->as_string : $result->raw;
+}
+
+sub _output_test_failure {
+ my ( $self, $parser ) = @_;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $tests_run = $parser->tests_run;
+ my $tests_planned = $parser->tests_planned;
+
+ my $total
+ = defined $tests_planned
+ ? $tests_planned
+ : $tests_run;
+
+ my $passed = $parser->passed;
+
+ # The total number of fails includes any tests that were planned but
+ # didn't run
+ my $failed = $parser->failed + $total - $tests_run;
+ my $exit = $parser->exit;
+
+ if ( my $exit = $parser->exit ) {
+ my $wstat = $parser->wait;
+ my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
+ $formatter->_failure_output("Dubious, test returned $status\n");
+ }
+
+ if ( $failed == 0 ) {
+ $formatter->_failure_output(
+ $total
+ ? "All $total subtests passed "
+ : 'No subtests run '
+ );
+ }
+ else {
+ $formatter->_failure_output("Failed $failed/$total subtests ");
+ if ( !$total ) {
+ $formatter->_failure_output("\nNo tests run!");
+ }
+ }
+
+ if ( my $skipped = $parser->skipped ) {
+ $passed -= $skipped;
+ my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
+ $formatter->_output(
+ "\n\t(less $skipped skipped $test: $passed okay)");
+ }
+
+ if ( my $failed = $parser->todo_passed ) {
+ my $test = $failed > 1 ? 'tests' : 'test';
+ $formatter->_output(
+ "\n\t($failed TODO $test unexpectedly succeeded)");
+ }
+
+ $formatter->_output("\n");
+}
+
+1;
--- /dev/null
+package TAP::Harness;
+
+use strict;
+use Carp;
+
+use File::Spec;
+use File::Path;
+use IO::Handle;
+
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run test scripts with statistics
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+$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 comments errors stdout color
+ show_count normalize
+ );
+
+ %VALIDATION_FOR = (
+ lib => sub {
+ my ( $self, $libs ) = @_;
+ $libs = [$libs] unless 'ARRAY' eq ref $libs;
+
+ return [ map {"-I$_"} @$libs ];
+ },
+ switches => sub { shift; shift },
+ exec => sub { shift; shift },
+ merge => sub { shift; shift },
+ aggregator_class => sub { shift; shift },
+ formatter_class => sub { shift; shift },
+ multiplexer_class => sub { shift; shift },
+ parser_class => sub { shift; shift },
+ scheduler_class => sub { shift; shift },
+ formatter => sub { shift; shift },
+ jobs => sub { shift; shift },
+ test_args => sub { shift; shift },
+ ignore_exit => sub { shift; shift },
+ rules => sub { shift; shift },
+ );
+
+ for my $method ( sort keys %VALIDATION_FOR ) {
+ no strict 'refs';
+ if ( $method eq 'lib' || $method eq 'switches' ) {
+ *{$method} = sub {
+ my $self = shift;
+ unless (@_) {
+ $self->{$method} ||= [];
+ return wantarray
+ ? @{ $self->{$method} }
+ : $self->{$method};
+ }
+ $self->_croak("Too many arguments to method '$method'")
+ if @_ > 1;
+ my $args = shift;
+ $args = [$args] unless ref $args;
+ $self->{$method} = $args;
+ return $self;
+ };
+ }
+ else {
+ *{$method} = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+
+ for my $method (@FORMATTER_ARGS) {
+ no strict 'refs';
+ *{$method} = sub {
+ my $self = shift;
+ return $self->formatter->$method(@_);
+ };
+ }
+}
+
+##############################################################################
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbosity => 1,
+ lib => [ 'lib', 'blib/lib', 'blib/arch' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an
+optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level:
+
+ 1 verbose Print individual test results to STDOUT.
+ 0 normal
+ -1 quiet Suppress some test output (mostly failures
+ while tests are running).
+ -2 really quiet Suppress everything but the tests summary.
+ -3 silent Suppress everything.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if
+available.
+
+=item * C<failures>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (this is a no-op if C<verbose> is selected).
+
+=item * C<show_count>
+
+Update the running test count during testing.
+
+=item * C<normalize>
+
+Set to a true value to normalize the TAP that is emitted in verbose modes.
+
+=item * C<lib>
+
+Accepts a scalar value or array ref of scalar values indicating which
+paths to allowed libraries should be included if Perl tests are
+executed. Naturally, this only makes sense in the context of tests
+written in Perl.
+
+=item * C<switches>
+
+Accepts a scalar value or array ref of scalar values indicating which
+switches should be included if Perl tests are executed. Naturally, this
+only makes sense in the context of tests written in Perl.
+
+=item * C<test_args>
+
+A reference to an C<@INC> style array of arguments to be passed to each
+test program.
+
+=item * C<color>
+
+Attempt to produce color output.
+
+=item * C<exec>
+
+Typically, Perl tests are run through this. However, anything which
+spits out TAP is fine. You can use this argument to specify the name of
+the program (and optional switches) to run your tests with:
+
+ exec => ['/usr/bin/ruby', '-w']
+
+You can also pass a subroutine reference in order to determine and
+return the proper program to run based on a given test script. The
+subroutine reference should expect the TAP::Harness object itself as the
+first argument, and the file name as the second argument. It should
+return an array reference containing the command to be run and including
+the test file name. It can also simply return C<undef>, in which case
+TAP::Harness will fall back on executing the test script in Perl:
+
+ exec => sub {
+ my ( $harness, $test_file ) = @_;
+
+ # Let Perl tests run.
+ return undef if $test_file =~ /[.]t$/;
+ return [ qw( /usr/bin/ruby -w ), $test_file ]
+ if $test_file =~ /[.]rb$/;
+ }
+
+If the subroutine returns a scalar with a newline or a filehandle, it
+will be interpreted as raw TAP or as a TAP stream, respectively.
+
+=item * C<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<aggregator_class>
+
+The name of the class to use to aggregate test results. The default is
+L<TAP::Parser::Aggregator>.
+
+=item * C<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
+isn't a TTY.
+
+=item * C<multiplexer_class>
+
+The name of the class to use to multiplex tests during parallel testing.
+The default is L<TAP::Parser::Multiplexer>.
+
+=item * C<parser_class>
+
+The name of the class to use to parse TAP. The default is
+L<TAP::Parser>.
+
+=item * C<scheduler_class>
+
+The name of the class to use to schedule test execution. The default is
+L<TAP::Parser::Scheduler>.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting the
+TAP output. See L<TAP::Formatter::Console> for an example.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be
+made in the summary report. To see all of the parse errors, set this
+argument to true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be
+displayed. This overrides other settings such as C<verbose> or
+C<failures>.
+
+=item * C<ignore_exit>
+
+If set to a true value instruct C<TAP::Parser> to ignore exit and wait
+status from test scripts.
+
+=item * C<jobs>
+
+The maximum number of parallel tests to run at any time. Which tests
+can be run in parallel is controlled by C<rules>. The default is to
+run only one test at a time.
+
+=item * C<rules>
+
+A reference to a hash of rules that control which tests may be
+executed in parallel. This is an experimental feature and the
+interface may change.
+
+ $harness->rules(
+ { par => [
+ { seq => '../ext/DB_File/t/*' },
+ { seq => '../ext/IO_Compress_Zlib/t/*' },
+ { seq => '../lib/CPANPLUS/*' },
+ { seq => '../lib/ExtUtils/t/*' },
+ '*'
+ ]
+ }
+ );
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+{
+ my @legal_callback = qw(
+ parser_args
+ made_parser
+ before_runtests
+ after_runtests
+ after_test
+ );
+
+ my %default_class = (
+ aggregator_class => 'TAP::Parser::Aggregator',
+ formatter_class => 'TAP::Formatter::Console',
+ multiplexer_class => 'TAP::Parser::Multiplexer',
+ parser_class => 'TAP::Parser',
+ scheduler_class => 'TAP::Parser::Scheduler',
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name ( sort keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+
+ my $value = $self->$validate($property);
+ if ( $self->_error ) {
+ $self->_croak;
+ }
+ $self->$name($value);
+ }
+ }
+
+ $self->jobs(1) unless defined $self->jobs;
+
+ local $default_class{formatter_class} = 'TAP::Formatter::File'
+ unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY};
+
+ while ( my ( $attr, $class ) = each %default_class ) {
+ $self->$attr( $self->$attr() || $class );
+ }
+
+ unless ( $self->formatter ) {
+
+ # This is a little bodge to preserve legacy behaviour. It's
+ # pretty horrible that we know which args are destined for
+ # the formatter.
+ my %formatter_args = ( jobs => $self->jobs );
+ for my $name (@FORMATTER_ARGS) {
+ if ( defined( my $property = delete $arg_for{$name} ) ) {
+ $formatter_args{$name} = $property;
+ }
+ }
+
+ $self->formatter(
+ $self->_construct( $self->formatter_class, \%formatter_args )
+ );
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+
+ return $self;
+ }
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<runtests>
+
+ $harness->runtests(@tests);
+
+Accepts and array of C<@tests> to be run. This should generally be the
+names of test files, but this is not required. Each element in C<@tests>
+will be passed to C<TAP::Parser::new()> as a C<source>. See
+L<TAP::Parser> for more information.
+
+It is possible to provide aliases that will be displayed in place of the
+test name by supplying the test as a reference to an array containing
+C<< [ $test, $alias ] >>:
+
+ $harness->runtests( [ 't/foo.t', 'Foo Once' ],
+ [ 't/foo.t', 'Foo Twice' ] );
+
+Normally it is an error to attempt to run the same test twice. Aliases
+allow you to overcome this limitation by giving each run of the test a
+unique name.
+
+Tests will be run in the order found.
+
+If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
+should name a directory into which a copy of the raw TAP for each test
+will be written. TAP is written to files named for each test.
+Subdirectories will be created as needed.
+
+Returns a L<TAP::Parser::Aggregator> containing the test results.
+
+=cut
+
+sub runtests {
+ my ( $self, @tests ) = @_;
+
+ my $aggregate = $self->_construct( $self->aggregator_class );
+
+ $self->_make_callback( 'before_runtests', $aggregate );
+ $aggregate->start;
+ $self->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop;
+ $self->summary($aggregate);
+ $self->_make_callback( 'after_runtests', $aggregate );
+
+ return $aggregate;
+}
+
+=head3 C<summary>
+
+Output the summary for a TAP::Parser::Aggregator.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+ $self->formatter->summary($aggregate);
+}
+
+sub _after_test {
+ my ( $self, $aggregate, $job, $parser ) = @_;
+
+ $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
+ $aggregate->add( $job->description, $parser );
+}
+
+sub _bailout {
+ my ( $self, $result ) = @_;
+ my $explanation = $result->explanation;
+ die "FAILED--Further testing stopped"
+ . ( $explanation ? ": $explanation\n" : ".\n" );
+}
+
+sub _aggregate_parallel {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ my $jobs = $self->jobs;
+ my $mux = $self->_construct( $self->multiplexer_class );
+
+ RESULT: {
+
+ # Keep multiplexer topped up
+ FILL:
+ while ( $mux->parsers < $jobs ) {
+ my $job = $scheduler->get_job;
+
+ # If we hit a spinner stop filling and start running.
+ last FILL if !defined $job || $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+ $mux->add( $parser, [ $session, $job ] );
+ }
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ my ( $session, $job ) = @$stash;
+ if ( defined $result ) {
+ $session->result($result);
+ $self->_bailout($result) if $result->is_bailout;
+ }
+ else {
+
+ # End of parser. Automatically removed from the mux.
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+ redo RESULT;
+ }
+ }
+
+ return;
+}
+
+sub _aggregate_single {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ JOB:
+ while ( my $job = $scheduler->get_job ) {
+ next JOB if $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ if ( $result->is_bailout ) {
+
+ # Keep reading until input is exhausted in the hope
+ # of allowing any pending diagnostics to show up.
+ 1 while $parser->next;
+ $self->_bailout($result);
+ }
+ }
+
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+
+ return;
+}
+
+=head3 C<aggregate_tests>
+
+ $harness->aggregate_tests( $aggregate, @tests );
+
+Run the named tests and display a summary of result. Tests will be run
+in the order found.
+
+Test results will be added to the supplied L<TAP::Parser::Aggregator>.
+C<aggregate_tests> may be called multiple times to run several sets of
+tests. Multiple C<Test::Harness> instances may be used to pass results
+to a single aggregator so that different parts of a complex test suite
+may be run using different C<TAP::Harness> settings. This is useful, for
+example, in the case where some tests should run in parallel but others
+are unsuitable for parallel execution.
+
+ my $formatter = TAP::Formatter::Console->new;
+ my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
+ my $par_harness = TAP::Harness->new(
+ { formatter => $formatter,
+ jobs => 9
+ }
+ );
+ my $aggregator = TAP::Parser::Aggregator->new;
+
+ $aggregator->start();
+ $ser_harness->aggregate_tests( $aggregator, @ser_tests );
+ $par_harness->aggregate_tests( $aggregator, @par_tests );
+ $aggregator->stop();
+ $formatter->summary($aggregator);
+
+Note that for simpler testing requirements it will often be possible to
+replace the above code with a single call to C<runtests>.
+
+Each elements of the @tests array is either
+
+=over
+
+=item * the file name of a test script to run
+
+=item * a reference to a [ file name, display name ] array
+
+=back
+
+When you supply a separate display name it becomes possible to run a
+test more than once; the display name is effectively the alias by which
+the test is known inside the harness. The harness doesn't care if it
+runs the same script more than once when each invocation uses a
+different name.
+
+=cut
+
+sub aggregate_tests {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $jobs = $self->jobs;
+ my $scheduler = $self->make_scheduler(@tests);
+
+ # #12458
+ local $ENV{HARNESS_IS_VERBOSE} = 1
+ if $self->formatter->verbosity > 0;
+
+ # Formatter gets only names.
+ $self->formatter->prepare( map { $_->description } $scheduler->get_all );
+
+ if ( $self->jobs > 1 ) {
+ $self->_aggregate_parallel( $aggregate, $scheduler );
+ }
+ else {
+ $self->_aggregate_single( $aggregate, $scheduler );
+ }
+
+ return;
+}
+
+sub _add_descriptions {
+ my $self = shift;
+
+ # Turn unwrapped scalars into anonymous arrays and copy the name as
+ # the description for tests that have only a name.
+ return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ }
+ map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
+}
+
+=head3 C<make_scheduler>
+
+Called by the harness when it needs to create a
+L<TAP::Parser::Scheduler>. Override in a subclass to provide an
+alternative scheduler. C<make_scheduler> is passed the list of tests
+that was passed to C<aggregate_tests>.
+
+=cut
+
+sub make_scheduler {
+ my ( $self, @tests ) = @_;
+ return $self->_construct(
+ $self->scheduler_class,
+ tests => [ $self->_add_descriptions(@tests) ],
+ rules => $self->rules
+ );
+}
+
+=head3 C<jobs>
+
+Gets or sets the number of concurrent test runs the harness is
+handling. By default, this value is 1 -- for parallel testing, this
+should be set higher.
+
+=cut
+
+##############################################################################
+
+=head1 SUBCLASSING
+
+C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
+don't like how a particular feature functions, just override the
+desired methods.
+
+=head2 Methods
+
+TODO: This is out of date
+
+The following methods are ones you may wish to override if you want to
+subclass C<TAP::Harness>.
+
+=head3 C<summary>
+
+ $harness->summary( \%args );
+
+C<summary> prints the summary report after all tests are run. The
+argument is a hashref with the following keys:
+
+=over 4
+
+=item * C<start>
+
+This is created with C<< Benchmark->new >> and it the time the tests
+started. You can print a useful summary time, if desired, with:
+
+ $self->output(
+ timestr( timediff( Benchmark->new, $start_time ), 'nop' ) );
+
+=item * C<tests>
+
+This is an array reference of all test names. To get the L<TAP::Parser>
+object for individual tests:
+
+ my $aggregate = $args->{aggregate};
+ my $tests = $args->{tests};
+
+ for my $name ( @$tests ) {
+ my ($parser) = $aggregate->parsers($test);
+ ... do something with $parser
+ }
+
+This is a bit clunky and will be cleaned up in a later release.
+
+=back
+
+=cut
+
+sub _get_parser_args {
+ my ( $self, $job ) = @_;
+ my $test_prog = $job->filename;
+ my %args = ();
+ my @switches;
+ @switches = $self->lib if $self->lib;
+ push @switches => $self->switches if $self->switches;
+ $args{switches} = \@switches;
+ $args{spool} = $self->_open_spool($test_prog);
+ $args{merge} = $self->merge;
+ $args{ignore_exit} = $self->ignore_exit;
+
+ if ( my $exec = $self->exec ) {
+ $args{exec}
+ = ref $exec eq 'CODE'
+ ? $exec->( $self, $test_prog )
+ : [ @$exec, $test_prog ];
+ if ( not defined $args{exec} ) {
+ $args{source} = $test_prog;
+ }
+ elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) {
+ $args{source} = delete $args{exec};
+ }
+ }
+ else {
+ $args{source} = $test_prog;
+ }
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ return \%args;
+}
+
+=head3 C<make_parser>
+
+Make a new parser and display formatter session. Typically used and/or
+overridden in subclasses.
+
+ my ( $parser, $session ) = $harness->make_parser;
+
+=cut
+
+sub make_parser {
+ my ( $self, $job ) = @_;
+
+ my $args = $self->_get_parser_args($job);
+ $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
+ my $parser = $self->_construct( $self->parser_class, $args );
+
+ $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
+ my $session = $self->formatter->open_test( $job->description, $parser );
+
+ return ( $parser, $session );
+}
+
+=head3 C<finish_parser>
+
+Terminate use of a parser. Typically used and/or overridden in
+subclasses. The parser isn't destroyed as a result of this.
+
+=cut
+
+sub finish_parser {
+ my ( $self, $parser, $session ) = @_;
+
+ $session->close_test;
+ $self->_close_spool($parser);
+
+ return $parser;
+}
+
+sub _open_spool {
+ my $self = shift;
+ my $test = shift;
+
+ if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
+
+ my $spool = File::Spec->catfile( $spool_dir, $test );
+
+ # Make the directory
+ my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
+ my $path = File::Spec->catpath( $vol, $dir, '' );
+ eval { mkpath($path) };
+ $self->_croak($@) if $@;
+
+ my $spool_handle = IO::Handle->new;
+ open( $spool_handle, ">$spool" )
+ or $self->_croak(" Can't write $spool ( $! ) ");
+
+ return $spool_handle;
+ }
+
+ return;
+}
+
+sub _close_spool {
+ my $self = shift;
+ my ($parser) = @_;
+
+ if ( my $spool_handle = $parser->delete_spool ) {
+ close($spool_handle)
+ or $self->_croak(" Error closing TAP spool file( $! ) \n ");
+ }
+
+ return;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ unless ($message) {
+ $message = $self->_error;
+ }
+ $self->SUPER::_croak($message);
+
+ return;
+}
+
+=head1 REPLACING
+
+If you like the C<prove> utility and L<TAP::Parser> but you want your
+own harness, all you need to do is write one and provide C<new> and
+C<runtests> methods. Then you can use the C<prove> utility like so:
+
+ prove --harness My::Test::Harness
+
+Note that while C<prove> accepts a list of tests (or things to be
+tested), C<new> has a fairly rich set of arguments. You'll probably want
+to read over this code carefully to see how all of them are being used.
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+package TAP::Object;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Object - Base class that provides common functionality to all C<TAP::*> modules
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use strict;
+ use vars qw(@ISA);
+
+ use TAP::Object;
+
+ @ISA = qw(TAP::Object);
+
+ # new() implementation by TAP::Object
+ sub _initialize {
+ my ( $self, @args) = @_;
+ # initialize your object
+ return $self;
+ }
+
+ # ... later ...
+ my $obj = TAP::Whatever->new(@args);
+
+=head1 DESCRIPTION
+
+C<TAP::Object> provides a default constructor and exception model for all
+C<TAP::*> classes. Exceptions are raised using L<Carp>.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new object. Any arguments passed to C<new> will be passed on to the
+L</_initialize> method. Returns a new object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->_initialize(@_);
+}
+
+=head2 Instance Methods
+
+=head3 C<_initialize>
+
+Initializes a new object. This method is a stub by default, you should override
+it as appropriate.
+
+I<Note:> L</new> expects you to return C<$self> or raise an exception. See
+L</_croak>, and L<Carp>.
+
+=cut
+
+sub _initialize {
+ return $_[0];
+}
+
+=head3 C<_croak>
+
+Raise an exception using C<croak> from L<Carp>, eg:
+
+ $self->_croak( 'why me?', 'aaarrgh!' );
+
+May also be called as a I<class> method.
+
+ $class->_croak( 'this works too' );
+
+=cut
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+ return;
+}
+
+=head3 C<_construct>
+
+Create a new instance of the specified class.
+
+=cut
+
+sub _construct {
+ my ( $self, $class, @args ) = @_;
+
+ $self->_croak("Bad module name $class")
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ unless ( $class->can('new') ) {
+ local $@;
+ eval "require $class";
+ $self->_croak("Can't load $class") if $@;
+ }
+
+ return $class->new(@args);
+}
+
+=head3 C<mk_methods>
+
+Create simple getter/setters.
+
+ __PACKAGE__->mk_methods(@method_names);
+
+=cut
+
+sub mk_methods {
+ my ( $class, @methods ) = @_;
+ foreach my $method_name (@methods) {
+ my $method = "${class}::$method_name";
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method_name} = shift if @_;
+ return $self->{$method_name};
+ };
+ }
+}
+
+1;
+
--- /dev/null
+package TAP::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Base ();
+use TAP::Parser::Grammar ();
+use TAP::Parser::Result ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::Source ();
+use TAP::Parser::Source::Perl ();
+use TAP::Parser::Iterator ();
+use TAP::Parser::IteratorFactory ();
+
+use Carp qw( confess );
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+my $DEFAULT_TAP_VERSION = 12;
+my $MAX_TAP_VERSION = 13;
+
+$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{TAP_VERSION};
+}
+
+BEGIN { # making accessors
+ @ISA = qw(TAP::Base);
+
+ __PACKAGE__->mk_methods(
+ qw(
+ _stream
+ _spool
+ exec
+ exit
+ is_good_plan
+ plan
+ tests_planned
+ tests_run
+ wait
+ version
+ in_todo
+ start_time
+ end_time
+ skip_all
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ )
+ );
+} # done making accessors
+
+=head1 SYNOPSIS
+
+ use TAP::Parser;
+
+ my $parser = TAP::Parser->new( { source => $source } );
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser> is designed to produce a proper parse of TAP output. For
+an example of how to run tests through this module, see the simple
+harnesses C<examples/>.
+
+There's a wiki dedicated to the Test Anything Protocol:
+
+L<http://testanything.org>
+
+It includes the TAP::Parser Cookbook:
+
+L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $parser = TAP::Parser->new(\%args);
+
+Returns a new C<TAP::Parser> object.
+
+The arguments should be a hashref with I<one> of the following keys:
+
+=over 4
+
+=item * C<source>
+
+This is the preferred method of passing arguments to the constructor. To
+determine how to handle the source, the following steps are taken.
+
+If the source contains a newline, it's assumed to be a string of raw TAP
+output.
+
+If the source is a reference, it's assumed to be something to pass to
+the L<TAP::Parser::Iterator::Stream> constructor. This is used
+internally and you should not use it.
+
+Otherwise, the parser does a C<-e> check to see if the source exists. If so,
+it attempts to execute the source and read the output as a stream. This is by
+far the preferred method of using the parser.
+
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new( { source => $file } );
+ # do stuff with the parser
+ }
+
+=item * C<tap>
+
+The value should be the complete TAP output.
+
+=item * C<exec>
+
+If passed an array reference, will attempt to create the iterator by
+passing a L<TAP::Parser::Source> object to
+L<TAP::Parser::Iterator::Source>, using the array reference strings as
+the command arguments to L<IPC::Open3::open3|IPC::Open3>:
+
+ exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
+
+Note that C<source> and C<exec> are mutually exclusive.
+
+=back
+
+The following keys are optional.
+
+=over 4
+
+=item * C<callback>
+
+If present, each callback corresponding to a given result type will be called
+with the result as the argument if the C<run> method is used:
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+=item * C<switches>
+
+If using a Perl file as a source, optional switches may be passed which will
+be used when invoking the perl executable.
+
+ my $parser = TAP::Parser->new( {
+ source => $test_file,
+ switches => '-Ilib',
+ } );
+
+=item * C<test_args>
+
+Used in conjunction with the C<source> option to supply a reference to
+an C<@ARGV> style array of arguments to pass to the test program.
+
+=item * C<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+If false, STDERR is not captured (though it is 'relayed' to keep it
+somewhat synchronized with STDOUT.)
+
+If true, STDERR and STDOUT are the same filehandle. This may cause
+breakage if STDERR contains anything resembling TAP format, but does
+allow exact synchronization.
+
+Subtleties of this behavior may be platform-dependent and may change in
+the future.
+
+=item * C<source_class>
+
+This option was introduced to let you easily customize which I<source> class
+the parser should use. It defaults to L<TAP::Parser::Source>.
+
+See also L</make_source>.
+
+=item * C<perl_source_class>
+
+This option was introduced to let you easily customize which I<perl source>
+class the parser should use. It defaults to L<TAP::Parser::Source::Perl>.
+
+See also L</make_perl_source>.
+
+=item * C<grammar_class>
+
+This option was introduced to let you easily customize which I<grammar> class
+the parser should use. It defaults to L<TAP::Parser::Grammar>.
+
+See also L</make_grammar>.
+
+=item * C<iterator_factory_class>
+
+This option was introduced to let you easily customize which I<iterator>
+factory class the parser should use. It defaults to
+L<TAP::Parser::IteratorFactory>.
+
+See also L</make_iterator>.
+
+=item * C<result_factory_class>
+
+This option was introduced to let you easily customize which I<result>
+factory class the parser should use. It defaults to
+L<TAP::Parser::ResultFactory>.
+
+See also L</make_result>.
+
+=back
+
+=cut
+
+# new() implementation supplied by TAP::Base
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub _default_source_class {'TAP::Parser::Source'}
+sub _default_perl_source_class {'TAP::Parser::Source::Perl'}
+sub _default_grammar_class {'TAP::Parser::Grammar'}
+sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
+sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ my $parser = TAP::Parser->new( { source => $file } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This method returns the results of the parsing, one result at a time. Note
+that it is destructive. You can't rewind and examine previous results.
+
+If callbacks are used, they will be issued before this call returns.
+
+Each result returned is a subclass of L<TAP::Parser::Result>. See that
+module and related classes for more information on how to use them.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+##############################################################################
+
+=head3 C<run>
+
+ $parser->run;
+
+This method merely runs the parser and parses all of the TAP.
+
+=cut
+
+sub run {
+ my $self = shift;
+ while ( defined( my $result = $self->next ) ) {
+
+ # do nothing
+ }
+}
+
+##############################################################################
+
+=head3 C<make_source>
+
+Make a new L<TAP::Parser::Source> object and return it. Passes through any
+arguments given.
+
+The C<source_class> can be customized, as described in L</new>.
+
+=head3 C<make_perl_source>
+
+Make a new L<TAP::Parser::Source::Perl> object and return it. Passes through
+any arguments given.
+
+The C<perl_source_class> can be customized, as described in L</new>.
+
+=head3 C<make_grammar>
+
+Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
+arguments given.
+
+The C<grammar_class> can be customized, as described in L</new>.
+
+=head3 C<make_iterator>
+
+Make a new L<TAP::Parser::Iterator> object using the parser's
+L<TAP::Parser::IteratorFactory>, and return it. Passes through any arguments
+given.
+
+The C<iterator_factory_class> can be customized, as described in L</new>.
+
+=head3 C<make_result>
+
+Make a new L<TAP::Parser::Result> object using the parser's
+L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments
+given.
+
+The C<result_factory_class> can be customized, as described in L</new>.
+
+=cut
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub make_source { shift->source_class->new(@_); }
+sub make_perl_source { shift->perl_source_class->new(@_); }
+sub make_grammar { shift->grammar_class->new(@_); }
+sub make_iterator { shift->iterator_factory_class->make_iterator(@_); }
+sub make_result { shift->result_factory_class->make_result(@_); }
+
+sub _iterator_for_source {
+ my ( $self, $source ) = @_;
+
+ # If the source has a get_stream method then use it. This makes it
+ # possible to pass a pre-existing source object to the parser's
+ # constructor.
+ if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) {
+ return $source->get_stream($self);
+ }
+ else {
+ return $self->iterator_factory_class->make_iterator($source);
+ }
+}
+
+{
+
+ # of the following, anything beginning with an underscore is strictly
+ # internal and should not be exposed.
+ my %initialize = (
+ version => $DEFAULT_TAP_VERSION,
+ plan => '', # the test plan (e.g., 1..3)
+ tap => '', # the TAP
+ tests_run => 0, # actual current test numbers
+ results => [], # TAP parser results
+ skipped => [], #
+ todo => [], #
+ passed => [], #
+ failed => [], #
+ actual_failed => [], # how many tests really failed
+ actual_passed => [], # how many tests really passed
+ todo_passed => [], # tests which unexpectedly succeed
+ parse_errors => [], # perfect TAP should have none
+ );
+
+ # We seem to have this list hanging around all over the place. We could
+ #Â probably get it from somewhere else to avoid the repetition.
+ my @legal_callback = qw(
+ test
+ version
+ plan
+ comment
+ bailout
+ unknown
+ yaml
+ ALL
+ ELSE
+ EOF
+ );
+
+ my @class_overrides = qw(
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ # everything here is basically designed to convert any TAP source to a
+ # stream.
+
+ # Shallow copy
+ my %args = %{ $arg_for || {} };
+
+ $self->SUPER::_initialize( \%args, \@legal_callback );
+
+ # get any class overrides out first:
+ for my $key (@class_overrides) {
+ my $default_method = "_default_$key";
+ my $val = delete $args{$key} || $self->$default_method();
+ $self->$key($val);
+ }
+
+ my $stream = delete $args{stream};
+ my $tap = delete $args{tap};
+ my $source = delete $args{source};
+ my $exec = delete $args{exec};
+ my $merge = delete $args{merge};
+ my $spool = delete $args{spool};
+ my $switches = delete $args{switches};
+ my $ignore_exit = delete $args{ignore_exit};
+ my @test_args = @{ delete $args{test_args} || [] };
+
+ if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
+ $self->_croak(
+ "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
+ );
+ }
+
+ if ( my @excess = sort keys %args ) {
+ $self->_croak("Unknown options: @excess");
+ }
+
+ if ($tap) {
+ $stream = $self->_iterator_for_source( [ split "\n" => $tap ] );
+ }
+ elsif ($exec) {
+ my $source = $self->make_source;
+ $source->source( [ @$exec, @test_args ] );
+ $source->merge($merge); # XXX should just be arguments?
+ $stream = $source->get_stream($self);
+ }
+ elsif ($source) {
+ if ( $source =~ /\n/ ) {
+ $stream
+ = $self->_iterator_for_source( [ split "\n" => $source ] );
+ }
+ elsif ( ref $source ) {
+ $stream = $self->_iterator_for_source($source);
+ }
+ elsif ( -e $source ) {
+ my $perl = $self->make_perl_source;
+
+ $perl->switches($switches)
+ if $switches;
+
+ $perl->merge($merge); # XXX args to new()?
+ $perl->source( [ $source, @test_args ] );
+ $stream = $perl->get_stream($self);
+ }
+ else {
+ $self->_croak("Cannot determine source for $source");
+ }
+ }
+
+ unless ($stream) {
+ $self->_croak('PANIC: could not determine stream');
+ }
+
+ while ( my ( $k, $v ) = each %initialize ) {
+ $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
+ }
+
+ $self->_stream($stream);
+ $self->_spool($spool);
+ $self->ignore_exit($ignore_exit);
+
+ return $self;
+ }
+}
+
+=head1 INDIVIDUAL RESULTS
+
+If you've read this far in the docs, you've seen this:
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+Each result returned is a L<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=head2 Result types
+
+Basically, you fetch individual results from the TAP. The six types, with
+examples of each, are as follows:
+
+=over 4
+
+=item * Version
+
+ TAP version 12
+
+=item * Plan
+
+ 1..42
+
+=item * Pragma
+
+ pragma +strict
+
+=item * Test
+
+ ok 3 - We should start with some foobar!
+
+=item * Comment
+
+ # Hope we don't use up the foobar.
+
+=item * Bailout
+
+ Bail out! We ran out of foobar!
+
+=item * Unknown
+
+ ... yo, this ain't TAP! ...
+
+=back
+
+Each result fetched is a result object of a different type. There are common
+methods to each result object and different types may have methods unique to
+their type. Sometimes a type method may be overridden in a subclass, but its
+use is guaranteed to be identical.
+
+=head2 Common type methods
+
+=head3 C<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+Indicates whether or not this is a comment. Comments will generally only
+appear in the TAP stream if STDERR is merged to STDOUT. See the
+C<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut
+which allows you to do this:
+
+ my $parser = TAP::Parser->new( { source => $source } );
+ while ( my $result = $parser->next ) {
+ # only print failing results
+ print $result->as_string unless $result->is_ok;
+ }
+
+=head2 C<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<pragma> methods
+
+ if ( $result->is_pragma ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<pragmas>
+
+Returns a list of pragmas each of which is a + or - followed by the
+pragma name.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=head2 C<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+B<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ if ( $parser->in_todo ) { ... }
+
+True while the most recent result was a TODO. Becomes true before the
+TODO result is returned and stays true until just before the next non-
+TODO test is returned.
+
+=head1 TOTAL RESULTS
+
+After parsing the TAP, there are many methods available to let you dig through
+the results and determine what is meaningful to you.
+
+=head2 Individual Results
+
+These results refer to individual tests which are run.
+
+=head3 C<passed>
+
+ my @passed = $parser->passed; # the test numbers which passed
+ my $passed = $parser->passed; # the number of tests which passed
+
+This method lets you know which (or how many) tests passed. If a test failed
+but had a TODO directive, it will be counted as a passed test.
+
+=cut
+
+sub passed { @{ shift->{passed} } }
+
+=head3 C<failed>
+
+ my @failed = $parser->failed; # the test numbers which failed
+ my $failed = $parser->failed; # the number of tests which failed
+
+This method lets you know which (or how many) tests failed. If a test passed
+but had a TODO directive, it will B<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # the test numbers which actually passed
+ my @actual_passed = $parser->actual_passed;
+
+ # the number of tests which actually passed
+ my $actual_passed = $parser->actual_passed;
+
+This method lets you know which (or how many) tests actually passed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_passed { @{ shift->{actual_passed} } }
+*actual_ok = \&actual_passed;
+
+=head3 C<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # the test numbers which actually failed
+ my @actual_failed = $parser->actual_failed;
+
+ # the number of tests which actually failed
+ my $actual_failed = $parser->actual_failed;
+
+This method lets you know which (or how many) tests actually failed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_failed { @{ shift->{actual_failed} } }
+
+##############################################################################
+
+=head3 C<todo>
+
+ my @todo = $parser->todo; # the test numbers with todo directives
+ my $todo = $parser->todo; # the number of tests with todo directives
+
+This method lets you know which (or how many) tests had TODO directives.
+
+=cut
+
+sub todo { @{ shift->{todo} } }
+
+=head3 C<todo_passed>
+
+ # the test numbers which unexpectedly succeeded
+ my @todo_passed = $parser->todo_passed;
+
+ # the number of tests which unexpectedly succeeded
+ my $todo_passed = $parser->todo_passed;
+
+This method lets you know which (or how many) tests actually passed but were
+declared as "TODO" tests.
+
+=cut
+
+sub todo_passed { @{ shift->{todo_passed} } }
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ my @skipped = $parser->skipped; # the test numbers with SKIP directives
+ my $skipped = $parser->skipped; # the number of tests with SKIP directives
+
+This method lets you know which (or how many) tests had SKIP directives.
+
+=cut
+
+sub skipped { @{ shift->{skipped} } }
+
+=head2 Pragmas
+
+=head3 C<pragma>
+
+Get or set a pragma. To get the state of a pragma:
+
+ if ( $p->pragma('strict') ) {
+ # be strict
+ }
+
+To set the state of a pragma:
+
+ $p->pragma('strict', 1); # enable strict mode
+
+=cut
+
+sub pragma {
+ my ( $self, $pragma ) = splice @_, 0, 2;
+
+ return $self->{pragma}->{$pragma} unless @_;
+
+ if ( my $state = shift ) {
+ $self->{pragma}->{$pragma} = 1;
+ }
+ else {
+ delete $self->{pragma}->{$pragma};
+ }
+
+ return;
+}
+
+=head3 C<pragmas>
+
+Get a list of all the currently enabled pragmas:
+
+ my @pragmas_enabled = $p->pragmas;
+
+=cut
+
+sub pragmas { sort keys %{ shift->{pragma} || {} } }
+
+=head2 Summary Results
+
+These results are "meta" information about the total results of an individual
+test program.
+
+=head3 C<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ if ( $parser->is_good_plan ) { ... }
+
+Returns a boolean value indicating whether or not the number of tests planned
+matches the number of tests run.
+
+B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ print $parser->tests_planned;
+
+Returns the number of tests planned, according to the plan. For example, a
+plan of '1..17' will mean that 17 tests were planned.
+
+=head3 C<tests_run>
+
+ print $parser->tests_run;
+
+Returns the number of tests which actually were run. Hopefully this will
+match the number of C<< $parser->tests_planned >>.
+
+=head3 C<skip_all>
+
+Returns a true value (actually the reason for skipping) if all tests
+were skipped.
+
+=head3 C<start_time>
+
+Returns the time when the Parser was created.
+
+=head3 C<end_time>
+
+Returns the time when the end of TAP input was seen.
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+This is a 'catch-all' method which returns true if any tests have currently
+failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
+}
+
+=head3 C<version>
+
+ $parser->version;
+
+Once the parser is done, this will return the version number for the
+parsed TAP. Version numbers were introduced with TAP version 13 so if no
+version number is found version 12 is assumed.
+
+=head3 C<exit>
+
+ $parser->exit;
+
+Once the parser is done, this will return the exit status. If the parser ran
+an executable, it returns the exit status of the executable.
+
+=head3 C<wait>
+
+ $parser->wait;
+
+Once the parser is done, this will return the wait status. If the parser ran
+an executable, it returns the wait status of the executable. Otherwise, this
+mererely returns the C<exit> status.
+
+=head2 C<ignore_exit>
+
+ $parser->ignore_exit(1);
+
+Tell the parser to ignore the exit status from the test when determining
+whether the test passed. Normally tests with non-zero exit status are
+considered to have failed even if all individual tests passed. In cases
+where it is not possible to control the exit value of the test script
+use this option to ignore it.
+
+=cut
+
+sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
+
+=head3 C<parse_errors>
+
+ my @errors = $parser->parse_errors; # the parser errors
+ my $errors = $parser->parse_errors; # the number of parser_errors
+
+Fortunately, all TAP output is perfect. In the event that it is not, this
+method will return parser errors. Note that a junk line which the parser does
+not recognize is C<not> an error. This allows this parser to handle future
+versions of TAP. The following are all TAP errors reported by the parser:
+
+=over 4
+
+=item * Misplaced plan
+
+The plan (for example, '1..5'), must only come at the beginning or end of the
+TAP output.
+
+=item * No plan
+
+Gotta have a plan!
+
+=item * More than one plan
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+ 1..3
+
+Right. Very funny. Don't do that.
+
+=item * Test numbers out of sequence
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+That last test line above should have the number '3' instead of '2'.
+
+Note that it's perfectly acceptable for some lines to have test numbers and
+others to not have them. However, when a test number is found, it must be in
+sequence. The following is also an error:
+
+ 1..3
+ ok 1 - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+But this is not:
+
+ 1..3
+ ok - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+
+=back
+
+=cut
+
+sub parse_errors { @{ shift->{parse_errors} } }
+
+sub _add_error {
+ my ( $self, $error ) = @_;
+ push @{ $self->{parse_errors} } => $error;
+ return $self;
+}
+
+sub _make_state_table {
+ my $self = shift;
+ my %states;
+ my %planned_todo = ();
+
+ #Â These transitions are defaults for all states
+ my %state_globals = (
+ comment => {},
+ bailout => {},
+ yaml => {},
+ version => {
+ act => sub {
+ $self->_add_error(
+ 'If TAP version is present it must be the first line of output'
+ );
+ },
+ },
+ unknown => {
+ act => sub {
+ my $unk = shift;
+ if ( $self->pragma('strict') ) {
+ $self->_add_error(
+ 'Unknown TAP token: "' . $unk->raw . '"' );
+ }
+ },
+ },
+ pragma => {
+ act => sub {
+ my ($pragma) = @_;
+ for my $pr ( $pragma->pragmas ) {
+ if ( $pr =~ /^ ([-+])(\w+) $/x ) {
+ $self->pragma( $2, $1 eq '+' );
+ }
+ }
+ },
+ },
+ );
+
+ # Provides default elements for transitions
+ my %state_defaults = (
+ plan => {
+ act => sub {
+ my ($plan) = @_;
+ $self->tests_planned( $plan->tests_planned );
+ $self->plan( $plan->plan );
+ if ( $plan->has_skip ) {
+ $self->skip_all( $plan->explanation
+ || '(no reason given)' );
+ }
+
+ $planned_todo{$_}++ for @{ $plan->todo_list };
+ },
+ },
+ test => {
+ act => sub {
+ my ($test) = @_;
+
+ my ( $number, $tests_run )
+ = ( $test->number, ++$self->{tests_run} );
+
+ # Fake TODO state
+ if ( defined $number && delete $planned_todo{$number} ) {
+ $test->set_directive('TODO');
+ }
+
+ my $has_todo = $test->has_todo;
+
+ $self->in_todo($has_todo);
+ if ( defined( my $tests_planned = $self->tests_planned ) ) {
+ if ( $tests_run > $tests_planned ) {
+ $test->is_unplanned(1);
+ }
+ }
+
+ if ( defined $number ) {
+ if ( $number != $tests_run ) {
+ my $count = $tests_run;
+ $self->_add_error( "Tests out of sequence. Found "
+ . "($number) but expected ($count)" );
+ }
+ }
+ else {
+ $test->_number( $number = $tests_run );
+ }
+
+ push @{ $self->{todo} } => $number if $has_todo;
+ push @{ $self->{todo_passed} } => $number
+ if $test->todo_passed;
+ push @{ $self->{skipped} } => $number
+ if $test->has_skip;
+
+ push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
+ $number;
+ push @{
+ $self->{
+ $test->is_actual_ok
+ ? 'actual_passed'
+ : 'actual_failed'
+ }
+ } => $number;
+ },
+ },
+ yaml => { act => sub { }, },
+ );
+
+ # Each state contains a hash the keys of which match a token type. For
+ # each token
+ # type there may be:
+ # act A coderef to run
+ # goto The new state to move to. Stay in this state if
+ # missing
+ # continue Goto the new state and run the new state for the
+ # current token
+ %states = (
+ INIT => {
+ version => {
+ act => sub {
+ my ($version) = @_;
+ my $ver_num = $version->version;
+ if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
+ my $ver_min = $DEFAULT_TAP_VERSION + 1;
+ $self->_add_error(
+ "Explicit TAP version must be at least "
+ . "$ver_min. Got version $ver_num" );
+ $ver_num = $DEFAULT_TAP_VERSION;
+ }
+ if ( $ver_num > $MAX_TAP_VERSION ) {
+ $self->_add_error(
+ "TAP specified version $ver_num but "
+ . "we don't know about versions later "
+ . "than $MAX_TAP_VERSION" );
+ $ver_num = $MAX_TAP_VERSION;
+ }
+ $self->version($ver_num);
+ $self->_grammar->set_version($ver_num);
+ },
+ goto => 'PLAN'
+ },
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLAN => {
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLANNED => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => {
+ act => sub {
+ my ($version) = @_;
+ $self->_add_error(
+ 'More than one plan found in TAP output');
+ },
+ },
+ },
+ PLANNED_AFTER_TEST => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => { act => sub { }, continue => 'PLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ GOT_PLAN => {
+ test => {
+ act => sub {
+ my ($plan) = @_;
+ my $line = $self->plan;
+ $self->_add_error(
+ "Plan ($line) must be at the beginning "
+ . "or end of the TAP output" );
+ $self->is_good_plan(0);
+ },
+ continue => 'PLANNED'
+ },
+ plan => { continue => 'PLANNED' },
+ },
+ UNPLANNED => {
+ test => { goto => 'UNPLANNED_AFTER_TEST' },
+ plan => { goto => 'GOT_PLAN' },
+ },
+ UNPLANNED_AFTER_TEST => {
+ test => { act => sub { }, continue => 'UNPLANNED' },
+ plan => { act => sub { }, continue => 'UNPLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ );
+
+ # Apply globals and defaults to state table
+ for my $name ( keys %states ) {
+
+ # Merge with globals
+ my $st = { %state_globals, %{ $states{$name} } };
+
+ # Add defaults
+ for my $next ( sort keys %{$st} ) {
+ if ( my $default = $state_defaults{$next} ) {
+ for my $def ( sort keys %{$default} ) {
+ $st->{$next}->{$def} ||= $default->{$def};
+ }
+ }
+ }
+
+ # Stuff back in table
+ $states{$name} = $st;
+ }
+
+ return \%states;
+}
+
+=head3 C<get_select_handles>
+
+Get an a list of file handles which can be passed to C<select> to
+determine the readiness of this parser.
+
+=cut
+
+sub get_select_handles { shift->_stream->get_select_handles }
+
+sub _grammar {
+ my $self = shift;
+ return $self->{_grammar} = shift if @_;
+
+ return $self->{_grammar} ||= $self->make_grammar(
+ { stream => $self->_stream,
+ parser => $self,
+ version => $self->version
+ }
+ );
+}
+
+sub _iter {
+ my $self = shift;
+ my $stream = $self->_stream;
+ my $grammar = $self->_grammar;
+ my $spool = $self->_spool;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ $self->start_time( $self->get_time );
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ TRANS: {
+ my $state_spec = $state_table->{$state}
+ or die "Illegal state: $state";
+
+ if ( my $next = $state_spec->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $act->($token);
+ }
+ if ( my $cont = $next->{continue} ) {
+ $state = $cont;
+ redo TRANS;
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $state = $goto;
+ }
+ }
+ else {
+ confess("Unhandled token type: $type\n");
+ }
+ }
+ return $token;
+ };
+
+ # Handle end of stream - which means either pop a block or finish
+ my $end_handler = sub {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ return;
+ };
+
+ # Finally make the closure that we return. For performance reasons
+ # there are two versions of the returned function: one that handles
+ # callbacks and one that does not.
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $_->($result) for @{$code};
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ $self->_make_callback( 'EOF', $self )
+ unless defined $result;
+ }
+
+ return $result;
+ };
+ } # _has_callbacks
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ }
+
+ return $result;
+ };
+ } # no callbacks
+}
+
+sub _finish {
+ my $self = shift;
+
+ $self->end_time( $self->get_time );
+
+ # Avoid leaks
+ $self->_stream(undef);
+ $self->_grammar(undef);
+
+ # If we just delete the iter we won't get a fault if it's recreated.
+ # Instead we set it to a sub that returns an infinite
+ # stream of undef. This segfaults on 5.5.4, presumably because
+ # we're still executing the closure that gets replaced and it hasn't
+ # been protected with a refcount.
+ $self->{_iter} = sub {return}
+ if $] >= 5.006;
+
+ # sanity checks
+ if ( !$self->plan ) {
+ $self->_add_error('No plan found in TAP output');
+ }
+ else {
+ $self->is_good_plan(1) unless defined $self->is_good_plan;
+ }
+ if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
+ $self->is_good_plan(0);
+ if ( defined( my $planned = $self->tests_planned ) ) {
+ my $ran = $self->tests_run;
+ $self->_add_error(
+ "Bad plan. You planned $planned tests but ran $ran.");
+ }
+ }
+ if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
+
+ # this should never happen
+ my $actual = $self->tests_run;
+ my $passed = $self->passed;
+ my $failed = $self->failed;
+ $self->_croak( "Panic: planned test count ($actual) did not equal "
+ . "sum of passed ($passed) and failed ($failed) tests!" );
+ }
+
+ $self->is_good_plan(0) unless defined $self->is_good_plan;
+ return $self;
+}
+
+=head3 C<delete_spool>
+
+Delete and return the spool.
+
+ my $fh = $parser->delete_spool;
+
+=cut
+
+sub delete_spool {
+ my $self = shift;
+
+ return delete $self->{_spool};
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will
+be invoked. Thus, if all of the previous result types are specified as
+callbacks, this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is no
+accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO
+lists in the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was
+listed as a TODO test on the plan line. However, we are not aware of
+anyone actually using this feature and hard-coding test numbers is
+discouraged because it's very easy to add a test and break the test
+number sequence. This makes test suites very fragile. Instead, the
+following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter
+'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've
+never run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 SUBCLASSING
+
+If you find you need to provide custom functionality (as you would have using
+L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
+designed to be easily subclassed.
+
+Before you start, it's important to know a few things:
+
+=over 2
+
+=item 1
+
+All C<TAP::*> objects inherit from L<TAP::Object>.
+
+=item 2
+
+Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
+
+=item 3
+
+Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
+responsible for creating new objects in the C<TAP::Parser::*> namespace.
+
+This makes it possible for you to have a single point of configuring what
+subclasses should be used, which in turn means that in many cases you'll find
+you only need to sub-class one of the parser's components.
+
+=item 4
+
+By subclassing, you may end up overriding undocumented methods. That's not
+a bad thing per se, but be forewarned that undocumented methods may change
+without warning from one release to the next - we cannot guarantee backwards
+compatability. If any I<documented> method needs changing, it will be
+deprecated first, and changed in a later release.
+
+=back
+
+=head2 Parser Components
+
+=head3 Sources
+
+A TAP parser consumes input from a I<source>. There are currently two types
+of sources: L<TAP::Parser::Source> for general non-perl commands, and
+L<TAP::Parser::Source::Perl>. You can subclass both of them. You'll need to
+customize your parser by setting the C<source_class> & C<perl_source_class>
+parameters. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_source> or L</make_perl_source>.
+
+=head3 Iterators
+
+A TAP parser uses I<iterators> to loop through the I<stream> provided by the
+parser's I<source>. There are quite a few types of Iterators available.
+Choosing which class to use is the responsibility of the I<iterator factory>.
+
+To create your own iterators you'll have to subclass
+L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>. Then you'll
+need to customize the class used by your parser by setting the
+C<iterator_factory_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_iterator>.
+
+=head3 Results
+
+A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
+input I<stream>. There are quite a few result types available; choosing
+which class to use is the responsibility of the I<result factory>.
+
+To create your own result types you have two options:
+
+=over 2
+
+=item option 1
+
+Subclass L<TAP::Parser::Result> and register your new result type/class with
+the default L<TAP::Parser::ResultFactory>.
+
+=item option 2
+
+Subclass L<TAP::Parser::ResultFactory> itself and implement your own
+L<TAP::Parser::Result> creation logic. Then you'll need to customize the
+class used by your parser by setting the C<result_factory_class> parameter.
+See L</new> for more details.
+
+=back
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_result>.
+
+=head3 Grammar
+
+L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
+input I<stream> and produces results. If you need to customize its behaviour
+you should probably familiarize yourself with the source first. Enough
+lecturing.
+
+Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
+C<grammar_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_grammar>
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral
+support, or just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=item * David Wheeler
+
+=item * Alex Vandiver
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid@cpan.org>
+
+Andy Armstong <andy@hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+Michael Peters <mpeters at plusthree dot com>
+
+Leif Eriksen <leif dot eriksen at bigpond dot com>
+
+Steve Purkis <spurkis@cpan.org>
+
+Nicholas Clark <nick@ccl4.org>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
+We will be notified, and then you'll automatically be notified of
+progress on your bug as we make changes.
+
+Obviously, bugs which include patches are best. If you prefer, you can
+patch against bleed by via anonymous checkout of the latest version:
+
+ svn checkout http://svn.hexten.net/tapx
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Aggregator;
+
+use strict;
+use Benchmark;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Aggregator;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+ $aggregate->add( 't/00-load.t', $load_parser );
+ $aggregate->add( 't/10-lex.t', $lex_parser );
+
+ my $summary = <<'END_SUMMARY';
+ Passed: %s
+ Failed: %s
+ Unexpectedly succeeded: %s
+ END_SUMMARY
+ printf $summary,
+ scalar $aggregate->passed,
+ scalar $aggregate->failed,
+ scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN { # install summary methods
+ %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+ failed
+ parse_errors
+ passed
+ skipped
+ todo
+ todo_passed
+ total
+ wait
+ exit
+ );
+ $SUMMARY_METHOD_FOR{total} = 'tests_run';
+ $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
+
+ foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
+ next if 'total' eq $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return wantarray
+ ? @{ $self->{"descriptions_for_$method"} }
+ : $self->{$method};
+ };
+ }
+} # end install summary methods
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.) It is used as a unique identifier (see e.g.
+L<"parsers">.) Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak( "You already have a parser for ($description)."
+ . " Perhaps you have run the same test twice." );
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+
+ # Slightly nasty. Instead we should maybe have 'cooked' accessors
+ # for results that may be masked by the parser.
+ next
+ if ( $method eq 'exit' || $method eq 'wait' )
+ && $parser->ignore_exit;
+
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method. Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->_get_parsers(@_) if @_;
+ my $descriptions = $self->{parse_order};
+ my @parsers = @{ $self->{parser_for} }{@$descriptions};
+
+ # Note: Because of the way context works, we must assign the parsers to
+ # the @parsers array or else this method does not work as documented.
+ return @parsers;
+}
+
+sub _get_parsers {
+ my ( $self, @descriptions ) = @_;
+ my @parsers;
+ foreach my $description (@descriptions) {
+ $self->_croak("A parser for ($description) could not be found")
+ unless exists $self->{parser_for}{$description};
+ push @parsers => $self->{parser_for}{$description};
+ }
+ return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to
+the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+ my $self = shift;
+ $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+ my $self = shift;
+ $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+ my $self = shift;
+
+ require Carp;
+ Carp::croak
+ q{Can't call elapsed without first calling start and then stop}
+ unless defined $self->{start_time} && defined $self->{end_time};
+ return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>. This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+ my $self = shift;
+
+ my $elapsed = $self->elapsed;
+
+ return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+ my $self = shift;
+ return
+ $self->total
+ && $self->total == $self->passed
+ && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+ my $self = shift;
+
+ my $total = $self->total;
+ my $passed = $self->passed;
+
+ return
+ ( $self->has_errors || $total != $passed ) ? 'FAIL'
+ : $total ? 'PASS'
+ : 'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * planned
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded. This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->todo_passed
+ || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+ if ( $parser->has_errors ) {
+ ...
+ }
+
+Returns true if I<any> of the parsers failed. This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse errors
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::YAMLish::Reader ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Grammar;
+ my $grammar = $self->make_grammar({
+ stream => $tap_parser_stream,
+ parser => $tap_parser,
+ version => 12,
+ });
+
+ my $result = $grammar->tokenize;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $grammar = TAP::Parser::Grammar->new({
+ stream => $stream,
+ parser => $parser,
+ version => $version,
+ });
+
+Returns L<TAP::Parser> grammar object that will parse the specified stream.
+Both C<stream> and C<parser> are required arguments. If C<version> is not set
+it defaults to C<12> (see L</set_version> for more details).
+
+=cut
+
+# new() implementation supplied by TAP::Object
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{stream} = $args->{stream}; # TODO: accessor
+ $self->{parser} = $args->{parser}; # TODO: accessor
+ $self->set_version( $args->{version} || 12 );
+ return $self;
+}
+
+my %language_for;
+
+{
+
+ # XXX the 'not' and 'ok' might be on separate lines in VMS ...
+ my $ok = qr/(?:not )?ok\b/;
+ my $num = qr/\d+/;
+
+ my %v12 = (
+ version => {
+ syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $version = $1;
+ return $self->_make_version_token( $line, $version, );
+ },
+ },
+ plan => {
+ syntax => qr/^1\.\.(\d+)\s*(.*)\z/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $tail ) = ( $1, $2 );
+ my $explanation = undef;
+ my $skip = '';
+
+ if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
+ my @todo = split /\s+/, _trim($1);
+ return $self->_make_plan_token(
+ $line, $tests_planned, 'TODO',
+ '', \@todo
+ );
+ }
+ elsif ( 0 == $tests_planned ) {
+ $skip = 'SKIP';
+
+ # If we can't match # SKIP the directive should be undef.
+ ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i;
+ }
+ elsif ( $tail !~ /^\s*$/ ) {
+ return $self->_make_unknown_token($line);
+ }
+
+ $explanation = '' unless defined $explanation;
+
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+
+ },
+ },
+
+ # An optimization to handle the most common test lines without
+ # directives.
+ simple_test => {
+ syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+
+ return $self->_make_test_token(
+ $line, $ok, $num,
+ $desc
+ );
+ },
+ },
+ test => {
+ syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+ my ( $dir, $explanation ) = ( '', '' );
+ if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
+ \# \s* (SKIP|TODO) \b \s* (.*) $/ix
+ )
+ {
+ ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
+ }
+ return $self->_make_test_token(
+ $line, $ok, $num, $desc,
+ $dir, $explanation
+ );
+ },
+ },
+ comment => {
+ syntax => qr/^#(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $comment = $1;
+ return $self->_make_comment_token( $line, $comment );
+ },
+ },
+ bailout => {
+ syntax => qr/^Bail out!\s*(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $explanation = $1;
+ return $self->_make_bailout_token(
+ $line,
+ $explanation
+ );
+ },
+ },
+ );
+
+ my %v13 = (
+ %v12,
+ plan => {
+ syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $explanation ) = ( $1, $2 );
+ my $skip
+ = ( 0 == $tests_planned || defined $explanation )
+ ? 'SKIP'
+ : '';
+ $explanation = '' unless defined $explanation;
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+ },
+ },
+ yaml => {
+ syntax => qr/^ (\s+) (---.*) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $pad, $marker ) = ( $1, $2 );
+ return $self->_make_yaml_token( $pad, $marker );
+ },
+ },
+ pragma => {
+ syntax =>
+ qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $pragmas = $1;
+ return $self->_make_pragma_token( $line, $pragmas );
+ },
+ },
+ );
+
+ %language_for = (
+ '12' => {
+ tokens => \%v12,
+ },
+ '13' => {
+ tokens => \%v13,
+ setup => sub {
+ shift->{stream}->handle_unicode;
+ },
+ },
+ );
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<set_version>
+
+ $grammar->set_version(13);
+
+Tell the grammar which TAP syntax version to support. The lowest
+supported version is 12. Although 'TAP version' isn't valid version 12
+syntax it is accepted so that higher version numbers may be parsed.
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ my $version = shift;
+
+ if ( my $language = $language_for{$version} ) {
+ $self->{version} = $version;
+ $self->{tokens} = $language->{tokens};
+
+ if ( my $setup = $language->{setup} ) {
+ $self->$setup();
+ }
+
+ $self->_order_tokens;
+ }
+ else {
+ require Carp;
+ Carp::croak("Unsupported syntax version: $version");
+ }
+}
+
+# Optimization to put the most frequent tokens first.
+sub _order_tokens {
+ my $self = shift;
+
+ my %copy = %{ $self->{tokens} };
+ my @ordered_tokens = grep {defined}
+ map { delete $copy{$_} } qw( simple_test test comment plan );
+ push @ordered_tokens, values %copy;
+
+ $self->{ordered_tokens} = \@ordered_tokens;
+}
+
+##############################################################################
+
+=head3 C<tokenize>
+
+ my $token = $grammar->tokenize;
+
+This method will return a L<TAP::Parser::Result> object representing the
+current line of TAP.
+
+=cut
+
+sub tokenize {
+ my $self = shift;
+
+ my $line = $self->{stream}->next;
+ unless ( defined $line ) {
+ delete $self->{parser}; # break circular ref
+ return;
+ }
+
+ my $token;
+
+ foreach my $token_data ( @{ $self->{ordered_tokens} } ) {
+ if ( $line =~ $token_data->{syntax} ) {
+ my $handler = $token_data->{handler};
+ $token = $self->$handler($line);
+ last;
+ }
+ }
+
+ $token = $self->_make_unknown_token($line) unless $token;
+
+ return $self->{parser}->make_result($token);
+}
+
+##############################################################################
+
+=head3 C<token_types>
+
+ my @types = $grammar->token_types;
+
+Returns the different types of tokens which this grammar can parse.
+
+=cut
+
+sub token_types {
+ my $self = shift;
+ return keys %{ $self->{tokens} };
+}
+
+##############################################################################
+
+=head3 C<syntax_for>
+
+ my $syntax = $grammar->syntax_for($token_type);
+
+Returns a pre-compiled regular expression which will match a chunk of TAP
+corresponding to the token type. For example (not that you should really pay
+attention to this, C<< $grammar->syntax_for('comment') >> will return
+C<< qr/^#(.*)/ >>.
+
+=cut
+
+sub syntax_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{syntax};
+}
+
+##############################################################################
+
+=head3 C<handler_for>
+
+ my $handler = $grammar->handler_for($token_type);
+
+Returns a code reference which, when passed an appropriate line of TAP,
+returns the lexed token corresponding to that line. As a result, the basic
+TAP parsing loop looks similar to the following:
+
+ my @tokens;
+ my $grammar = TAP::Grammar->new;
+ LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
+ foreach my $type ( $grammar->token_types ) {
+ my $syntax = $grammar->syntax_for($type);
+ if ( $line =~ $syntax ) {
+ my $handler = $grammar->handler_for($type);
+ push @tokens => $grammar->$handler($line);
+ next LINE;
+ }
+ }
+ push @tokens => $grammar->_make_unknown_token($line);
+ }
+
+=cut
+
+sub handler_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{handler};
+}
+
+sub _make_version_token {
+ my ( $self, $line, $version ) = @_;
+ return {
+ type => 'version',
+ raw => $line,
+ version => $version,
+ };
+}
+
+sub _make_plan_token {
+ my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
+
+ if ( $directive eq 'SKIP'
+ && 0 != $tests_planned
+ && $self->{version} < 13 )
+ {
+ warn
+ "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+ }
+
+ return {
+ type => 'plan',
+ raw => $line,
+ tests_planned => $tests_planned,
+ directive => $directive,
+ explanation => _trim($explanation),
+ todo_list => $todo,
+ };
+}
+
+sub _make_test_token {
+ my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+ return {
+ ok => $ok,
+ test_num => $num,
+ description => _trim($desc),
+ directive => ( defined $dir ? uc $dir : '' ),
+ explanation => _trim($explanation),
+ raw => $line,
+ type => 'test',
+ };
+}
+
+sub _make_unknown_token {
+ my ( $self, $line ) = @_;
+ return {
+ raw => $line,
+ type => 'unknown',
+ };
+}
+
+sub _make_comment_token {
+ my ( $self, $line, $comment ) = @_;
+ return {
+ type => 'comment',
+ raw => $line,
+ comment => _trim($comment)
+ };
+}
+
+sub _make_bailout_token {
+ my ( $self, $line, $explanation ) = @_;
+ return {
+ type => 'bailout',
+ raw => $line,
+ bailout => _trim($explanation)
+ };
+}
+
+sub _make_yaml_token {
+ my ( $self, $pad, $marker ) = @_;
+
+ my $yaml = TAP::Parser::YAMLish::Reader->new;
+
+ my $stream = $self->{stream};
+
+ # Construct a reader that reads from our input stripping leading
+ # spaces from each line.
+ my $leader = length($pad);
+ my $strip = qr{ ^ (\s{$leader}) (.*) $ }x;
+ my @extra = ($marker);
+ my $reader = sub {
+ return shift @extra if @extra;
+ my $line = $stream->next;
+ return $2 if $line =~ $strip;
+ return;
+ };
+
+ my $data = $yaml->read($reader);
+
+ # Reconstitute input. This is convoluted. Maybe we should just
+ # record it on the way in...
+ chomp( my $raw = $yaml->get_raw );
+ $raw =~ s/^/$pad/mg;
+
+ return {
+ type => 'yaml',
+ raw => $raw,
+ data => $data
+ };
+}
+
+sub _make_pragma_token {
+ my ( $self, $line, $pragmas ) = @_;
+ return {
+ type => 'pragma',
+ raw => $line,
+ pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
+ };
+}
+
+sub _trim {
+ my $data = shift;
+
+ return '' unless defined $data;
+
+ $data =~ s/^\s+//;
+ $data =~ s/\s+$//;
+ return $data;
+}
+
+1;
+
+=head1 TAP GRAMMAR
+
+B<NOTE:> This grammar is slightly out of date. There's still some discussion
+about it and a new one will be provided when we have things better defined.
+
+The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
+stream-based protocol. In fact, it's quite legal to have an infinite stream.
+For the same reason that we don't apply regexes to streams, we're not using a
+formal grammar here. Instead, we parse the TAP in lines.
+
+For purposes for forward compatability, any result which does not match the
+following grammar is currently referred to as
+L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
+
+A formal grammar would look similar to the following:
+
+ (*
+ For the time being, I'm cheating on the EBNF by allowing
+ certain terms to be defined by POSIX character classes by
+ using the following syntax:
+
+ digit ::= [:digit:]
+
+ As far as I am aware, that's not valid EBNF. Sue me. I
+ didn't know how to write "char" otherwise (Unicode issues).
+ Suggestions welcome.
+ *)
+
+ tap ::= version? { comment | unknown } leading_plan lines
+ |
+ lines trailing_plan {comment}
+
+ version ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
+
+ leading_plan ::= plan skip_directive? "\n"
+
+ trailing_plan ::= plan "\n"
+
+ plan ::= '1..' nonNegativeInteger
+
+ lines ::= line {line}
+
+ line ::= (comment | test | unknown | bailout ) "\n"
+
+ test ::= status positiveInteger? description? directive?
+
+ status ::= 'not '? 'ok '
+
+ description ::= (character - (digit | '#')) {character - '#'}
+
+ directive ::= todo_directive | skip_directive
+
+ todo_directive ::= hash_mark 'TODO' ' ' {character}
+
+ skip_directive ::= hash_mark 'SKIP' ' ' {character}
+
+ comment ::= hash_mark {character}
+
+ hash_mark ::= '#' {' '}
+
+ bailout ::= 'Bail out!' {character}
+
+ unknown ::= { (character - "\n") }
+
+ (* POSIX character classes and other terminals *)
+
+ digit ::= [:digit:]
+ character ::= ([:print:] - "\n")
+ positiveInteger ::= ( digit - '0' ) {digit}
+ nonNegativeInteger ::= digit {digit}
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
+do is read through the code. There's no easy way of summarizing it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Result>,
+
+=cut
--- /dev/null
+package TAP::Parser::Iterator;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for general usage
+
+ # to subclass:
+ use vars qw(@ISA);
+ use TAP::Parser::Iterator ();
+ @ISA = qw(TAP::Parser::Iterator);
+ sub _initialize {
+ # see TAP::Object...
+ }
+
+=head1 DESCRIPTION
+
+This is a simple iterator base class that defines L<TAP::Parser>'s iterator
+API. See C<TAP::Parser::IteratorFactory> for the preferred way of creating
+iterators.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Provided by L<TAP::Object>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+B<Note:> this method is abstract and should be overridden.
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub next {
+ my $self = shift;
+ my $line = $self->next_raw;
+
+ # vms nit: When encountering 'not ok', vms often has the 'not' on a line
+ # by itself:
+ # not
+ # ok 1 - 'I hate VMS'
+ if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
+ $line .= ( $self->next_raw || '' );
+ }
+
+ return $line;
+}
+
+sub next_raw {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+=head3 C<handle_unicode>
+
+If necessary switch the input stream to handle unicode. This only has
+any effect for I/O handle based streams.
+
+The default implementation does nothing.
+
+=cut
+
+sub handle_unicode { }
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle-based should return an empty list.
+
+The default implementation does nothing.
+
+=cut
+
+sub get_select_handles {
+ return;
+}
+
+=head3 C<wait>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->wait;
+
+Return the C<wait> status for this iterator.
+
+=head3 C<exit>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->exit;
+
+Return the C<exit> status for this iterator.
+
+=cut
+
+sub wait {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+sub exit {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+You must override the abstract methods as noted above.
+
+=head2 Example
+
+L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
+There's not much point repeating it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Iterator::Array;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Array;
+ my @data = ('foo', 'bar', baz');
+ my $it = TAP::Parser::Iterator::Array->new(\@data);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for arrays of scalar content, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Takes one argument: an C<$array_ref>
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. For an array iterator this will always
+be zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. For an array iterator this will always
+be zero.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ chomp @$thing;
+ $self->{idx} = 0;
+ $self->{array} = $thing;
+ $self->{exit} = undef;
+ return $self;
+}
+
+sub wait { shift->exit }
+
+sub exit {
+ my $self = shift;
+ return 0 if $self->{idx} >= @{ $self->{array} };
+ return;
+}
+
+sub next_raw {
+ my $self = shift;
+ return $self->{array}->[ $self->{idx}++ ];
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Iterator::Process;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+use Config;
+use IO::Handle;
+
+@ISA = 'TAP::Parser::Iterator';
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Process;
+ my %args = (
+ command => ['python', 'setup.py', 'test'],
+ merge => 1,
+ setup => sub { ... },
+ teardown => sub { ... },
+ );
+ my $it = TAP::Parser::Iterator::Process->new(\%args);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for executing external processes, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a hashref of the form:
+
+ command => \@command_to_execute
+ merge => $attempt_merge_stderr_and_stdout?
+ setup => $callback_to_setup_command
+ teardown => $callback_to_teardown_command
+
+Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
+process if they are available. Falls back onto C<open()>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through the process output, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator's process.
+
+=head3 C<exit>
+
+Get the exit status for this iterator's process.
+
+=cut
+
+eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+if ($@) {
+ *_wait2exit = sub { $_[1] >> 8 };
+}
+else {
+ *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
+}
+
+sub _use_open3 {
+ my $self = shift;
+ return unless $Config{d_fork} || $IS_WIN32;
+ for my $module (qw( IPC::Open3 IO::Select )) {
+ eval "use $module";
+ return if $@;
+ }
+ return 1;
+}
+
+{
+ my $got_unicode;
+
+ sub _get_unicode {
+ return $got_unicode if defined $got_unicode;
+ eval 'use Encode qw(decode_utf8);';
+ $got_unicode = $@ ? 0 : 1;
+
+ }
+}
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+
+ my @command = @{ delete $args->{command} || [] }
+ or die "Must supply a command to execute";
+
+ # Private. Used to frig with chunk size during testing.
+ my $chunk_size = delete $args->{_chunk_size} || 65536;
+
+ my $merge = delete $args->{merge};
+ my ( $pid, $err, $sel );
+
+ if ( my $setup = delete $args->{setup} ) {
+ $setup->(@command);
+ }
+
+ my $out = IO::Handle->new;
+
+ if ( $self->_use_open3 ) {
+
+ # HOTPATCH {{{
+ my $xclose = \&IPC::Open3::xclose;
+ local $^W; # no warnings
+ local *IPC::Open3::xclose = sub {
+ my $fh = shift;
+ no strict 'refs';
+ return if ( fileno($fh) == fileno(STDIN) );
+ $xclose->($fh);
+ };
+
+ # }}}
+
+ if ($IS_WIN32) {
+ $err = $merge ? '' : '>&STDERR';
+ eval {
+ $pid = open3(
+ '<&STDIN', $out, $merge ? '' : $err,
+ @command
+ );
+ };
+ die "Could not execute (@command): $@" if $@;
+ if ( $] >= 5.006 ) {
+
+ # Kludge to avoid warning under 5.5
+ eval 'binmode($out, ":crlf")';
+ }
+ }
+ else {
+ $err = $merge ? '' : IO::Handle->new;
+ eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
+ die "Could not execute (@command): $@" if $@;
+ $sel = $merge ? undef : IO::Select->new( $out, $err );
+ }
+ }
+ else {
+ $err = '';
+ my $command
+ = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
+ open( $out, "$command|" )
+ or die "Could not execute ($command): $!";
+ }
+
+ $self->{out} = $out;
+ $self->{err} = $err;
+ $self->{sel} = $sel;
+ $self->{pid} = $pid;
+ $self->{exit} = undef;
+ $self->{chunk_size} = $chunk_size;
+
+ if ( my $teardown = delete $args->{teardown} ) {
+ $self->{teardown} = sub {
+ $teardown->(@command);
+ };
+ }
+
+ return $self;
+}
+
+=head3 C<handle_unicode>
+
+Upgrade the input stream to handle UTF8.
+
+=cut
+
+sub handle_unicode {
+ my $self = shift;
+
+ if ( $self->{sel} ) {
+ if ( _get_unicode() ) {
+
+ # Make sure our iterator has been constructed and...
+ my $next = $self->{_next} ||= $self->_next;
+
+ # ...wrap it to do UTF8 casting
+ $self->{_next} = sub {
+ my $line = $next->();
+ return decode_utf8($line) if defined $line;
+ return;
+ };
+ }
+ }
+ else {
+ if ( $] >= 5.008 ) {
+ eval 'binmode($self->{out}, ":utf8")';
+ }
+ }
+
+}
+
+##############################################################################
+
+sub wait { shift->{wait} }
+sub exit { shift->{exit} }
+
+sub _next {
+ my $self = shift;
+
+ if ( my $out = $self->{out} ) {
+ if ( my $sel = $self->{sel} ) {
+ my $err = $self->{err};
+ my @buf = ();
+ my $partial = ''; # Partial line
+ my $chunk_size = $self->{chunk_size};
+ return sub {
+ return shift @buf if @buf;
+
+ READ:
+ while ( my @ready = $sel->can_read ) {
+ for my $fh (@ready) {
+ my $got = sysread $fh, my ($chunk), $chunk_size;
+
+ if ( $got == 0 ) {
+ $sel->remove($fh);
+ }
+ elsif ( $fh == $err ) {
+ print STDERR $chunk; # echo STDERR
+ }
+ else {
+ $chunk = $partial . $chunk;
+ $partial = '';
+
+ # Make sure we have a complete line
+ unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
+ my $nl = rindex $chunk, "\n";
+ if ( $nl == -1 ) {
+ $partial = $chunk;
+ redo READ;
+ }
+ else {
+ $partial = substr( $chunk, $nl + 1 );
+ $chunk = substr( $chunk, 0, $nl );
+ }
+ }
+
+ push @buf, split /\n/, $chunk;
+ return shift @buf if @buf;
+ }
+ }
+ }
+
+ # Return partial last line
+ if ( length $partial ) {
+ my $last = $partial;
+ $partial = '';
+ return $last;
+ }
+
+ $self->_finish;
+ return;
+ };
+ }
+ else {
+ return sub {
+ if ( defined( my $line = <$out> ) ) {
+ chomp $line;
+ return $line;
+ }
+ $self->_finish;
+ return;
+ };
+ }
+ }
+ else {
+ return sub {
+ $self->_finish;
+ return;
+ };
+ }
+}
+
+sub next_raw {
+ my $self = shift;
+ return ( $self->{_next} ||= $self->_next )->();
+}
+
+sub _finish {
+ my $self = shift;
+
+ my $status = $?;
+
+ # Avoid circular refs
+ $self->{_next} = sub {return}
+ if $] >= 5.006;
+
+ # If we have a subprocess we need to wait for it to terminate
+ if ( defined $self->{pid} ) {
+ if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+ $status = $?;
+ }
+ }
+
+ ( delete $self->{out} )->close if $self->{out};
+
+ # If we have an IO::Select we also have an error handle to close.
+ if ( $self->{sel} ) {
+ ( delete $self->{err} )->close;
+ delete $self->{sel};
+ }
+ else {
+ $status = $?;
+ }
+
+ # Sometimes we get -1 on Windows. Presumably that means status not
+ # available.
+ $status = 0 if $IS_WIN32 && $status == -1;
+
+ $self->{wait} = $status;
+ $self->{exit} = $self->_wait2exit($status);
+
+ if ( my $teardown = $self->{teardown} ) {
+ $teardown->();
+ }
+
+ return $self;
+}
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {
+ my $self = shift;
+ return grep $_, ( $self->{out}, $self->{err} );
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Iterator::Stream;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Stream;
+ open( TEST, 'test.tap' );
+ my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for reading from filehandles, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a filehandle.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ $self->{fh} = $thing;
+ return $self;
+}
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. Always returns zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. Always returns zero.
+
+=cut
+
+sub wait { shift->exit }
+sub exit { shift->{fh} ? () : 0 }
+
+sub next_raw {
+ my $self = shift;
+ my $fh = $self->{fh};
+
+ if ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ return $line;
+ }
+ else {
+ $self->_finish;
+ return;
+ }
+}
+
+sub _finish {
+ my $self = shift;
+ close delete $self->{fh};
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::IteratorFactory;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::Iterator::Array ();
+use TAP::Parser::Iterator::Stream ();
+use TAP::Parser::Iterator::Process ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::IteratorFactory;
+ my $factory = TAP::Parser::IteratorFactory->new;
+ my $iter = $factory->make_iterator(\*TEST);
+ my $iter = $factory->make_iterator(\@array);
+ my $iter = $factory->make_iterator(\%hash);
+
+ my $line = $iter->next;
+
+=head1 DESCRIPTION
+
+This is a factory class for simple iterator wrappers for arrays, filehandles,
+and hashes. Unless you're subclassing, you probably won't need to use this
+module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_iterator>
+
+Create an iterator. The type of iterator created depends on the arguments to
+the constructor:
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $filehandle );
+
+Creates a I<stream> iterator (see L</make_stream_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $array_reference );
+
+Creates an I<array> iterator (see L</make_array_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference );
+
+Creates a I<process> iterator (see L</make_process_iterator>).
+
+=cut
+
+sub make_iterator {
+ my ( $proto, $thing ) = @_;
+
+ my $ref = ref $thing;
+ if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+ return $proto->make_stream_iterator($thing);
+ }
+ elsif ( $ref eq 'ARRAY' ) {
+ return $proto->make_array_iterator($thing);
+ }
+ elsif ( $ref eq 'HASH' ) {
+ return $proto->make_process_iterator($thing);
+ }
+ else {
+ die "Can't iterate with a $ref";
+ }
+}
+
+=head3 C<make_stream_iterator>
+
+Make a new stream iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Stream>.
+
+=head3 C<make_array_iterator>
+
+Make a new array iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Array>.
+
+=head3 C<make_process_iterator>
+
+Make a new process iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Process>.
+
+=cut
+
+sub make_stream_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Stream->new(@_);
+}
+
+sub make_array_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Array->new(@_);
+}
+
+sub make_process_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Process->new(@_);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=back
+
+=head2 Example
+
+ package MyIteratorFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyStreamIterator;
+ use TAP::Parser::IteratorFactory;
+
+ @ISA = qw( TAP::Parser::IteratorFactory );
+
+ # override stream iterator
+ sub make_stream_iterator {
+ my $proto = shift;
+ MyStreamIterator->new(@_);
+ }
+
+ 1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Multiplexer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use IO::Select;
+use TAP::Object ();
+
+use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
+use constant IS_VMS => $^O eq 'VMS';
+use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+
+@ISA = 'TAP::Object';
+
+=head1 NAME
+
+TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Multiplexer;
+
+ my $mux = TAP::Parser::Multiplexer->new;
+ $mux->add( $parser1, $stash1 );
+ $mux->add( $parser2, $stash2 );
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+ # do stuff
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
+Internally it calls select on the input file handles for those parsers
+to wait for one or more of them to have input available.
+
+See L<TAP::Harness> for an example of its use.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $mux = TAP::Parser::Multiplexer->new;
+
+Returns a new C<TAP::Parser::Multiplexer> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ $self->{select} = IO::Select->new;
+ $self->{avid} = []; # Parsers that can't select
+ $self->{count} = 0;
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $mux->add( $parser, $stash );
+
+Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
+reference that will be returned from C<next> along with the parser and
+the next result.
+
+=cut
+
+sub add {
+ my ( $self, $parser, $stash ) = @_;
+
+ if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
+ my $sel = $self->{select};
+
+ # We have to turn handles into file numbers here because by
+ # the time we want to remove them from our IO::Select they
+ # will already have been closed by the iterator.
+ my @filenos = map { fileno $_ } @handles;
+ for my $h (@handles) {
+ $sel->add( [ $h, $parser, $stash, @filenos ] );
+ }
+
+ $self->{count}++;
+ }
+ else {
+ push @{ $self->{avid} }, [ $parser, $stash ];
+ }
+}
+
+=head3 C<parsers>
+
+ my $count = $mux->parsers;
+
+Returns the number of parsers. Parsers are removed from the multiplexer
+when their input is exhausted.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->{count} + scalar @{ $self->{avid} };
+}
+
+sub _iter {
+ my $self = shift;
+
+ my $sel = $self->{select};
+ my $avid = $self->{avid};
+ my @ready = ();
+
+ return sub {
+
+ # Drain all the non-selectable parsers first
+ if (@$avid) {
+ my ( $parser, $stash ) = @{ $avid->[0] };
+ my $result = $parser->next;
+ shift @$avid unless defined $result;
+ return ( $parser, $stash, $result );
+ }
+
+ unless (@ready) {
+ return unless $sel->count;
+ @ready = $sel->can_read;
+ }
+
+ my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
+ my $result = $parser->next;
+
+ unless ( defined $result ) {
+ $sel->remove(@handles);
+ $self->{count}--;
+
+ # Force another can_read - we may now have removed a handle
+ # thought to have been ready.
+ @ready = ();
+ }
+
+ return ( $parser, $stash, $result );
+ };
+}
+
+=head3 C<next>
+
+Return a result from the next available parser. Returns a list
+containing the parser from which the result came, the stash that
+corresponds with that parser and the result.
+
+ my ( $parser, $stash, $result ) = $mux->next;
+
+If C<$result> is undefined the corresponding parser has reached the end
+of its input (and will automatically be removed from the multiplexer).
+
+When all parsers are exhausted an empty list will be returned.
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ if ( ! defined $result ) {
+ # End of this parser
+ }
+ else {
+ # Process result
+ }
+ }
+ else {
+ # All parsers finished
+ }
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Result;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+
+BEGIN {
+
+ # make is_* methods
+ my @attrs = qw( plan pragma test comment bailout version unknown yaml );
+ no strict 'refs';
+ for my $token (@attrs) {
+ my $method = "is_$token";
+ *$method = sub { return $token eq shift->type };
+ }
+}
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::Result - Base class for TAP::Parser output objects
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # abstract class - not meany to be used directly
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # directly:
+ use TAP::Parser::Result;
+ my $token = {...};
+ my $result = TAP::Parser::Result->new( $token );
+
+=head2 DESCRIPTION
+
+This is a simple base class used by L<TAP::Parser> to store objects that
+represent the current bit of test output data from TAP (usually a single
+line). Unless you're subclassing, you probably won't need to use this module
+directly.
+
+=head2 METHODS
+
+=head3 C<new>
+
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # to use directly:
+ my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+# new() implementation provided by TAP::Object
+
+sub _initialize {
+ my ( $self, $token ) = @_;
+ if ($token) {
+
+ # assign to a hash slice to make a shallow copy of the token.
+ # I guess we could assign to the hash as (by default) there are not
+ # contents, but that seems less helpful if someone wants to subclass us
+ @{$self}{ keys %$token } = values %$token;
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Boolean methods
+
+The following methods all return a boolean value and are to be overridden in
+the appropriate subclass.
+
+=over 4
+
+=item * C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+ 1..3
+
+=item * C<is_pragma>
+
+Indicates whether or not this is a pragma line.
+
+ pragma +strict
+
+=item * C<is_test>
+
+Indicates whether or not this is a test line.
+
+ ok 1 Is OK!
+
+=item * C<is_comment>
+
+Indicates whether or not this is a comment.
+
+ # this is a comment
+
+=item * C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+ Bail out! We're out of dilithium crystals.
+
+=item * C<is_version>
+
+Indicates whether or not this is a TAP version line.
+
+ TAP version 4
+
+=item * C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+ ... this line is junk ...
+
+=item * C<is_yaml>
+
+Indicates whether or not this is a YAML chunk.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head3 C<raw>
+
+ print $result->raw;
+
+Returns the original line of text which was parsed.
+
+=cut
+
+sub raw { shift->{raw} }
+
+##############################################################################
+
+=head3 C<type>
+
+ my $type = $result->type;
+
+Returns the "type" of a token, such as C<comment> or C<test>.
+
+=cut
+
+sub type { shift->{type} }
+
+##############################################################################
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=cut
+
+sub as_string { shift->{raw} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut.
+
+=cut
+
+sub is_ok {1}
+
+##############################################################################
+
+=head3 C<passed>
+
+Deprecated. Please use C<is_ok> instead.
+
+=cut
+
+sub passed {
+ warn 'passed() is deprecated. Please use "is_ok()"';
+ shift->is_ok;
+}
+
+##############################################################################
+
+=head3 C<has_directive>
+
+ if ( $result->has_directive ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO or SKIP directive.
+
+=cut
+
+sub has_directive {
+ my $self = shift;
+ return ( $self->has_todo || $self->has_skip );
+}
+
+##############################################################################
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO directive.
+
+=cut
+
+sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) {
+ ...
+ }
+
+Indicates whether or not the given result has a SKIP directive.
+
+=cut
+
+sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
+
+=head3 C<set_directive>
+
+Set the directive associated with this token. Used internally to fake
+TODO tests.
+
+=cut
+
+sub set_directive {
+ my ( $self, $dir ) = @_;
+ $self->{directive} = $dir;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+Remember: if you want your subclass to be automatically used by the parser,
+you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
+
+If you're creating a completely new result I<type>, you'll probably need to
+subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
+
+=head2 Example
+
+ package MyResult;
+
+ use strict;
+ use vars '@ISA';
+
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ sub as_string { 'My results all look the same' }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::ResultFactory>,
+L<TAP::Parser::Result::Bailout>,
+L<TAP::Parser::Result::Comment>,
+L<TAP::Parser::Result::Plan>,
+L<TAP::Parser::Result::Pragma>,
+L<TAP::Parser::Result::Test>,
+L<TAP::Parser::Result::Unknown>,
+L<TAP::Parser::Result::Version>,
+L<TAP::Parser::Result::YAML>,
+
+=cut
--- /dev/null
+package TAP::Parser::Result::Bailout;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Bailout - Bailout result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a bail out line is encountered.
+
+ 1..5
+ ok 1 - woo hooo!
+ Bail out! Well, so much for "woo hooo!"
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=cut
+
+sub explanation { shift->{bailout} }
+sub as_string { shift->{bailout} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Comment;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Comment - Comment result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a comment line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+ # this is a comment
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+Note that this method merely returns the comment preceded by a '# '.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=cut
+
+sub comment { shift->{comment} }
+sub as_string { shift->{raw} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Plan;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Plan - Plan result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a plan line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub plan { '1..' . shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<tests_planned>
+
+ my $planned = $result->tests_planned;
+
+Returns the number of tests planned. For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=cut
+
+sub tests_planned { shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $plan->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<explanation>
+
+ my $explanation = $plan->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+=head3 C<todo_list>
+
+ my $todo = $result->todo_list;
+ for ( @$todo ) {
+ ...
+ }
+
+=cut
+
+sub todo_list { shift->{todo_list} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Pragma;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Pragma - TAP pragma token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a pragma is encountered.
+
+ TAP version 13
+ pragma +strict, -foo
+
+Pragmas are only supported from TAP version 13 onwards.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<pragmas>
+
+if ( $result->is_pragma ) {
+ @pragmas = $result->pragmas;
+}
+
+=cut
+
+sub pragmas {
+ my @pragmas = @{ shift->{pragmas} };
+ return wantarray ? @pragmas : \@pragmas;
+}
+
+1;
--- /dev/null
+package TAP::Parser::Result::Test;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system. Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+ my ( $self, $number ) = @_;
+ $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false. See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+ my $self = shift;
+
+ return if $self->is_unplanned;
+
+ # TODO directives reverse the sense of a test.
+ return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+ my $self = shift;
+ return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated. Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+ warn 'actual_passed() is deprecated. Please use "is_actual_ok()"';
+ goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+ if ( $test->todo_passed ) {
+ # test unexpectedly succeeded
+ }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+ my $self = shift;
+ return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn 'todo_failed() is deprecated. Please use "todo_passed()"';
+ goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+This method prints the test as a string. It will probably be similar, but
+not necessarily identical, to the original test line. Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line. If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ my $string = $self->ok . " " . $self->number;
+ if ( my $description = $self->description ) {
+ $string .= " $description";
+ }
+ if ( my $directive = $self->directive ) {
+ my $explanation = $self->explanation;
+ $string .= " # $directive $explanation";
+ }
+ return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+ $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+ print <<'END';
+ ok 1
+ ok 2
+ 1..1
+ END
+
+=cut
+
+sub is_unplanned {
+ my $self = shift;
+ return ( $self->{unplanned} || '' ) unless @_;
+ $self->{unplanned} = !!shift;
+ return $self;
+}
+
+1;
--- /dev/null
+package TAP::Parser::Result::Unknown;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Unknown - Unknown result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if the parser does not recognize the token line. For example:
+
+ 1..5
+ VERSION 7
+ ok 1 - woo hooo!
+ ... woo hooo! is cool!
+
+In the above "TAP", the second and fourth lines will generate "Unknown"
+tokens.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Result::Version;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Version - TAP syntax version token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a version line is encountered.
+
+ TAP version 13
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 13.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<version>
+
+ if ( $result->is_version ) {
+ print $result->version;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub version { shift->{version} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::YAML;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::YAML - YAML result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a YAML block is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<data>
+
+ if ( $result->is_yaml ) {
+ print $result->data;
+ }
+
+Return the parsed YAML data for this result
+
+=cut
+
+sub data { shift->{data} }
+
+1;
--- /dev/null
+package TAP::Parser::ResultFactory;
+
+use strict;
+use vars qw($VERSION @ISA %CLASS_FOR);
+
+use TAP::Object ();
+use TAP::Parser::Result::Bailout ();
+use TAP::Parser::Result::Comment ();
+use TAP::Parser::Result::Plan ();
+use TAP::Parser::Result::Pragma ();
+use TAP::Parser::Result::Test ();
+use TAP::Parser::Result::Unknown ();
+use TAP::Parser::Result::Version ();
+use TAP::Parser::Result::YAML ();
+
+@ISA = 'TAP::Object';
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::ResultFactory;
+ my $token = {...};
+ my $factory = TAP::Parser::ResultFactory->new;
+ my $result = $factory->make_result( $token );
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head2 DESCRIPTION
+
+This is a simple factory class which returns a L<TAP::Parser::Result> subclass
+representing the current bit of test data from TAP (usually a single line).
+It is used primarily by L<TAP::Parser::Grammar>. Unless you're subclassing,
+you probably won't need to use this module directly.
+
+=head2 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_result>
+
+Returns an instance the appropriate class for the test token passed in.
+
+ my $result = TAP::Parser::ResultFactory->make_result($token);
+
+Can also be called as an instance method.
+
+=cut
+
+sub make_result {
+ my ( $proto, $token ) = @_;
+ my $type = $token->{type};
+ return $proto->class_for($type)->new($token);
+}
+
+=head3 C<class_for>
+
+Takes one argument: C<$type>. Returns the class for this $type, or C<croak>s
+with an error.
+
+=head3 C<register_type>
+
+Takes two arguments: C<$type>, C<$class>
+
+This lets you override an existing type with your own custom type, or register
+a completely new type, eg:
+
+ # create a custom result type:
+ package MyResult;
+ use strict;
+ use vars qw(@ISA);
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ # use it:
+ my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
+
+Your custom type should then be picked up automatically by the L<TAP::Parser>.
+
+=cut
+
+BEGIN {
+ %CLASS_FOR = (
+ plan => 'TAP::Parser::Result::Plan',
+ pragma => 'TAP::Parser::Result::Pragma',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+ );
+}
+
+sub class_for {
+ my ( $class, $type ) = @_;
+
+ # return target class:
+ return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
+
+ # or complain:
+ require Carp;
+ Carp::croak("Could not determine class for result type '$type'");
+}
+
+sub register_type {
+ my ( $class, $type, $rclass ) = @_;
+
+ # register it blindly, assume they know what they're doing
+ $CLASS_FOR{$type} = $rclass;
+ return $class;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=item 2
+
+C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
+This I<will> change in a future version!
+
+=item 3
+
+L<TAP::Parser::Result> subclasses will register themselves with
+L<TAP::Parser::ResultFactory> directly:
+
+ package MyFooResult;
+ TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
+
+Of course, it's up to you to decide whether or not to ignore them.
+
+=back
+
+=head2 Example
+
+ package MyResultFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyResult;
+ use TAP::Parser::ResultFactory;
+
+ @ISA = qw( TAP::Parser::ResultFactory );
+
+ # force all results to be 'MyResult'
+ sub class_for {
+ return 'MyResult';
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<TAP::Parser>,
+L<TAP::Parser::Result>,
+L<TAP::Parser::Grammar>
+
+=cut
--- /dev/null
+package TAP::Parser::Scheduler;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use TAP::Parser::Scheduler::Job;
+use TAP::Parser::Scheduler::Spinner;
+
+=head1 NAME
+
+TAP::Parser::Scheduler - Schedule tests during parallel testing
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $sched = TAP::Parser::Scheduler->new;
+
+Returns a new C<TAP::Parser::Scheduler> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ croak "Need a number of key, value pairs" if @_ % 2;
+
+ my %args = @_;
+ my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+ my $rules = delete $args{rules} || { par => '**' };
+
+ croak "Unknown arg(s): ", join ', ', sort keys %args
+ if keys %args;
+
+ # Turn any simple names into a name, description pair. TODO: Maybe
+ # construct jobs here?
+ my $self = bless {}, $class;
+
+ $self->_set_rules( $rules, $tests );
+
+ return $self;
+}
+
+# Build the scheduler data structure.
+#
+# SCHEDULER-DATA ::= JOB
+# || ARRAY OF ARRAY OF SCHEDULER-DATA
+#
+# The nested arrays are the key to scheduling. The outer array contains
+# a list of things that may be executed in parallel. Whenever an
+# eligible job is sought any element of the outer array that is ready to
+# execute can be selected. The inner arrays represent sequential
+# execution. They can only proceed when the first job is ready to run.
+
+sub _set_rules {
+ my ( $self, $rules, $tests ) = @_;
+ my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
+ map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+ my $schedule = $self->_rule_clause( $rules, \@tests );
+
+ # If any tests are left add them as a sequential block at the end of
+ # the run.
+ $schedule = [ [ $schedule, @tests ] ] if @tests;
+
+ $self->{schedule} = $schedule;
+}
+
+sub _rule_clause {
+ my ( $self, $rule, $tests ) = @_;
+ croak 'Rule clause must be a hash'
+ unless 'HASH' eq ref $rule;
+
+ my @type = keys %$rule;
+ croak 'Rule clause must have exactly one key'
+ unless @type == 1;
+
+ my %handlers = (
+ par => sub {
+ [ map { [$_] } @_ ];
+ },
+ seq => sub { [ [@_] ] },
+ );
+
+ my $handler = $handlers{ $type[0] }
+ || croak 'Unknown scheduler type: ', $type[0];
+ my $val = $rule->{ $type[0] };
+
+ return $handler->(
+ map {
+ 'HASH' eq ref $_
+ ? $self->_rule_clause( $_, $tests )
+ : $self->_expand( $_, $tests )
+ } 'ARRAY' eq ref $val ? @$val : $val
+ );
+}
+
+sub _glob_to_regexp {
+ my ( $self, $glob ) = @_;
+ my $nesting;
+ my $pattern;
+
+ while (1) {
+ if ( $glob =~ /\G\*\*/gc ) {
+
+ # ** is any number of characters, including /, within a pathname
+ $pattern .= '.*?';
+ }
+ elsif ( $glob =~ /\G\*/gc ) {
+
+ # * is zero or more characters within a filename/directory name
+ $pattern .= '[^/]*';
+ }
+ elsif ( $glob =~ /\G\?/gc ) {
+
+ # ? is exactly one character within a filename/directory name
+ $pattern .= '[^/]';
+ }
+ elsif ( $glob =~ /\G\{/gc ) {
+
+ # {foo,bar,baz} is any of foo, bar or baz.
+ $pattern .= '(?:';
+ ++$nesting;
+ }
+ elsif ( $nesting and $glob =~ /\G,/gc ) {
+
+ # , is only special inside {}
+ $pattern .= '|';
+ }
+ elsif ( $nesting and $glob =~ /\G\}/gc ) {
+
+ # } that matches { is special. But unbalanced } are not.
+ $pattern .= ')';
+ --$nesting;
+ }
+ elsif ( $glob =~ /\G(\\.)/gc ) {
+
+ # A quoted literal
+ $pattern .= $1;
+ }
+ elsif ( $glob =~ /\G([\},])/gc ) {
+
+ # Sometimes meta characters
+ $pattern .= '\\' . $1;
+ }
+ else {
+
+ # Eat everything that is not a meta character.
+ $glob =~ /\G([^{?*\\\},]*)/gc;
+ $pattern .= quotemeta $1;
+ }
+ return $pattern if pos $glob == length $glob;
+ }
+}
+
+sub _expand {
+ my ( $self, $name, $tests ) = @_;
+
+ my $pattern = $self->_glob_to_regexp($name);
+ $pattern = qr/^ $pattern $/x;
+ my @match = ();
+
+ for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+ if ( $tests->[$ti]->filename =~ $pattern ) {
+ push @match, splice @$tests, $ti, 1;
+ $ti--;
+ }
+ }
+
+ return @match;
+}
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+ my $self = shift;
+ my @all = $self->_gather( $self->{schedule} );
+ $self->{count} = @all;
+ @all;
+}
+
+sub _gather {
+ my ( $self, $rule ) = @_;
+ return unless defined $rule;
+ return $rule unless 'ARRAY' eq ref $rule;
+ return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job or C<undef> if none are available. Returns
+a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
+jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+ my $self = shift;
+ $self->{count} ||= $self->get_all;
+ my @jobs = $self->_find_next_job( $self->{schedule} );
+ if (@jobs) {
+ --$self->{count};
+ return $jobs[0];
+ }
+
+ return TAP::Parser::Scheduler::Spinner->new
+ if $self->{count};
+
+ return;
+}
+
+sub _not_empty {
+ my $ar = shift;
+ return 1 unless 'ARRAY' eq ref $ar;
+ foreach (@$ar) {
+ return 1 if _not_empty($_);
+ }
+ return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+ my ( $self, $rule ) = @_;
+
+ my @queue = ();
+ my $index = 0;
+ while ( $index < @$rule ) {
+ my $seq = $rule->[$index];
+
+ # Prune any exhausted items.
+ shift @$seq while @$seq && _is_empty( $seq->[0] );
+ if (@$seq) {
+ if ( defined $seq->[0] ) {
+ if ( 'ARRAY' eq ref $seq->[0] ) {
+ push @queue, $seq;
+ }
+ else {
+ my $job = splice @$seq, 0, 1, undef;
+ $job->on_finish( sub { shift @$seq } );
+ return $job;
+ }
+ }
+ ++$index;
+ }
+ else {
+
+ # Remove the empty sub-array from the array
+ splice @$rule, $index, 1;
+ }
+ }
+
+ for my $seq (@queue) {
+ if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
+ return @jobs;
+ }
+ }
+
+ return;
+}
+
+=head3 C<as_string>
+
+Return a human readable representation of the scheduling tree.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ return $self->_as_string( $self->{schedule} );
+}
+
+sub _as_string {
+ my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
+ my $pad = ' ' x 2;
+ my $indent = $pad x $depth;
+ if ( !defined $rule ) {
+ return "$indent(undef)\n";
+ }
+ elsif ( 'ARRAY' eq ref $rule ) {
+ return unless @$rule;
+ my $type = ( 'par', 'seq' )[ $depth % 2 ];
+ return join(
+ '', "$indent$type:\n",
+ map { $self->_as_string( $_, $depth + 1 ) } @$rule
+ );
+ }
+ else {
+ return "$indent'" . $rule->filename . "'\n";
+ }
+}
+
+1;
--- /dev/null
+package TAP::Parser::Scheduler::Job;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Job - A single testing job.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Job;
+
+=head1 DESCRIPTION
+
+Represents a single test 'job'.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Job->new(
+ $name, $desc
+ );
+
+Returns a new C<TAP::Parser::Scheduler::Job> object.
+
+=cut
+
+sub new {
+ my ( $class, $name, $desc, @ctx ) = @_;
+ return bless {
+ filename => $name,
+ description => $desc,
+ @ctx ? ( context => \@ctx ) : (),
+ }, $class;
+}
+
+=head3 C<on_finish>
+
+Register a closure to be called when this job is destroyed.
+
+=cut
+
+sub on_finish {
+ my ( $self, $cb ) = @_;
+ $self->{on_finish} = $cb;
+}
+
+=head3 C<finish>
+
+Called when a job is complete to unlock it.
+
+=cut
+
+sub finish {
+ my $self = shift;
+ if ( my $cb = $self->{on_finish} ) {
+ $cb->($self);
+ }
+}
+
+=head3 C<filename>
+
+=head3 C<description>
+
+=head3 C<context>
+
+=cut
+
+sub filename { shift->{filename} }
+sub description { shift->{description} }
+sub context { @{ shift->{context} || [] } }
+
+=head3 C<as_array_ref>
+
+For backwards compatibility in callbacks.
+
+=cut
+
+sub as_array_ref {
+ my $self = shift;
+ return [ $self->filename, $self->description, $self->{context} ||= [] ];
+}
+
+=head3 C<is_spinner>
+
+Returns false indicating that this is a real job rather than a
+'spinner'. Spinners are returned when the scheduler still has pending
+jobs but can't (because of locking) return one right now.
+
+=cut
+
+sub is_spinner {0}
+
+1;
--- /dev/null
+package TAP::Parser::Scheduler::Spinner;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Spinner - A no-op job.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Spinner;
+
+=head1 DESCRIPTION
+
+A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
+the harness to spin (keep executing tests) while the scheduler can't
+return a real job.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Spinner->new;
+
+Returns a new C<TAP::Parser::Scheduler::Spinner> object.
+
+=cut
+
+sub new { bless {}, shift }
+
+=head3 C<is_spinner>
+
+Returns true indicating that is a 'spinner' job. Spinners are returned
+when the scheduler still has pending jobs but can't (because of locking)
+return one right now.
+
+=cut
+
+sub is_spinner {1}
+
+1;
--- /dev/null
+package TAP::Parser::Source;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::IteratorFactory ();
+
+@ISA = qw(TAP::Object);
+
+# Causes problem on MacOS and shouldn't be necessary anyway
+#$SIG{CHLD} = sub { wait };
+
+=head1 NAME
+
+TAP::Parser::Source - Stream output from some source
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new;
+ my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a command and hopefully returns a stream from it.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{switches} = [];
+ _autoflush( \*STDOUT );
+ _autoflush( \*STDERR );
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+ my $source = $source->source;
+ $source->source(['./some_prog some_test_file']);
+
+ # or
+ $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
+
+Getter/setter for the source. The source should generally consist of an array
+reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>,
+should return a filehandle which returns successive rows of TAP. C<croaks> if
+it doesn't get an arrayref.
+
+=cut
+
+sub source {
+ my $self = shift;
+ return $self->{source} unless @_;
+ unless ( 'ARRAY' eq ref $_[0] ) {
+ $self->_croak('Argument to &source must be an array reference');
+ }
+ $self->{source} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream;
+
+Returns a L<TAP::Parser::Iterator> stream of the output generated by executing
+C<source>. C<croak>s if there was no command found.
+
+Must be passed an object that implements a C<make_iterator> method.
+Typically this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+ my @command = $self->_get_command
+ or $self->_croak('No command found!');
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge
+ }
+ );
+}
+
+sub _get_command { return @{ shift->source || [] } }
+
+##############################################################################
+
+=head3 C<merge>
+
+ my $merge = $source->merge;
+
+Sets or returns the flag that dictates whether STDOUT and STDERR are merged.
+
+=cut
+
+sub merge {
+ my $self = shift;
+ return $self->{merge} unless @_;
+ $self->{merge} = shift;
+ return $self;
+}
+
+# Turns on autoflush for the handle passed
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyRubySource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source;
+
+ @ISA = qw( TAP::Parser::Source );
+
+ # expect $source->(['mytest.rb', 'cmdline', 'args']);
+ sub source {
+ my ($self, $args) = @_;
+ my ($rb_file) = @$args;
+ croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+ return $self->SUPER::source(['/usr/bin/ruby', @$args]);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source::Perl>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Source::Perl;
+
+use strict;
+use Config;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::Source;
+use TAP::Parser::Utils qw( split_shell );
+
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new;
+ my $stream = $perl->source( [ $filename, @args ] )->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a filename and hopefully returns a stream from it. The filename should
+be the name of a Perl program.
+
+Note that this is a subclass of L<TAP::Parser::Source>. See that module for
+more methods.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+Returns a new C<TAP::Parser::Source::Perl> object.
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+Getter/setter the name of the test program and any arguments it requires.
+
+ my ($filename, @args) = @{ $perl->source };
+ $perl->source( [ $filename, @args ] );
+
+C<croak>s if C<$filename> could not be found.
+
+=cut
+
+sub source {
+ my $self = shift;
+ $self->_croak("Cannot find ($_[0][0])")
+ if @_ && !-f $_[0][0];
+ return $self->SUPER::source(@_);
+}
+
+=head3 C<switches>
+
+ my $switches = $perl->switches;
+ my @switches = $perl->switches;
+ $perl->switches( \@switches );
+
+Getter/setter for the additional switches to pass to the perl executable. One
+common switch would be to set an include directory:
+
+ $perl->switches( ['-Ilib'] );
+
+=cut
+
+sub switches {
+ my $self = shift;
+ unless (@_) {
+ return wantarray ? @{ $self->{switches} } : $self->{switches};
+ }
+ my $switches = shift;
+ $self->{switches} = [@$switches]; # force a copy
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream($parser);
+
+Returns a stream of the output generated by executing C<source>. Must be
+passed an object that implements a C<make_iterator> method. Typically
+this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+
+ my @switches = $self->_switches;
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+
+ # Filter out any -I switches to be handled as libs later.
+ #
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ #
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ my @filtered_switches;
+ for (@switches) {
+ if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+ push @libs, $1;
+ }
+ else {
+ push @filtered_switches, $_;
+ }
+ }
+ @switches = @filtered_switches;
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB}
+ = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $previous = $ENV{PERL5LIB};
+ my $teardown = sub {
+ if ( defined $previous ) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ # Taint mode ignores environment variables so we must retranslate
+ # PERL5LIB as -I switches and place PERL5OPT on the command line
+ # in order that it be seen.
+ if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
+ push @switches, $self->_libs2switches(@libs);
+ push @switches, split_shell( $ENV{PERL5OPT} );
+ }
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my $self = shift;
+ my @switches = @_;
+ my ( $file, @args ) = @{ $self->source };
+ my $command = $self->_get_perl;
+
+# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
+#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file, @args );
+ return @command;
+}
+
+sub _get_command {
+ my $self = shift;
+ return $self->_get_command_for_switches( $self->_switches );
+}
+
+sub _libs2switches {
+ my $self = shift;
+ return map {"-I$_"} grep {$_} @_;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my $file = shift;
+ local *TEST;
+ my $shebang;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ close(TEST) or print "Can't close $file. $!\n";
+ }
+ else {
+ print "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ unless ( exists $shebang_for{$file} ) {
+ $shebang_for{$file} = _read_shebang($file);
+ }
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
+sub _switches {
+ my $self = shift;
+ my ( $file, @args ) = @{ $self->source };
+ my @switches = (
+ $self->switches,
+ );
+
+ my $shebang = $self->shebang($file);
+ return unless defined $shebang;
+
+ my $taint = $self->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
+
+ # Quote the argument if we're VMS, since VMS will downcase anything
+ # not quoted.
+ if (IS_VMS) {
+ for (@switches) {
+ $_ = qq["$_"];
+ }
+ }
+
+ return @switches;
+}
+
+sub _get_perl {
+ my $self = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyPerlSource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source::Perl;
+
+ @ISA = qw( TAP::Parser::Source::Perl );
+
+ sub source {
+ my ($self, $args) = @_;
+ if ($args) {
+ $self->{file} = $args->[0];
+ return $self->SUPER::source($args);
+ }
+ return $self->SUPER::source;
+ }
+
+ # use the version of perl from the shebang line in the test file
+ sub _get_perl {
+ my $self = shift;
+ if (my $shebang = $self->shebang( $self->{file} )) {
+ $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+ return $1 if $1;
+ }
+ return $self->SUPER::_get_perl(@_);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+
+=cut
--- /dev/null
+package TAP::Parser::Utils;
+
+use strict;
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( split_shell );
+
+=head1 NAME
+
+TAP::Parser::Utils - Internal TAP::Parser utilities
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Utils qw( split_shell )
+ my @switches = split_shell( $arg );
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+=head2 INTERFACE
+
+=head3 C<split_shell>
+
+Shell style argument parsing. Handles backslash escaping, single and
+double quoted strings but not shell substitutions.
+
+Pass one or more strings containing shell escaped arguments. The return
+value is an array of arguments parsed from the input strings according
+to (approximate) shell parsing rules. It's legal to pass C<undef> in
+which case an empty array will be returned. That makes it possible to
+
+ my @args = split_shell( $ENV{SOME_ENV_VAR} );
+
+without worrying about whether the environment variable exists.
+
+This is used to split HARNESS_PERL_ARGS into individual switches.
+
+=cut
+
+sub split_shell {
+ my @parts = ();
+
+ for my $switch ( grep defined && length, @_ ) {
+ push @parts, $1 while $switch =~ /
+ (
+ (?: [^\\"'\s]+
+ | \\.
+ | " (?: \\. | [^"] )* "
+ | ' (?: \\. | [^'] )* '
+ )+
+ ) /xg;
+ }
+
+ for (@parts) {
+ s/ \\(.) | ['"] /defined $1 ? $1 : ''/exg;
+ }
+
+ return @parts;
+}
+
+1;
--- /dev/null
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
+
+# TODO:
+# Handle blessed object syntax
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
+my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
+my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
+my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
+my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
+
+# new() implementation supplied by TAP::Object
+
+sub read {
+ my $self = shift;
+ my $obj = shift;
+
+ die "Must have a code reference to read input from"
+ unless ref $obj eq 'CODE';
+
+ $self->{reader} = $obj;
+ $self->{capture} = [];
+
+ #Â Prime the reader
+ $self->_next;
+ return unless $self->{next};
+
+ my $doc = $self->_read;
+
+ # The terminator is mandatory otherwise we'd consume a line from the
+ # iterator that doesn't belong to us. If we want to remove this
+ # restriction we'll have to implement look-ahead in the iterators.
+ # Which might not be a bad idea.
+ my $dots = $self->_peek;
+ die "Missing '...' at end of YAMLish"
+ unless defined $dots
+ and $dots =~ $IS_END_YAML;
+
+ delete $self->{reader};
+ delete $self->{next};
+
+ return $doc;
+}
+
+sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
+
+sub _peek {
+ my $self = shift;
+ return $self->{next} unless wantarray;
+ my $line = $self->{next};
+ $line =~ /^ (\s*) (.*) $ /x;
+ return ( $2, length $1 );
+}
+
+sub _next {
+ my $self = shift;
+ die "_next called with no reader"
+ unless $self->{reader};
+ my $line = $self->{reader}->();
+ $self->{next} = $line;
+ push @{ $self->{capture} }, $line;
+}
+
+sub _read {
+ my $self = shift;
+
+ my $line = $self->_peek;
+
+ # Do we have a document header?
+ if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) {
+ $self->_next;
+
+ return $self->_read_scalar($1) if defined $1; # Inline?
+
+ my ( $next, $indent ) = $self->_peek;
+
+ if ( $next =~ /^ - /x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $next =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $next, $indent );
+ }
+ elsif ( $next =~ $IS_END_YAML ) {
+ die "Premature end of YAMLish";
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$next'";
+ }
+ }
+ else {
+ die "YAMLish document header not found";
+ }
+}
+
+# Parse a double quoted string
+sub _read_qq {
+ my $self = shift;
+ my $str = shift;
+
+ unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
+ die "Internal: not a quoted string";
+ }
+
+ $str =~ s/\\"/"/gx;
+ $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
+ / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
+ return $str;
+}
+
+# Parse a scalar string to the actual scalar
+sub _read_scalar {
+ my $self = shift;
+ my $string = shift;
+
+ return undef if $string eq '~';
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ if ( $string eq '>' || $string eq '|' ) {
+
+ my ( $line, $indent ) = $self->_peek;
+ die "Multi-line scalar content missing" unless defined $line;
+
+ my @multiline = ($line);
+
+ while (1) {
+ $self->_next;
+ my ( $next, $ind ) = $self->_peek;
+ last if $ind < $indent;
+
+ my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
+ push @multiline, $pad . $next;
+ }
+
+ return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
+ }
+
+ if ( $string =~ /^ ' (.*) ' $/x ) {
+ ( my $rv = $1 ) =~ s/''/'/g;
+ return $rv;
+ }
+
+ if ( $string =~ $IS_QQ_STRING ) {
+ return $self->_read_qq($string);
+ }
+
+ if ( $string =~ /^['"]/ ) {
+
+ # A quote with folding... we don't support that
+ die __PACKAGE__ . " does not support multi-line quoted scalars";
+ }
+
+ # Regular unquoted string
+ return $string;
+}
+
+sub _read_nested {
+ my $self = shift;
+
+ my ( $line, $indent ) = $self->_peek;
+
+ if ( $line =~ /^ -/x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $line, $indent );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+}
+
+# Parse an array
+sub _read_array {
+ my ( $self, $limit ) = @_;
+
+ my $ar = [];
+
+ while (1) {
+ my ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+
+ if ( $indent > $limit ) {
+ die "Array line over-indented";
+ }
+
+ if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
+ $indent += length $1;
+ $line =~ s/-\s+//;
+ push @$ar, $self->_read_hash( $line, $indent );
+ }
+ elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
+ die "Unexpected start of YAMLish" if $line =~ /^---/;
+ $self->_next;
+ push @$ar, $self->_read_scalar($1);
+ }
+ elsif ( $line =~ /^ - \s* $/x ) {
+ $self->_next;
+ push @$ar, $self->_read_nested;
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ $self->_next;
+ push @$ar, $self->_read_hash( $line, $indent, );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+ }
+
+ return $ar;
+}
+
+sub _read_hash {
+ my ( $self, $line, $limit ) = @_;
+
+ my $indent;
+ my $hash = {};
+
+ while (1) {
+ die "Badly formed hash line: '$line'"
+ unless $line =~ $HASH_LINE;
+
+ my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
+ $self->_next;
+
+ if ( defined $value ) {
+ $hash->{$key} = $self->_read_scalar($value);
+ }
+ else {
+ $hash->{$key} = $self->_read_nested;
+ }
+
+ ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+ }
+
+ return $hash;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Note that parts of this code were derived from L<YAML::Tiny> with the
+permission of Adam Kennedy.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Reader> object.
+
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+
+=head2 Instance Methods
+
+=head3 C<read>
+
+ my $got = $reader->read($stream);
+
+Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
+represents.
+
+=head3 C<get_raw>
+
+ my $source = $reader->get_source;
+
+Return the raw YAMLish source from the most recent C<read>.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
+the YAML matching regular expressions for this module.
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+Portions copyright 2006-2008 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
--- /dev/null
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
+my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
+
+my @UNPRINTABLE = qw(
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1a e x1c x1d x1e x1f
+);
+
+# new() implementation supplied by TAP::Object
+
+sub write {
+ my $self = shift;
+
+ die "Need something to write"
+ unless @_;
+
+ my $obj = shift;
+ my $out = shift || \*STDOUT;
+
+ die "Need a reference to something I can write to"
+ unless ref $out;
+
+ $self->{writer} = $self->_make_writer($out);
+
+ $self->_write_obj( '---', $obj );
+ $self->_put('...');
+
+ delete $self->{writer};
+}
+
+sub _make_writer {
+ my $self = shift;
+ my $out = shift;
+
+ my $ref = ref $out;
+
+ if ( 'CODE' eq $ref ) {
+ return $out;
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ return sub { push @$out, shift };
+ }
+ elsif ( 'SCALAR' eq $ref ) {
+ return sub { $$out .= shift() . "\n" };
+ }
+ elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
+ return sub { print $out shift(), "\n" };
+ }
+
+ die "Can't write to $out";
+}
+
+sub _put {
+ my $self = shift;
+ $self->{writer}->( join '', @_ );
+}
+
+sub _enc_scalar {
+ my $self = shift;
+ my $val = shift;
+ my $rule = shift;
+
+ return '~' unless defined $val;
+
+ if ( $val =~ /$rule/ ) {
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/"/\\"/g;
+ $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
+ return qq{"$val"};
+ }
+
+ if ( length($val) == 0 or $val =~ /\s/ ) {
+ $val =~ s/'/''/;
+ return "'$val'";
+ }
+
+ return $val;
+}
+
+sub _write_obj {
+ my $self = shift;
+ my $prefix = shift;
+ my $obj = shift;
+ my $indent = shift || 0;
+
+ if ( my $ref = ref $obj ) {
+ my $pad = ' ' x $indent;
+ if ( 'HASH' eq $ref ) {
+ if ( keys %$obj ) {
+ $self->_put($prefix);
+ for my $key ( sort keys %$obj ) {
+ my $value = $obj->{$key};
+ $self->_write_obj(
+ $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
+ $value, $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' {}' );
+ }
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ if (@$obj) {
+ $self->_put($prefix);
+ for my $value (@$obj) {
+ $self->_write_obj(
+ $pad . '-', $value,
+ $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' []' );
+ }
+ }
+ else {
+ die "Don't know how to encode $ref";
+ }
+ }
+ else {
+ $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 3.17
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::YAMLish::Writer;
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+
+ # Write to an array...
+ $yw->write( $data, \@some_array );
+
+ # ...an open file handle...
+ $yw->write( $data, $some_file_handle );
+
+ # ...a string ...
+ $yw->write( $data, \$some_string );
+
+ # ...or a closure
+ $yw->write( $data, sub {
+ my $line = shift;
+ print "$line\n";
+ } );
+
+=head1 DESCRIPTION
+
+Encodes a scalar, hash reference or array reference as YAMLish.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Writer> object.
+
+=head2 Instance Methods
+
+=head3 C<write>
+
+ $writer->write($obj, $output );
+
+Encode a scalar, hash reference or array reference as YAML.
+
+ my $writer = sub {
+ my $line = shift;
+ print SOMEFILE "$line\n";
+ };
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+ $yw->write( $data, $writer );
+
+
+The C< $output > argument may be:
+
+=over
+
+=item * a reference to a scalar to append YAML to
+
+=item * the handle of an open file
+
+=item * a reference to an array into which YAML will be pushed
+
+=item * a code reference
+
+=back
+
+If you supply a code reference the subroutine will be called once for
+each line of output with the line as its only argument. Passed lines
+will have no trailing newline.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
--- /dev/null
+package App::Prove;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Harness;
+use TAP::Parser::Utils qw( split_shell );
+use File::Spec;
+use Getopt::Long;
+use App::Prove::State;
+use Carp;
+
+=head1 NAME
+
+App::Prove - Implements the C<prove> command.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+L<Test::Harness> provides a command, C<prove>, which runs a TAP based
+test suite and prints a report. The C<prove> command is a minimal
+wrapper around an instance of this module.
+
+=head1 SYNOPSIS
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ $app->run;
+
+=cut
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => $^O eq 'VMS';
+use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
+
+use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
+use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
+
+use constant PLUGINS => 'App::Prove::Plugin';
+
+my @ATTR;
+
+BEGIN {
+ @ISA = qw(TAP::Object);
+
+ @ATTR = qw(
+ archive argv blib show_count color directives exec failures comments
+ formatter harness includes modules plugins jobs lib merge parse quiet
+ really_quiet recurse backwards shuffle taint_fail taint_warn timer
+ verbose warnings_fail warnings_warn show_help show_man show_version
+ state_class test_args state dry extension ignore_exit rules state_manager
+ normalize
+ );
+ __PACKAGE__->mk_methods(@ATTR);
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new C<App::Prove>. Optionally a hash ref of attribute
+initializers may be passed.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ my $args = shift || {};
+
+ # setup defaults:
+ for my $key (qw( argv rc_opts includes modules state plugins rules )) {
+ $self->{$key} = [];
+ }
+ $self->{harness_class} = 'TAP::Harness';
+
+ for my $attr (@ATTR) {
+ if ( exists $args->{$attr} ) {
+
+ # TODO: Some validation here
+ $self->{$attr} = $args->{$attr};
+ }
+ }
+
+ my %env_provides_default = (
+ HARNESS_TIMER => 'timer',
+ );
+
+ while ( my ( $env, $attr ) = each %env_provides_default ) {
+ $self->{$attr} = 1 if $ENV{$env};
+ }
+ $self->state_class('App::Prove::State');
+ return $self;
+}
+
+=head3 C<state_class>
+
+Getter/setter for the name of the class used for maintaining state. This
+class should either subclass from C<App::Prove::State> or provide an identical
+interface.
+
+=head3 C<state_manager>
+
+Getter/setter for the instance of the C<state_class>.
+
+=cut
+
+=head3 C<add_rc_file>
+
+ $prove->add_rc_file('myproj/.proverc');
+
+Called before C<process_args> to prepend the contents of an rc file to
+the options.
+
+=cut
+
+sub add_rc_file {
+ my ( $self, $rc_file ) = @_;
+
+ local *RC;
+ open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
+ while ( defined( my $line = <RC> ) ) {
+ push @{ $self->{rc_opts} },
+ grep { defined and not /^#/ }
+ $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
+ }
+ close RC;
+}
+
+=head3 C<process_args>
+
+ $prove->process_args(@args);
+
+Processes the command-line arguments. Attributes will be set
+appropriately. Any filenames may be found in the C<argv> attribute.
+
+Dies on invalid arguments.
+
+=cut
+
+sub process_args {
+ my $self = shift;
+
+ my @rc = RC_FILE;
+ unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
+
+ # Preprocess meta-args.
+ my @args;
+ while ( defined( my $arg = shift ) ) {
+ if ( $arg eq '--norc' ) {
+ @rc = ();
+ }
+ elsif ( $arg eq '--rc' ) {
+ defined( my $rc = shift )
+ or croak "Missing argument to --rc";
+ push @rc, $rc;
+ }
+ elsif ( $arg =~ m{^--rc=(.+)$} ) {
+ push @rc, $1;
+ }
+ else {
+ push @args, $arg;
+ }
+ }
+
+ # Everything after the arisdottle '::' gets passed as args to
+ # test programs.
+ if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
+ my @test_args = splice @args, $stop_at;
+ shift @test_args;
+ $self->{test_args} = \@test_args;
+ }
+
+ # Grab options from RC files
+ $self->add_rc_file($_) for grep -f, @rc;
+ unshift @args, @{ $self->{rc_opts} };
+
+ if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
+ die "Long options should be written with two dashes: ",
+ join( ', ', @bad ), "\n";
+ }
+
+ # And finally...
+
+ {
+ local @ARGV = @args;
+ Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
+
+ # Don't add coderefs to GetOptions
+ GetOptions(
+ 'v|verbose' => \$self->{verbose},
+ 'f|failures' => \$self->{failures},
+ 'o|comments' => \$self->{comments},
+ 'l|lib' => \$self->{lib},
+ 'b|blib' => \$self->{blib},
+ 's|shuffle' => \$self->{shuffle},
+ 'color!' => \$self->{color},
+ 'colour!' => \$self->{color},
+ 'count!' => \$self->{show_count},
+ 'c' => \$self->{color},
+ 'D|dry' => \$self->{dry},
+ 'ext=s' => \$self->{extension},
+ 'harness=s' => \$self->{harness},
+ 'ignore-exit' => \$self->{ignore_exit},
+ 'formatter=s' => \$self->{formatter},
+ 'r|recurse' => \$self->{recurse},
+ 'reverse' => \$self->{backwards},
+ 'p|parse' => \$self->{parse},
+ 'q|quiet' => \$self->{quiet},
+ 'Q|QUIET' => \$self->{really_quiet},
+ 'e|exec=s' => \$self->{exec},
+ 'm|merge' => \$self->{merge},
+ 'I=s@' => $self->{includes},
+ 'M=s@' => $self->{modules},
+ 'P=s@' => $self->{plugins},
+ 'state=s@' => $self->{state},
+ 'directives' => \$self->{directives},
+ 'h|help|?' => \$self->{show_help},
+ 'H|man' => \$self->{show_man},
+ 'V|version' => \$self->{show_version},
+ 'a|archive=s' => \$self->{archive},
+ 'j|jobs=i' => \$self->{jobs},
+ 'timer' => \$self->{timer},
+ 'T' => \$self->{taint_fail},
+ 't' => \$self->{taint_warn},
+ 'W' => \$self->{warnings_fail},
+ 'w' => \$self->{warnings_warn},
+ 'normalize' => \$self->{normalize},
+ 'rules=s@' => $self->{rules},
+ ) or croak('Unable to continue');
+
+ # Stash the remainder of argv for later
+ $self->{argv} = [@ARGV];
+ }
+
+ return;
+}
+
+sub _first_pos {
+ my $want = shift;
+ for ( 0 .. $#_ ) {
+ return $_ if $_[$_] eq $want;
+ }
+ return;
+}
+
+sub _help {
+ my ( $self, $verbosity ) = @_;
+
+ eval('use Pod::Usage 1.12 ()');
+ if ( my $err = $@ ) {
+ die 'Please install Pod::Usage for the --help option '
+ . '(or try `perldoc prove`.)'
+ . "\n ($@)";
+ }
+
+ Pod::Usage::pod2usage( { -verbose => $verbosity } );
+
+ return;
+}
+
+sub _color_default {
+ my $self = shift;
+
+ return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32;
+}
+
+sub _get_args {
+ my $self = shift;
+
+ my %args;
+
+ if ( defined $self->color ? $self->color : $self->_color_default ) {
+ $args{color} = 1;
+ }
+ if ( !defined $self->show_count ) {
+ $args{show_count} = 1;
+ }
+ else {
+ $args{show_count} = $self->show_count;
+ }
+
+ if ( $self->archive ) {
+ $self->require_harness( archive => 'TAP::Harness::Archive' );
+ $args{archive} = $self->archive;
+ }
+
+ if ( my $jobs = $self->jobs ) {
+ $args{jobs} = $jobs;
+ }
+
+ if ( my $harness_opt = $self->harness ) {
+ $self->require_harness( harness => $harness_opt );
+ }
+
+ if ( my $formatter = $self->formatter ) {
+ $args{formatter_class} = $formatter;
+ }
+
+ if ( $self->ignore_exit ) {
+ $args{ignore_exit} = 1;
+ }
+
+ if ( $self->taint_fail && $self->taint_warn ) {
+ die '-t and -T are mutually exclusive';
+ }
+
+ if ( $self->warnings_fail && $self->warnings_warn ) {
+ die '-w and -W are mutually exclusive';
+ }
+
+ for my $a (qw( lib switches )) {
+ my $method = "_get_$a";
+ my $val = $self->$method();
+ $args{$a} = $val if defined $val;
+ }
+
+ # Handle verbose, quiet, really_quiet flags
+ my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
+
+ my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
+ keys %verb_map;
+
+ die "Only one of verbose, quiet or really_quiet should be specified\n"
+ if @verb_adj > 1;
+
+ $args{verbosity} = shift @verb_adj || 0;
+
+ for my $a (qw( merge failures comments timer directives normalize )) {
+ $args{$a} = 1 if $self->$a();
+ }
+
+ $args{errors} = 1 if $self->parse;
+
+ # defined but zero-length exec runs test files as binaries
+ $args{exec} = [ split( /\s+/, $self->exec ) ]
+ if ( defined( $self->exec ) );
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ if ( @{ $self->rules } ) {
+ my @rules;
+ for ( @{ $self->rules } ) {
+ if (/^par=(.*)/) {
+ push @rules, $1;
+ }
+ elsif (/^seq=(.*)/) {
+ push @rules, { seq => $1 };
+ }
+ }
+ $args{rules} = { par => [@rules] };
+ }
+
+ return ( \%args, $self->{harness_class} );
+}
+
+sub _find_module {
+ my ( $self, $class, @search ) = @_;
+
+ croak "Bad module name $class"
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ for my $pfx (@search) {
+ my $name = join( '::', $pfx, $class );
+ eval "require $name";
+ return $name unless $@;
+ }
+
+ eval "require $class";
+ return $class unless $@;
+ return;
+}
+
+sub _load_extension {
+ my ( $self, $name, @search ) = @_;
+
+ my @args = ();
+ if ( $name =~ /^(.*?)=(.*)/ ) {
+ $name = $1;
+ @args = split( /,/, $2 );
+ }
+
+ if ( my $class = $self->_find_module( $name, @search ) ) {
+ $class->import(@args);
+ if ( $class->can('load') ) {
+ $class->load( { app_prove => $self, args => [@args] } );
+ }
+ }
+ else {
+ croak "Can't load module $name";
+ }
+}
+
+sub _load_extensions {
+ my ( $self, $ext, @search ) = @_;
+ $self->_load_extension( $_, @search ) for @$ext;
+}
+
+=head3 C<run>
+
+Perform whatever actions the command line args specified. The C<prove>
+command line tool consists of the following code:
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ exit( $app->run ? 0 : 1 ); # if you need the exit code
+
+=cut
+
+sub run {
+ my $self = shift;
+
+ unless ( $self->state_manager ) {
+ $self->state_manager(
+ $self->state_class->new( { store => STATE_FILE } ) );
+ }
+
+ if ( $self->show_help ) {
+ $self->_help(1);
+ }
+ elsif ( $self->show_man ) {
+ $self->_help(2);
+ }
+ elsif ( $self->show_version ) {
+ $self->print_version;
+ }
+ elsif ( $self->dry ) {
+ print "$_\n" for $self->_get_tests;
+ }
+ else {
+
+ $self->_load_extensions( $self->modules );
+ $self->_load_extensions( $self->plugins, PLUGINS );
+
+ local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
+
+ return $self->_runtests( $self->_get_args, $self->_get_tests );
+ }
+
+ return 1;
+}
+
+sub _get_tests {
+ my $self = shift;
+
+ my $state = $self->state_manager;
+ my $ext = $self->extension;
+ $state->extension($ext) if defined $ext;
+ if ( defined( my $state_switch = $self->state ) ) {
+ $state->apply_switch(@$state_switch);
+ }
+
+ my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
+
+ $self->_shuffle(@tests) if $self->shuffle;
+ @tests = reverse @tests if $self->backwards;
+
+ return @tests;
+}
+
+sub _runtests {
+ my ( $self, $args, $harness_class, @tests ) = @_;
+ my $harness = $harness_class->new($args);
+
+ my $state = $self->state_manager;
+
+ $harness->callback(
+ after_test => sub {
+ $state->observe_test(@_);
+ }
+ );
+
+ $harness->callback(
+ after_runtests => sub {
+ $state->commit(@_);
+ }
+ );
+
+ my $aggregator = $harness->runtests(@tests);
+
+ return !$aggregator->has_errors;
+}
+
+sub _get_switches {
+ my $self = shift;
+ my @switches;
+
+ # notes that -T or -t must be at the front of the switches!
+ if ( $self->taint_fail ) {
+ push @switches, '-T';
+ }
+ elsif ( $self->taint_warn ) {
+ push @switches, '-t';
+ }
+ if ( $self->warnings_fail ) {
+ push @switches, '-W';
+ }
+ elsif ( $self->warnings_warn ) {
+ push @switches, '-w';
+ }
+
+ push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
+
+ return @switches ? \@switches : ();
+}
+
+sub _get_lib {
+ my $self = shift;
+ my @libs;
+ if ( $self->lib ) {
+ push @libs, 'lib';
+ }
+ if ( $self->blib ) {
+ push @libs, 'blib/lib', 'blib/arch';
+ }
+ if ( @{ $self->includes } ) {
+ push @libs, @{ $self->includes };
+ }
+
+ #24926
+ @libs = map { File::Spec->rel2abs($_) } @libs;
+
+ # Huh?
+ return @libs ? \@libs : ();
+}
+
+sub _shuffle {
+ my $self = shift;
+
+ # Fisher-Yates shuffle
+ my $i = @_;
+ while ($i) {
+ my $j = rand $i--;
+ @_[ $i, $j ] = @_[ $j, $i ];
+ }
+ return;
+}
+
+=head3 C<require_harness>
+
+Load a harness replacement class.
+
+ $prove->require_harness($for => $class_name);
+
+=cut
+
+sub require_harness {
+ my ( $self, $for, $class ) = @_;
+
+ my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
+
+ # Emulate Perl's -MModule=arg1,arg2 behaviour
+ $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
+
+ eval("use $class;");
+ die "$class_name is required to use the --$for feature: $@" if $@;
+
+ $self->{harness_class} = $class_name;
+
+ return;
+}
+
+=head3 C<print_version>
+
+Display the version numbers of the loaded L<TAP::Harness> and the
+current Perl.
+
+=cut
+
+sub print_version {
+ my $self = shift;
+ printf(
+ "TAP::Harness v%s and Perl v%vd\n",
+ $TAP::Harness::VERSION, $^V
+ );
+
+ return;
+}
+
+1;
+
+# vim:ts=4:sw=4:et:sta
+
+__END__
+
+=head2 Attributes
+
+After command line parsing the following attributes reflect the values
+of the corresponding command line switches. They may be altered before
+calling C<run>.
+
+=over
+
+=item C<archive>
+
+=item C<argv>
+
+=item C<backwards>
+
+=item C<blib>
+
+=item C<color>
+
+=item C<directives>
+
+=item C<dry>
+
+=item C<exec>
+
+=item C<extension>
+
+=item C<failures>
+
+=item C<comments>
+
+=item C<formatter>
+
+=item C<harness>
+
+=item C<ignore_exit>
+
+=item C<includes>
+
+=item C<jobs>
+
+=item C<lib>
+
+=item C<merge>
+
+=item C<modules>
+
+=item C<parse>
+
+=item C<plugins>
+
+=item C<quiet>
+
+=item C<really_quiet>
+
+=item C<recurse>
+
+=item C<rules>
+
+=item C<show_count>
+
+=item C<show_help>
+
+=item C<show_man>
+
+=item C<show_version>
+
+=item C<shuffle>
+
+=item C<state>
+
+=item C<state_class>
+
+=item C<taint_fail>
+
+=item C<taint_warn>
+
+=item C<test_args>
+
+=item C<timer>
+
+=item C<verbose>
+
+=item C<warnings_fail>
+
+=item C<warnings_warn>
+
+=back
+
+=head1 PLUGINS
+
+C<App::Prove> provides support for 3rd-party plugins. These are currently
+loaded at run-time, I<after> arguments have been parsed (so you can not
+change the way arguments are processed, sorry), typically with the
+C<< -PI<plugin> >> switch, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass an argument to your plugin by appending an C<=> after the plugin
+name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
+
+ prove -PMyPlugin=foo,bar,baz
+
+These are passed in to your plugin's C<load()> class method (if it has one),
+along with a reference to the C<App::Prove> object that is invoking your plugin:
+
+ sub load {
+ my ($class, $p) = @_;
+
+ my @args = @{ $p->{args} };
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ $p->{app_prove}->do_something;
+ ...
+ }
+
+Note that the user's arguments are also passed to your plugin's C<import()>
+function as a list, eg:
+
+ sub import {
+ my ($class, @args) = @_;
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ ...
+ }
+
+This is for backwards compatibility, and may be deprecated in the future.
+
+=head2 Sample Plugin
+
+Here's a sample plugin, for your reference:
+
+ package App::Prove::Plugin::Foo;
+
+ # Sample plugin, try running with:
+ # prove -PFoo=bar -r -j3
+ # prove -PFoo -Q
+ # prove -PFoo=bar,My::Formatter
+
+ use strict;
+ use warnings;
+
+ sub load {
+ my ($class, $p) = @_;
+ my @args = @{ $p->{args} };
+ my $app = $p->{app_prove};
+
+ print "loading plugin: $class, args: ", join(', ', @args ), "\n";
+
+ # turn on verbosity
+ $app->verbose( 1 );
+
+ # set the formatter?
+ $app->formatter( $args[1] ) if @args > 1;
+
+ # print some of App::Prove's state:
+ for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
+ my $val = $app->$attr;
+ $val = 'undef' unless defined( $val );
+ print "$attr: $val\n";
+ }
+
+ return 1;
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<prove>, L<TAP::Harness>
+
+=cut
--- /dev/null
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+
+use App::Prove::State::Result;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+BEGIN {
+ @ISA = qw( TAP::Base );
+ __PACKAGE__->mk_methods('result_class');
+}
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant NEED_GLOB => IS_WIN32;
+
+=head1 NAME
+
+App::Prove::State - State storage for the C<prove> command.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module implements that state
+and the operations that may be performed on it.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Accepts a hashref with the following key/value pairs:
+
+=over 4
+
+=item * C<store>
+
+The filename of the data store holding the data that App::Prove::State reads.
+
+=item * C<extension> (optional)
+
+The test name extension. Defaults to C<.t>.
+
+=item * C<result_class> (optional)
+
+The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
+
+=back
+
+=cut
+
+# override TAP::Base::new:
+sub new {
+ my $class = shift;
+ my %args = %{ shift || {} };
+
+ my $self = bless {
+ select => [],
+ seq => 1,
+ store => delete $args{store},
+ extension => ( delete $args{extension} || '.t' ),
+ result_class =>
+ ( delete $args{result_class} || 'App::Prove::State::Result' ),
+ }, $class;
+
+ $self->{_} = $self->result_class->new(
+ { tests => {},
+ generation => 1,
+ }
+ );
+ my $store = $self->{store};
+ $self->load($store)
+ if defined $store && -f $store;
+
+ return $self;
+}
+
+=head2 C<result_class>
+
+Getter/setter for the name of the class used for tracking test results. This
+class should either subclass from C<App::Prove::State::Result> or provide an
+identical interface.
+
+=cut
+
+=head2 C<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+ my $self = shift;
+ $self->{extension} = shift if @_;
+ return $self->{extension};
+}
+
+=head2 C<results>
+
+Get the results of the last test run. Returns a C<result_class()> instance.
+
+=cut
+
+sub results {
+ my $self = shift;
+ $self->{_} || $self->result_class->new;
+}
+
+=head2 C<commit>
+
+Save the test results. Should be called after all tests have run.
+
+=cut
+
+sub commit {
+ my $self = shift;
+ if ( $self->{should_save} ) {
+ $self->save;
+ }
+}
+
+=head2 Instance Methods
+
+=head3 C<apply_switch>
+
+ $self->apply_switch('failed,save');
+
+Apply a list of switch options to the state, updating the internal
+object state as a result. Nothing is returned.
+
+Diagnostics:
+ - "Illegal state option: %s"
+
+=over
+
+=item C<last>
+
+Run in the same order as last time
+
+=item C<failed>
+
+Run only the failed tests from last time
+
+=item C<passed>
+
+Run only the passed tests from last time
+
+=item C<all>
+
+Run all tests in normal order
+
+=item C<hot>
+
+Run the tests that most recently failed first
+
+=item C<todo>
+
+Run the tests ordered by number of todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order.
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<save>
+
+Save the state on exit.
+
+=back
+
+=cut
+
+sub apply_switch {
+ my $self = shift;
+ my @opts = @_;
+
+ my $last_gen = $self->results->generation - 1;
+ my $last_run_time = $self->results->last_run_time;
+ my $now = $self->get_time;
+
+ my @switches = map { split /,/ } @opts;
+
+ my %handler = (
+ last => sub {
+ $self->_select(
+ where => sub { $_->generation >= $last_gen },
+ order => sub { $_->sequence }
+ );
+ },
+ failed => sub {
+ $self->_select(
+ where => sub { $_->result != 0 },
+ order => sub { -$_->result }
+ );
+ },
+ passed => sub {
+ $self->_select( where => sub { $_->result == 0 } );
+ },
+ all => sub {
+ $self->_select();
+ },
+ todo => sub {
+ $self->_select(
+ where => sub { $_->num_todo != 0 },
+ order => sub { -$_->num_todo; }
+ );
+ },
+ hot => sub {
+ $self->_select(
+ where => sub { defined $_->last_fail_time },
+ order => sub { $now - $_->last_fail_time }
+ );
+ },
+ slow => sub {
+ $self->_select( order => sub { -$_->elapsed } );
+ },
+ fast => sub {
+ $self->_select( order => sub { $_->elapsed } );
+ },
+ new => sub {
+ $self->_select( order => sub { -$_->mtime } );
+ },
+ old => sub {
+ $self->_select( order => sub { $_->mtime } );
+ },
+ fresh => sub {
+ $self->_select( where => sub { $_->mtime >= $last_run_time } );
+ },
+ save => sub {
+ $self->{should_save}++;
+ },
+ adrian => sub {
+ unshift @switches, qw( hot all save );
+ },
+ );
+
+ while ( defined( my $ele = shift @switches ) ) {
+ my ( $opt, $arg )
+ = ( $ele =~ /^([^:]+):(.*)/ )
+ ? ( $1, $2 )
+ : ( $ele, undef );
+ my $code = $handler{$opt}
+ || croak "Illegal state option: $opt";
+ $code->($arg);
+ }
+ return;
+}
+
+sub _select {
+ my ( $self, %spec ) = @_;
+ push @{ $self->{select} }, \%spec;
+}
+
+=head3 C<get_tests>
+
+Given a list of args get the names of tests that should run
+
+=cut
+
+sub get_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my %seen;
+
+ my @selected = $self->_query;
+
+ unless ( @argv || @{ $self->{select} } ) {
+ @argv = $recurse ? '.' : 't';
+ croak qq{No tests named and '@argv' directory not found}
+ unless -d $argv[0];
+ }
+
+ push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
+ return grep { !$seen{$_}++ } @selected;
+}
+
+sub _query {
+ my $self = shift;
+ if ( my @sel = @{ $self->{select} } ) {
+ warn "No saved state, selection will be empty\n"
+ unless $self->results->num_tests;
+ return map { $self->_query_clause($_) } @sel;
+ }
+ return;
+}
+
+sub _query_clause {
+ my ( $self, $clause ) = @_;
+ my @got;
+ my $results = $self->results;
+ my $where = $clause->{where} || sub {1};
+
+ # Select
+ for my $name ( $results->test_names ) {
+ next unless -f $name;
+ local $_ = $results->test($name);
+ push @got, $name if $where->();
+ }
+
+ # Sort
+ if ( my $order = $clause->{order} ) {
+ @got = map { $_->[0] }
+ sort {
+ ( defined $b->[1] <=> defined $a->[1] )
+ || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
+ } map {
+ [ $_,
+ do { local $_ = $results->test($_); $order->() }
+ ]
+ } @got;
+ }
+
+ return @got;
+}
+
+sub _get_raw_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my @tests;
+
+ # Do globbing on Win32.
+ @argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
+
+ for my $arg (@argv) {
+ if ( '-' eq $arg ) {
+ push @argv => <STDIN>;
+ chomp(@argv);
+ next;
+ }
+
+ push @tests,
+ sort -d $arg
+ ? $recurse
+ ? $self->_expand_dir_recursive( $arg, $extension )
+ : glob( File::Spec->catfile( $arg, "*$extension" ) )
+ : $arg;
+ }
+ return @tests;
+}
+
+sub _expand_dir_recursive {
+ my ( $self, $dir, $extension ) = @_;
+
+ my @tests;
+ find(
+ { follow => 1, #21938
+ follow_skip => 2,
+ wanted => sub {
+ -f
+ && /\Q$extension\E$/
+ && push @tests => $File::Find::name;
+ }
+ },
+ $dir
+ );
+ return @tests;
+}
+
+=head3 C<observe_test>
+
+Store the results of a test.
+
+=cut
+
+# Store:
+# last fail time
+# last pass time
+# last run time
+# most recent result
+# most recent todos
+# total failures
+# total passes
+# state generation
+# parser
+
+sub observe_test {
+
+ my ( $self, $test_info, $parser ) = @_;
+ my $name = $test_info->[0];
+ my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
+ my $todo = scalar( $parser->todo );
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time,
+
+ my $test = $self->results->test($name);
+
+ $test->sequence( $self->{seq}++ );
+ $test->generation( $self->results->generation );
+
+ $test->run_time($end_time);
+ $test->result($fail);
+ $test->num_todo($todo);
+ $test->elapsed( $end_time - $start_time );
+
+ $test->parser($parser);
+
+ if ($fail) {
+ $test->total_failures( $test->total_failures + 1 );
+ $test->last_fail_time($end_time);
+ }
+ else {
+ $test->total_passes( $test->total_passes + 1 );
+ $test->last_pass_time($end_time);
+ }
+}
+
+=head3 C<save>
+
+Write the state to a file.
+
+=cut
+
+sub save {
+ my ($self) = @_;
+
+ my $store = $self->{store} or return;
+ $self->results->last_run_time( $self->get_time );
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+ local *FH;
+ open FH, ">$store" or croak "Can't write $store ($!)";
+ $writer->write( $self->results->raw, \*FH );
+ close FH;
+}
+
+=head3 C<load>
+
+Load the state from a file
+
+=cut
+
+sub load {
+ my ( $self, $name ) = @_;
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+ local *FH;
+ open FH, "<$name" or croak "Can't read $name ($!)";
+
+ # XXX this is temporary
+ $self->{_} = $self->result_class->new(
+ $reader->read(
+ sub {
+ my $line = <FH>;
+ defined $line && chomp $line;
+ return $line;
+ }
+ )
+ );
+
+ # $writer->write( $self->{tests} || {}, \*FH );
+ close FH;
+ $self->_regen_seq;
+ $self->_prune_and_stamp;
+ $self->results->generation( $self->results->generation + 1 );
+}
+
+sub _prune_and_stamp {
+ my $self = shift;
+
+ my $results = $self->results;
+ my @tests = $self->results->tests;
+ for my $test (@tests) {
+ my $name = $test->name;
+ if ( my @stat = stat $name ) {
+ $test->mtime( $stat[9] );
+ }
+ else {
+ $results->remove($name);
+ }
+ }
+}
+
+sub _regen_seq {
+ my $self = shift;
+ for my $test ( $self->results->tests ) {
+ $self->{seq} = $test->sequence + 1
+ if defined $test->sequence && $test->sequence >= $self->{seq};
+ }
+}
+
+1;
--- /dev/null
+package App::Prove::State::Result;
+
+use strict;
+use Carp 'croak';
+
+use App::Prove::State::Result::Test;
+use vars qw($VERSION);
+
+use constant STATE_VERSION => 1;
+
+=head1 NAME
+
+App::Prove::State::Result - Individual test suite results.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test suite run.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $result = App::Prove::State::Result->new({
+ generation => $generation,
+ tests => \%tests,
+ });
+
+Returns a new C<App::Prove::State::Result> instance.
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ my %instance_data = %$arg_for; # shallow copy
+ $instance_data{version} = $class->state_version;
+ my $tests = delete $instance_data{tests} || {};
+ my $self = bless \%instance_data => $class;
+ $self->_initialize($tests);
+ return $self;
+}
+
+sub _initialize {
+ my ( $self, $tests ) = @_;
+ my %tests;
+ while ( my ( $name, $test ) = each %$tests ) {
+ $tests{$name} = $self->test_class->new(
+ { %$test,
+ name => $name
+ }
+ );
+ }
+ $self->tests( \%tests );
+ return $self;
+}
+
+=head2 C<state_version>
+
+Returns the current version of state storage.
+
+=cut
+
+sub state_version {STATE_VERSION}
+
+=head2 C<test_class>
+
+Returns the name of the class used for tracking individual tests. This class
+should either subclass from C<App::Prove::State::Result::Test> or provide an
+identical interface.
+
+=cut
+
+sub test_class {
+ return 'App::Prove::State::Result::Test';
+}
+
+my %methods = (
+ generation => { method => 'generation', default => 0 },
+ last_run_time => { method => 'last_run_time', default => undef },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head3 C<generation>
+
+Getter/setter for the "generation" of the test suite run. The first
+generation is 1 (one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_run_time>
+
+Getter/setter for the time of the test suite run.
+
+=head3 C<tests>
+
+Returns the tests for a given generation. This is a hashref or a hash,
+depending on context called. The keys to the hash are the individual
+test names and the value is a hashref with various interesting values.
+Each k/v pair might resemble something like this:
+
+ 't/foo.t' => {
+ elapsed => '0.0428488254547119',
+ gen => '7',
+ last_pass_time => '1219328376.07815',
+ last_result => '0',
+ last_run_time => '1219328376.07815',
+ last_todo => '0',
+ mtime => '1191708862',
+ seq => '192',
+ total_passes => '6',
+ }
+
+=cut
+
+sub tests {
+ my $self = shift;
+ if (@_) {
+ $self->{tests} = shift;
+ return $self;
+ }
+ my %tests = %{ $self->{tests} };
+ my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
+ return wantarray ? @tests : \@tests;
+}
+
+=head3 C<test>
+
+ my $test = $result->test('t/customer/create.t');
+
+Returns an individual C<App::Prove::State::Result::Test> instance for the
+given test name (usually the filename). Will return a new
+C<App::Prove::State::Result::Test> instance if the name is not found.
+
+=cut
+
+sub test {
+ my ( $self, $name ) = @_;
+ croak("test() requires a test name") unless defined $name;
+
+ my $tests = $self->{tests} ||= {};
+ if ( my $test = $tests->{$name} ) {
+ return $test;
+ }
+ else {
+ my $test = $self->test_class->new( { name => $name } );
+ $self->{tests}->{$name} = $test;
+ return $test;
+ }
+}
+
+=head3 C<test_names>
+
+Returns an list of test names, sorted by run order.
+
+=cut
+
+sub test_names {
+ my $self = shift;
+ return map { $_->name } $self->tests;
+}
+
+=head3 C<remove>
+
+ $result->remove($test_name); # remove the test
+ my $test = $result->test($test_name); # fatal error
+
+Removes a given test from results. This is a no-op if the test name is not
+found.
+
+=cut
+
+sub remove {
+ my ( $self, $name ) = @_;
+ delete $self->{tests}->{$name};
+ return $self;
+}
+
+=head3 C<num_tests>
+
+Returns the number of tests for a given test suite result.
+
+=cut
+
+sub num_tests { keys %{ shift->{tests} } }
+
+=head3 C<raw>
+
+Returns a hashref of raw results, suitable for serialization by YAML.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ my %tests;
+ foreach my $test ( $self->tests ) {
+ $tests{ $test->name } = $test->raw;
+ }
+ $raw{tests} = \%tests;
+ return \%raw;
+}
+
+1;
--- /dev/null
+package App::Prove::State::Result::Test;
+
+use strict;
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+App::Prove::State::Result::Test - Individual test results.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+my %methods = (
+ name => { method => 'name' },
+ elapsed => { method => 'elapsed', default => 0 },
+ gen => { method => 'generation', default => 1 },
+ last_pass_time => { method => 'last_pass_time', default => undef },
+ last_fail_time => { method => 'last_fail_time', default => undef },
+ last_result => { method => 'result', default => 0 },
+ last_run_time => { method => 'run_time', default => undef },
+ last_todo => { method => 'num_todo', default => 0 },
+ mtime => { method => 'mtime', default => undef },
+ seq => { method => 'sequence', default => 1 },
+ total_passes => { method => 'total_passes', default => 0 },
+ total_failures => { method => 'total_failures', default => 0 },
+ parser => { method => 'parser' },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ bless $arg_for => $class;
+}
+
+=head2 Instance Methods
+
+=head3 C<name>
+
+The name of the test. Usually a filename.
+
+=head3 C<elapsed>
+
+The total elapsed times the test took to run, in seconds from the epoch..
+
+=head3 C<generation>
+
+The number for the "generation" of the test run. The first generation is 1
+(one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_pass_time>
+
+The last time the test program passed, in seconds from the epoch.
+
+Returns C<undef> if the program has never passed.
+
+=head3 C<last_fail_time>
+
+The last time the test suite failed, in seconds from the epoch.
+
+Returns C<undef> if the program has never failed.
+
+=head3 C<mtime>
+
+Returns the mtime of the test, in seconds from the epoch.
+
+=head3 C<raw>
+
+Returns a hashref of raw test data, suitable for serialization by YAML.
+
+=head3 C<result>
+
+Currently, whether or not the test suite passed with no 'problems' (such as
+TODO passed).
+
+=head3 C<run_time>
+
+The total time it took for the test to run, in seconds. If C<Time::HiRes> is
+available, it will have finer granularity.
+
+=head3 C<num_todo>
+
+The number of tests with TODO directives.
+
+=head3 C<sequence>
+
+The order in which this test was run for the given test suite result.
+
+=head3 C<total_passes>
+
+The number of times the test has passed.
+
+=head3 C<total_failures>
+
+The number of times the test has failed.
+
+=head3 C<parser>
+
+The underlying parser object. This is useful if you need the full
+information for the test program.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ # this is backwards-compatibility hack and is not guaranteed.
+ delete $raw{name};
+ delete $raw{parser};
+ return \%raw;
+}
+
+1;
--- /dev/null
+package Test::Builder;
+
+use 5.006;
+use strict;
+use warnings;
+
+our $VERSION = '0.88';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+BEGIN {
+ if( $] < 5.008 ) {
+ require Test::Builder::IO::Scalar;
+ }
+}
+
+
+# Make Test::Builder thread-safe for ithreads.
+BEGIN {
+ use Config;
+ # Load threads::shared when threads are turned on.
+ # 5.8.0's threads are so busted we no longer support them.
+ if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
+ require threads::shared;
+
+ # Hack around YET ANOTHER threads::shared bug. It would
+ # occassionally forget the contents of the variable when sharing it.
+ # So we first copy the data, then share, then put our copy back.
+ *share = sub (\[$@%]) {
+ my $type = ref $_[0];
+ my $data;
+
+ if( $type eq 'HASH' ) {
+ %$data = %{ $_[0] };
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @$data = @{ $_[0] };
+ }
+ elsif( $type eq 'SCALAR' ) {
+ $$data = ${ $_[0] };
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ $_[0] = &threads::shared::share( $_[0] );
+
+ if( $type eq 'HASH' ) {
+ %{ $_[0] } = %$data;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @{ $_[0] } = @$data;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ ${ $_[0] } = $$data;
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ return $_[0];
+ };
+ }
+ # 5.8.0's threads::shared is busted when threads are off
+ # and earlier Perls just don't have that module at all.
+ else {
+ *share = sub { return $_[0] };
+ *lock = sub { 0 };
+ }
+}
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use base 'Test::Builder::Module';
+
+ my $CLASS = __PACKAGE__;
+
+ sub ok {
+ my($test, $name) = @_;
+ my $tb = $CLASS->builder;
+
+ $tb->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+Test::Simple and Test::More have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program C<new> always returns the same
+Test::Builder object. No matter how many times you call C<new()>, you're
+getting the same object. This is called a singleton. This is done so that
+multiple modules share such global information as the test counter and
+where test output is going.
+
+If you want a completely new Test::Builder object different from the
+singleton, use C<create>.
+
+=cut
+
+my $Test = Test::Builder->new;
+
+sub new {
+ my($class) = shift;
+ $Test ||= $class->create;
+ return $Test;
+}
+
+=item B<create>
+
+ my $Test = Test::Builder->create;
+
+Ok, so there can be more than one Test::Builder object and this is how
+you get it. You might use this instead of C<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is
+still shared amongst B<all> Test::Builder objects, even ones created using
+this method. Also, the method name may change in the future.
+
+=cut
+
+sub create {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+ $self->reset;
+
+ return $self;
+}
+
+=item B<reset>
+
+ $Test->reset;
+
+Reinitializes the Test::Builder singleton to its original state.
+Mostly useful for tests run in persistent environments where the same
+test might be run multiple times in the same process.
+
+=cut
+
+our $Level;
+
+sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my($self) = @_;
+
+ # We leave this a global because it has to be localized and localizing
+ # hash keys is just asking for pain. Also, it was documented.
+ $Level = 1;
+
+ $self->{Have_Plan} = 0;
+ $self->{No_Plan} = 0;
+ $self->{Have_Output_Plan} = 0;
+
+ $self->{Original_Pid} = $$;
+
+ share( $self->{Curr_Test} );
+ $self->{Curr_Test} = 0;
+ $self->{Test_Results} = &share( [] );
+
+ $self->{Exported_To} = undef;
+ $self->{Expected_Tests} = 0;
+
+ $self->{Skip_All} = 0;
+
+ $self->{Use_Nums} = 1;
+
+ $self->{No_Header} = 0;
+ $self->{No_Ending} = 0;
+
+ $self->{Todo} = undef;
+ $self->{Todo_Stack} = [];
+ $self->{Start_Todo} = 0;
+ $self->{Opened_Testhandles} = 0;
+
+ $self->_dup_stdhandles;
+
+ return;
+}
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call C<plan()>, don't call any of the other methods below.
+
+=cut
+
+my %plan_cmds = (
+ no_plan => \&no_plan,
+ skip_all => \&skip_all,
+ tests => \&_plan_tests,
+);
+
+sub plan {
+ my( $self, $cmd, $arg ) = @_;
+
+ return unless $cmd;
+
+ local $Level = $Level + 1;
+
+ $self->croak("You tried to plan twice") if $self->{Have_Plan};
+
+ if( my $method = $plan_cmds{$cmd} ) {
+ local $Level = $Level + 1;
+ $self->$method($arg);
+ }
+ else {
+ my @args = grep { defined } ( $cmd, $arg );
+ $self->croak("plan() doesn't understand @args");
+ }
+
+ return 1;
+}
+
+
+sub _plan_tests {
+ my($self, $arg) = @_;
+
+ if($arg) {
+ local $Level = $Level + 1;
+ return $self->expected_tests($arg);
+ }
+ elsif( !defined $arg ) {
+ $self->croak("Got an undefined number of tests");
+ }
+ else {
+ $self->croak("You said to run 0 tests");
+ }
+
+ return;
+}
+
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the number of tests we expect this test to run and prints out
+the appropriate headers.
+
+=cut
+
+sub expected_tests {
+ my $self = shift;
+ my($max) = @_;
+
+ if(@_) {
+ $self->croak("Number of tests must be a positive integer. You gave it '$max'")
+ unless $max =~ /^\+?\d+$/;
+
+ $self->{Expected_Tests} = $max;
+ $self->{Have_Plan} = 1;
+
+ $self->_output_plan($max) unless $self->no_header;
+ }
+ return $self->{Expected_Tests};
+}
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate number of tests.
+
+=cut
+
+sub no_plan {
+ my($self, $arg) = @_;
+
+ $self->carp("no_plan takes no arguments") if $arg;
+
+ $self->{No_Plan} = 1;
+ $self->{Have_Plan} = 1;
+
+ return 1;
+}
+
+
+=begin private
+
+=item B<_output_plan>
+
+ $tb->_output_plan($max);
+ $tb->_output_plan($max, $directive);
+ $tb->_output_plan($max, $directive => $reason);
+
+Handles displaying the test plan.
+
+If a C<$directive> and/or C<$reason> are given they will be output with the
+plan. So here's what skipping all tests looks like:
+
+ $tb->_output_plan(0, "SKIP", "Because I said so");
+
+It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
+output.
+
+=end private
+
+=cut
+
+sub _output_plan {
+ my($self, $max, $directive, $reason) = @_;
+
+ $self->carp("The plan was already output") if $self->{Have_Output_Plan};
+
+ my $plan = "1..$max";
+ $plan .= " # $directive" if defined $directive;
+ $plan .= " $reason" if defined $reason;
+
+ $self->_print("$plan\n");
+
+ $self->{Have_Output_Plan} = 1;
+
+ return;
+}
+
+=item B<done_testing>
+
+ $Test->done_testing();
+ $Test->done_testing($num_tests);
+
+Declares that you are done testing, no more tests will be run after this point.
+
+If a plan has not yet been output, it will do so.
+
+$num_tests is the number of tests you planned to run. If a numbered
+plan was already declared, and if this contradicts, a failing test
+will be run to reflect the planning mistake. If C<no_plan> was declared,
+this will override.
+
+If C<done_testing()> is called twice, the second call will issue a
+failing test.
+
+If C<$num_tests> is omitted, the number of tests run will be used, like
+no_plan.
+
+C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
+safer. You'd use it like so:
+
+ $Test->ok($a == $b);
+ $Test->done_testing();
+
+Or to plan a variable number of tests:
+
+ for my $test (@tests) {
+ $Test->ok($test);
+ }
+ $Test->done_testing(@tests);
+
+=cut
+
+sub done_testing {
+ my($self, $num_tests) = @_;
+
+ # If done_testing() specified the number of tests, shut off no_plan.
+ if( defined $num_tests ) {
+ $self->{No_Plan} = 0;
+ }
+ else {
+ $num_tests = $self->current_test;
+ }
+
+ if( $self->{Done_Testing} ) {
+ my($file, $line) = @{$self->{Done_Testing}}[1,2];
+ $self->ok(0, "done_testing() was already called at $file line $line");
+ return;
+ }
+
+ $self->{Done_Testing} = [caller];
+
+ if( $self->expected_tests && $num_tests != $self->expected_tests ) {
+ $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
+ "but done_testing() expects $num_tests");
+ }
+ else {
+ $self->{Expected_Tests} = $num_tests;
+ }
+
+ $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
+
+ $self->{Have_Plan} = 1;
+
+ return 1;
+}
+
+
+=item B<has_plan>
+
+ $plan = $Test->has_plan
+
+Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
+has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
+of expected tests).
+
+=cut
+
+sub has_plan {
+ my $self = shift;
+
+ return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
+ return('no_plan') if $self->{No_Plan};
+ return(undef);
+}
+
+=item B<skip_all>
+
+ $Test->skip_all;
+ $Test->skip_all($reason);
+
+Skips all the tests, using the given C<$reason>. Exits immediately with 0.
+
+=cut
+
+sub skip_all {
+ my( $self, $reason ) = @_;
+
+ $self->{Skip_All} = 1;
+
+ $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
+ exit(0);
+}
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+
+This method isn't terribly useful since modules which share the same
+Test::Builder object might get exported to different packages and only
+the last one will be honored.
+
+=cut
+
+sub exported_to {
+ my( $self, $pack ) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in Test::More.
+
+They all return true if the test passed, false if the test failed.
+
+C<$name> is always optional.
+
+=over 4
+
+=item B<ok>
+
+ $Test->ok($test, $name);
+
+Your basic test. Pass if C<$test> is true, fail if $test is false. Just
+like Test::Simple's C<ok()>.
+
+=cut
+
+sub ok {
+ my( $self, $test, $name ) = @_;
+
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ lock $self->{Curr_Test};
+ $self->{Curr_Test}++;
+
+ # In case $name is a string overloaded object, force it to stringify.
+ $self->_unoverload_str( \$name );
+
+ $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ERR
+
+ # Capture the value of $TODO for the rest of this ok() call
+ # so it can more easily be found by other routines.
+ my $todo = $self->todo();
+ my $in_todo = $self->in_todo;
+ local $self->{Todo} = $todo if $in_todo;
+
+ $self->_unoverload_str( \$todo );
+
+ my $out;
+ my $result = &share( {} );
+
+ unless($test) {
+ $out .= "not ";
+ @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ $out .= "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+
+ if( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $out .= " - $name";
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if( $self->in_todo ) {
+ $out .= " # TODO $todo";
+ $result->{reason} = $todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ unless($test) {
+ my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
+ $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
+
+ my( undef, $file, $line ) = $self->caller;
+ if( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
+ }
+ }
+
+ return $test ? 1 : 0;
+}
+
+sub _unoverload {
+ my $self = shift;
+ my $type = shift;
+
+ $self->_try(sub { require overload; }, die_on_fail => 1);
+
+ foreach my $thing (@_) {
+ if( $self->_is_object($$thing) ) {
+ if( my $string_meth = overload::Method( $$thing, $type ) ) {
+ $$thing = $$thing->$string_meth();
+ }
+ }
+ }
+
+ return;
+}
+
+sub _is_object {
+ my( $self, $thing ) = @_;
+
+ return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
+}
+
+sub _unoverload_str {
+ my $self = shift;
+
+ return $self->_unoverload( q[""], @_ );
+}
+
+sub _unoverload_num {
+ my $self = shift;
+
+ $self->_unoverload( '0+', @_ );
+
+ for my $val (@_) {
+ next unless $self->_is_dualvar($$val);
+ $$val = $$val + 0;
+ }
+
+ return;
+}
+
+# This is a hack to detect a dualvar such as $!
+sub _is_dualvar {
+ my( $self, $val ) = @_;
+
+ # Objects are not dualvars.
+ return 0 if ref $val;
+
+ no warnings 'numeric';
+ my $numval = $val + 0;
+ return $numval != 0 and $numval ne $val ? 1 : 0;
+}
+
+=item B<is_eq>
+
+ $Test->is_eq($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
+string version.
+
+=item B<is_num>
+
+ $Test->is_num($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
+numeric version.
+
+=cut
+
+sub is_eq {
+ my( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_str( \$got, \$expect );
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, 'eq', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'eq', $expect, $name );
+}
+
+sub is_num {
+ my( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_num( \$got, \$expect );
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, '==', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '==', $expect, $name );
+}
+
+sub _diag_fmt {
+ my( $self, $type, $val ) = @_;
+
+ if( defined $$val ) {
+ if( $type eq 'eq' or $type eq 'ne' ) {
+ # quote and force string context
+ $$val = "'$$val'";
+ }
+ else {
+ # force numeric context
+ $self->_unoverload_num($val);
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+
+ return;
+}
+
+sub _is_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: $expect
+DIAGNOSTIC
+
+}
+
+sub _isnt_diag {
+ my( $self, $got, $type ) = @_;
+
+ $self->_diag_fmt( $type, \$got );
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: anything else
+DIAGNOSTIC
+}
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->isnt_num($got, $dont_expect, $name);
+
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, 'ne' ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
+}
+
+sub isnt_num {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, '!=' ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '!=', $dont_expect, $name );
+}
+
+=item B<like>
+
+ $Test->like($this, qr/$regex/, $name);
+ $Test->like($this, '/$regex/', $name);
+
+Like Test::More's C<like()>. Checks if $this matches the given C<$regex>.
+
+You'll want to avoid C<qr//> if you want your tests to work before 5.005.
+
+=item B<unlike>
+
+ $Test->unlike($this, qr/$regex/, $name);
+ $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's C<unlike()>. Checks if $this B<does not match> the
+given C<$regex>.
+
+=cut
+
+sub like {
+ my( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ return $self->_regex_ok( $this, $regex, '=~', $name );
+}
+
+sub unlike {
+ my( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ return $self->_regex_ok( $this, $regex, '!~', $name );
+}
+
+=item B<cmp_ok>
+
+ $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's C<cmp_ok()>.
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+
+sub cmp_ok {
+ my( $self, $got, $type, $expect, $name ) = @_;
+
+ my $test;
+ my $error;
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ my($pack, $file, $line) = $self->caller();
+
+ $test = eval qq[
+#line 1 "cmp_ok [from $file line $line]"
+\$got $type \$expect;
+];
+ $error = $@;
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok( $test, $name );
+
+ # Treat overloaded objects as numbers if we're asked to do a
+ # numeric comparison.
+ my $unoverload
+ = $numeric_cmps{$type}
+ ? '_unoverload_num'
+ : '_unoverload_str';
+
+ $self->diag(<<"END") if $error;
+An error occurred while using $type:
+------------------------------------
+$error
+------------------------------------
+END
+
+ unless($ok) {
+ $self->$unoverload( \$got, \$expect );
+
+ if( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag( $got, $type, $expect );
+ }
+ elsif( $type =~ /^(ne|!=)$/ ) {
+ $self->_isnt_diag( $got, $type );
+ }
+ else {
+ $self->_cmp_diag( $got, $type, $expect );
+ }
+ }
+ return $ok;
+}
+
+sub _cmp_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ $got
+ $type
+ $expect
+DIAGNOSTIC
+}
+
+sub _caller_context {
+ my $self = shift;
+
+ my( $pack, $file, $line ) = $self->caller(1);
+
+ my $code = '';
+ $code .= "#line $line $file\n" if defined $file and defined $line;
+
+ return $code;
+}
+
+=back
+
+
+=head2 Other Testing Methods
+
+These are methods which are used in the course of writing a test but are not themselves tests.
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ $Test->BAIL_OUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAIL_OUT {
+ my( $self, $reason ) = @_;
+
+ $self->{Bailed_Out} = 1;
+ $self->_print("Bail out! $reason");
+ exit 255;
+}
+
+=for deprecated
+BAIL_OUT() used to be BAILOUT()
+
+=cut
+
+*BAILOUT = \&BAIL_OUT;
+
+=item B<skip>
+
+ $Test->skip;
+ $Test->skip($why);
+
+Skips the current test, reporting C<$why>.
+
+=cut
+
+sub skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+ $self->_unoverload_str( \$why );
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # skip";
+ $out .= " $why" if length $why;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like C<skip()>, only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "not ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # TODO & SKIP $why\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
+
+Like C<skip()>, only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under C<no_plan>, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
+
+=head2 Test building utility methods
+
+These methods are useful when writing your own test methods.
+
+=over 4
+
+=item B<maybe_regex>
+
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
+
+Convenience method for building testing functions that take regular
+expressions as arguments, but need to work before perl 5.005.
+
+Takes a quoted regular expression produced by C<qr//>, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or C<undef> if its argument is not recognised.
+
+For example, a version of C<like()>, sans the useful diagnostic messages,
+could be written as:
+
+ sub laconic_like {
+ my ($self, $this, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($this =~ m/$usable_regex/, $name);
+ }
+
+=cut
+
+sub maybe_regex {
+ my( $self, $regex ) = @_;
+ my $usable_regex = undef;
+
+ return $usable_regex unless defined $regex;
+
+ my( $re, $opts );
+
+ # Check for qr/foo/
+ if( _is_qr($regex) ) {
+ $usable_regex = $regex;
+ }
+ # Check for '/foo/' or 'm,foo,'
+ elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
+ ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+ )
+ {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ }
+
+ return $usable_regex;
+}
+
+sub _is_qr {
+ my $regex = shift;
+
+ # is_regexp() checks for regexes in a robust manner, say if they're
+ # blessed.
+ return re::is_regexp($regex) if defined &re::is_regexp;
+ return ref $regex eq 'Regexp';
+}
+
+sub _regex_ok {
+ my( $self, $this, $regex, $cmp, $name ) = @_;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless( defined $usable_regex ) {
+ local $Level = $Level + 1;
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ my $test;
+ my $code = $self->_caller_context;
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ # Yes, it has to look like this or 5.4.5 won't see the #line
+ # directive.
+ # Don't ask me, man, I just work here.
+ $test = eval "
+$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+
+ $test = !$test if $cmp eq '!~';
+
+ local $Level = $Level + 1;
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless($ok) {
+ $this = defined $this ? "'$this'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+
+ local $Level = $Level + 1;
+ $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+# I'm not ready to publish this. It doesn't deal with array return
+# values from the code or context.
+
+=begin private
+
+=item B<_try>
+
+ my $return_from_code = $Test->try(sub { code });
+ my($return_from_code, $error) = $Test->try(sub { code });
+
+Works like eval BLOCK except it ensures it has no effect on the rest
+of the test (ie. C<$@> is not set) nor is effected by outside
+interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
+Perls.
+
+C<$error> is what would normally be in C<$@>.
+
+It is suggested you use this in place of eval BLOCK.
+
+=cut
+
+sub _try {
+ my( $self, $code, %opts ) = @_;
+
+ my $error;
+ my $return;
+ {
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ $return = eval { $code->() };
+ $error = $@;
+ }
+
+ die $error if $error and $opts{die_on_fail};
+
+ return wantarray ? ( $return, $error ) : $return;
+}
+
+=end private
+
+
+=item B<is_fh>
+
+ my $is_fh = $Test->is_fh($thing);
+
+Determines if the given C<$thing> can be used as a filehandle.
+
+=cut
+
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
+
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return eval { $maybe_fh->isa("IO::Handle") } ||
+ # 5.5.4's tied() and can() doesn't like getting undef
+ eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
+}
+
+=back
+
+
+=head2 Test style
+
+
+=over 4
+
+=item B<level>
+
+ $Test->level($how_high);
+
+How far up the call stack should C<$Test> look when reporting where the
+test failed.
+
+Defaults to 1.
+
+Setting L<$Test::Builder::Level> overrides. This is typically useful
+localized:
+
+ sub my_ok {
+ my $test = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $TB->ok($test);
+ }
+
+To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
+
+=cut
+
+sub level {
+ my( $self, $level ) = @_;
+
+ if( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+=item B<use_numbers>
+
+ $Test->use_numbers($on_or_off);
+
+Whether or not the test should output numbers. That is, this if true:
+
+ ok 1
+ ok 2
+ ok 3
+
+or this if false
+
+ ok
+ ok
+ ok
+
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
+
+Defaults to on.
+
+=cut
+
+sub use_numbers {
+ my( $self, $use_nums ) = @_;
+
+ if( defined $use_nums ) {
+ $self->{Use_Nums} = $use_nums;
+ }
+ return $self->{Use_Nums};
+}
+
+=item B<no_diag>
+
+ $Test->no_diag($no_diag);
+
+If set true no diagnostics will be printed. This includes calls to
+C<diag()>.
+
+=item B<no_ending>
+
+ $Test->no_ending($no_ending);
+
+Normally, Test::Builder does some extra diagnostics when the test
+ends. It also changes the exit code as described below.
+
+If this is true, none of that will be done.
+
+=item B<no_header>
+
+ $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
+=cut
+
+foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
+ my $method = lc $attribute;
+
+ my $code = sub {
+ my( $self, $no ) = @_;
+
+ if( defined $no ) {
+ $self->{$attribute} = $no;
+ }
+ return $self->{$attribute};
+ };
+
+ no strict 'refs'; ## no critic
+ *{ __PACKAGE__ . '::' . $method } = $code;
+}
+
+=back
+
+=head2 Output
+
+Controlling where the test output goes.
+
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
+
+=over 4
+
+=item B<diag>
+
+ $Test->diag(@msgs);
+
+Prints out the given C<@msgs>. Like C<print>, arguments are simply
+appended together.
+
+Normally, it uses the C<failure_output()> handle, but if this is for a
+TODO test, the C<todo_output()> handle is used.
+
+Output will be indented and marked with a # so as not to interfere
+with test output. A newline will be put on the end if there isn't one
+already.
+
+We encourage using this rather than calling print directly.
+
+Returns false. Why? Because C<diag()> is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+ return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+
+=cut
+
+sub diag {
+ my $self = shift;
+
+ $self->_print_comment( $self->_diag_fh, @_ );
+}
+
+=item B<note>
+
+ $Test->note(@msgs);
+
+Like C<diag()>, but it prints to the C<output()> handle so it will not
+normally be seen by the user except in verbose mode.
+
+=cut
+
+sub note {
+ my $self = shift;
+
+ $self->_print_comment( $self->output, @_ );
+}
+
+sub _diag_fh {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ return $self->in_todo ? $self->todo_output : $self->failure_output;
+}
+
+sub _print_comment {
+ my( $self, $fh, @msgs ) = @_;
+
+ return if $self->no_diag;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Smash args together like print does.
+ # Convert undef to 'undef' so its readable.
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
+
+ # Escape the beginning, _print will take care of the rest.
+ $msg =~ s/^/# /;
+
+ local $Level = $Level + 1;
+ $self->_print_to_fh( $fh, $msg );
+
+ return 0;
+}
+
+=item B<explain>
+
+ my @dump = $Test->explain(@msgs);
+
+Will dump the contents of any references in a human readable format.
+Handy for things like...
+
+ is_deeply($have, $want) || diag explain $have;
+
+or
+
+ is_deeply($have, $want) || note explain $have;
+
+=cut
+
+sub explain {
+ my $self = shift;
+
+ return map {
+ ref $_
+ ? do {
+ $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
+
+ my $dumper = Data::Dumper->new( [$_] );
+ $dumper->Indent(1)->Terse(1);
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+ $dumper->Dump;
+ }
+ : $_
+ } @_;
+}
+
+=begin _private
+
+=item B<_print>
+
+ $Test->_print(@msgs);
+
+Prints to the C<output()> filehandle.
+
+=end _private
+
+=cut
+
+sub _print {
+ my $self = shift;
+ return $self->_print_to_fh( $self->output, @_ );
+}
+
+sub _print_to_fh {
+ my( $self, $fh, @msgs ) = @_;
+
+ # Prevent printing headers when only compiling. Mostly for when
+ # tests are deparsed with B::Deparse
+ return if $^C;
+
+ my $msg = join '', @msgs;
+
+ local( $\, $", $, ) = ( undef, ' ', '' );
+
+ # Escape each line after the first with a # so we don't
+ # confuse Test::Harness.
+ $msg =~ s{\n(?!\z)}{\n# }sg;
+
+ # Stick a newline on the end if it needs it.
+ $msg .= "\n" unless $msg =~ /\n\z/;
+
+ return print $fh $msg;
+}
+
+=item B<output>
+
+=item B<failure_output>
+
+=item B<todo_output>
+
+ my $filehandle = $Test->output;
+ $Test->output($filehandle);
+ $Test->output($filename);
+ $Test->output(\$scalar);
+
+These methods control where Test::Builder will print its output.
+They take either an open C<$filehandle>, a C<$filename> to open and write to
+or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
+
+B<output> is where normal "ok/not ok" test output goes.
+
+Defaults to STDOUT.
+
+B<failure_output> is where diagnostic output on test failures and
+C<diag()> goes. It is normally not read by Test::Harness and instead is
+displayed to the user.
+
+Defaults to STDERR.
+
+C<todo_output> is used instead of C<failure_output()> for the
+diagnostics of a failing TODO test. These will not be seen by the
+user.
+
+Defaults to STDOUT.
+
+=cut
+
+sub output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Out_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Out_FH};
+}
+
+sub failure_output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Fail_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Fail_FH};
+}
+
+sub todo_output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Todo_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Todo_FH};
+}
+
+sub _new_fh {
+ my $self = shift;
+ my($file_or_fh) = shift;
+
+ my $fh;
+ if( $self->is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ elsif( ref $file_or_fh eq 'SCALAR' ) {
+ # Scalar refs as filehandles was added in 5.8.
+ if( $] >= 5.008 ) {
+ open $fh, ">>", $file_or_fh
+ or $self->croak("Can't open scalar ref $file_or_fh: $!");
+ }
+ # Emulate scalar ref filehandles with a tie.
+ else {
+ $fh = Test::Builder::IO::Scalar->new($file_or_fh)
+ or $self->croak("Can't tie scalar ref $file_or_fh");
+ }
+ }
+ else {
+ open $fh, ">", $file_or_fh
+ or $self->croak("Can't open test output log $file_or_fh: $!");
+ _autoflush($fh);
+ }
+
+ return $fh;
+}
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+
+ return;
+}
+
+my( $Testout, $Testerr );
+
+sub _dup_stdhandles {
+ my $self = shift;
+
+ $self->_open_testhandles;
+
+ # Set everything to unbuffered else plain prints to STDOUT will
+ # come out in the wrong order from our own prints.
+ _autoflush($Testout);
+ _autoflush( \*STDOUT );
+ _autoflush($Testerr);
+ _autoflush( \*STDERR );
+
+ $self->reset_outputs;
+
+ return;
+}
+
+sub _open_testhandles {
+ my $self = shift;
+
+ return if $self->{Opened_Testhandles};
+
+ # We dup STDOUT and STDERR so people can change them in their
+ # test suites while still getting normal test output.
+ open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
+ open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
+
+ # $self->_copy_io_layers( \*STDOUT, $Testout );
+ # $self->_copy_io_layers( \*STDERR, $Testerr );
+
+ $self->{Opened_Testhandles} = 1;
+
+ return;
+}
+
+sub _copy_io_layers {
+ my( $self, $src, $dst ) = @_;
+
+ $self->_try(
+ sub {
+ require PerlIO;
+ my @src_layers = PerlIO::get_layers($src);
+
+ binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+ }
+ );
+
+ return;
+}
+
+=item reset_outputs
+
+ $tb->reset_outputs;
+
+Resets all the output filehandles back to their defaults.
+
+=cut
+
+sub reset_outputs {
+ my $self = shift;
+
+ $self->output ($Testout);
+ $self->failure_output($Testerr);
+ $self->todo_output ($Testout);
+
+ return;
+}
+
+=item carp
+
+ $tb->carp(@message);
+
+Warns with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
+
+=item croak
+
+ $tb->croak(@message);
+
+Dies with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
+
+=cut
+
+sub _message_at_caller {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ my( $pack, $file, $line ) = $self->caller;
+ return join( "", @_ ) . " at $file line $line.\n";
+}
+
+sub carp {
+ my $self = shift;
+ return warn $self->_message_at_caller(@_);
+}
+
+sub croak {
+ my $self = shift;
+ return die $self->_message_at_caller(@_);
+}
+
+
+=back
+
+
+=head2 Test Status and Info
+
+=over 4
+
+=item B<current_test>
+
+ my $curr_test = $Test->current_test;
+ $Test->current_test($num);
+
+Gets/sets the current test number we're on. You usually shouldn't
+have to set this.
+
+If set forward, the details of the missing tests are filled in as 'unknown'.
+if set backward, the details of the intervening tests are deleted. You
+can erase history if you really want to.
+
+=cut
+
+sub current_test {
+ my( $self, $num ) = @_;
+
+ lock( $self->{Curr_Test} );
+ if( defined $num ) {
+ $self->{Curr_Test} = $num;
+
+ # If the test counter is being pushed forward fill in the details.
+ my $test_results = $self->{Test_Results};
+ if( $num > @$test_results ) {
+ my $start = @$test_results ? @$test_results : 0;
+ for( $start .. $num - 1 ) {
+ $test_results->[$_] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ }
+ );
+ }
+ }
+ # If backward, wipe history. Its their funeral.
+ elsif( $num < @$test_results ) {
+ $#{$test_results} = $num - 1;
+ }
+ }
+ return $self->{Curr_Test};
+}
+
+=item B<summary>
+
+ my @tests = $Test->summary;
+
+A simple summary of the tests so far. True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
+
+Of course, test #1 is $tests[0], etc...
+
+=cut
+
+sub summary {
+ my($self) = shift;
+
+ return map { $_->{'ok'} } @{ $self->{Test_Results} };
+}
+
+=item B<details>
+
+ my @tests = $Test->details;
+
+Like C<summary()>, but with a lot more detail.
+
+ $tests[$test_num - 1] =
+ { 'ok' => is the test considered a pass?
+ actual_ok => did it literally say 'ok'?
+ name => name of the test (if any)
+ type => type of test (if any, see below).
+ reason => reason for the above (if any)
+ };
+
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'. This is for examining the result of 'todo'
+tests.
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test. Normal tests have a type
+of ''. Type can be one of the following:
+
+ skip see skip()
+ todo see todo()
+ todo_skip see todo_skip()
+ unknown see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when C<current_test()> is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+its type is 'unknown'. These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left C<undef>.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+ $tests[22] = # 23 - 1, since arrays start from 0.
+ { ok => 1, # logically, the test passed since its todo
+ actual_ok => 0, # in absolute terms, it failed
+ name => 'hole count',
+ type => 'todo',
+ reason => 'insufficient donuts'
+ };
+
+=cut
+
+sub details {
+ my $self = shift;
+ return @{ $self->{Test_Results} };
+}
+
+=item B<todo>
+
+ my $todo_reason = $Test->todo;
+ my $todo_reason = $Test->todo($pack);
+
+If the current tests are considered "TODO" it will return the reason,
+if any. This reason can come from a C<$TODO> variable or the last call
+to C<todo_start()>.
+
+Since a TODO test does not need a reason, this function can return an
+empty string even when inside a TODO block. Use C<< $Test->in_todo >>
+to determine if you are currently inside a TODO block.
+
+C<todo()> is about finding the right package to look for C<$TODO> in. It's
+pretty good at guessing the right package to look at. It first looks for
+the caller based on C<$Level + 1>, since C<todo()> is usually called inside
+a test function. As a last resort it will use C<exported_to()>.
+
+Sometimes there is some confusion about where todo() should be looking
+for the C<$TODO> variable. If you want to be sure, tell it explicitly
+what $pack to use.
+
+=cut
+
+sub todo {
+ my( $self, $pack ) = @_;
+
+ return $self->{Todo} if defined $self->{Todo};
+
+ local $Level = $Level + 1;
+ my $todo = $self->find_TODO($pack);
+ return $todo if defined $todo;
+
+ return '';
+}
+
+=item B<find_TODO>
+
+ my $todo_reason = $Test->find_TODO();
+ my $todo_reason = $Test->find_TODO($pack):
+
+Like C<todo()> but only returns the value of C<$TODO> ignoring
+C<todo_start()>.
+
+=cut
+
+sub find_TODO {
+ my( $self, $pack ) = @_;
+
+ $pack = $pack || $self->caller(1) || $self->exported_to;
+ return unless $pack;
+
+ no strict 'refs'; ## no critic
+ return ${ $pack . '::TODO' };
+}
+
+=item B<in_todo>
+
+ my $in_todo = $Test->in_todo;
+
+Returns true if the test is currently inside a TODO block.
+
+=cut
+
+sub in_todo {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
+}
+
+=item B<todo_start>
+
+ $Test->todo_start();
+ $Test->todo_start($message);
+
+This method allows you declare all subsequent tests as TODO tests, up until
+the C<todo_end> method has been called.
+
+The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
+whether or not we're in a TODO test. However, often we find that this is not
+possible to determine (such as when we want to use C<$TODO> but
+the tests are being executed in other packages which can't be inferred
+beforehand).
+
+Note that you can use this to nest "todo" tests
+
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+
+This is generally not recommended, but large testing systems often have weird
+internal needs.
+
+We've tried to make this also work with the TODO: syntax, but it's not
+guaranteed and its use is also discouraged:
+
+ TODO: {
+ local $TODO = 'We have work to do!';
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+ }
+
+Pick one style or another of "TODO" to be on the safe side.
+
+=cut
+
+sub todo_start {
+ my $self = shift;
+ my $message = @_ ? shift : '';
+
+ $self->{Start_Todo}++;
+ if( $self->in_todo ) {
+ push @{ $self->{Todo_Stack} } => $self->todo;
+ }
+ $self->{Todo} = $message;
+
+ return;
+}
+
+=item C<todo_end>
+
+ $Test->todo_end;
+
+Stops running tests as "TODO" tests. This method is fatal if called without a
+preceding C<todo_start> method call.
+
+=cut
+
+sub todo_end {
+ my $self = shift;
+
+ if( !$self->{Start_Todo} ) {
+ $self->croak('todo_end() called without todo_start()');
+ }
+
+ $self->{Start_Todo}--;
+
+ if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
+ $self->{Todo} = pop @{ $self->{Todo_Stack} };
+ }
+ else {
+ delete $self->{Todo};
+ }
+
+ return;
+}
+
+=item B<caller>
+
+ my $package = $Test->caller;
+ my($pack, $file, $line) = $Test->caller;
+ my($pack, $file, $line) = $Test->caller($height);
+
+Like the normal C<caller()>, except it reports according to your C<level()>.
+
+C<$height> will be added to the C<level()>.
+
+If C<caller()> winds up off the top of the stack it report the highest context.
+
+=cut
+
+sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my( $self, $height ) = @_;
+ $height ||= 0;
+
+ my $level = $self->level + $height + 1;
+ my @caller;
+ do {
+ @caller = CORE::caller( $level );
+ $level--;
+ } until @caller;
+ return wantarray ? @caller : $caller[0];
+}
+
+=back
+
+=cut
+
+=begin _private
+
+=over 4
+
+=item B<_sanity_check>
+
+ $self->_sanity_check();
+
+Runs a bunch of end of test sanity checks to make sure reality came
+through ok. If anything is wrong it will die with a fairly friendly
+error message.
+
+=cut
+
+#'#
+sub _sanity_check {
+ my $self = shift;
+
+ $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
+ $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
+ 'Somehow you got a different number of results than tests ran!' );
+
+ return;
+}
+
+=item B<_whoa>
+
+ $self->_whoa($check, $description);
+
+A sanity check, similar to C<assert()>. If the C<$check> is true, something
+has gone horribly wrong. It will die with the given C<$description> and
+a note to contact the author.
+
+=cut
+
+sub _whoa {
+ my( $self, $check, $desc ) = @_;
+ if($check) {
+ local $Level = $Level + 1;
+ $self->croak(<<"WHOA");
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+
+ return;
+}
+
+=item B<_my_exit>
+
+ _my_exit($exit_num);
+
+Perl seems to have some trouble with exiting inside an C<END> block. 5.005_03
+and 5.6.1 both seem to do odd things. Instead, this function edits C<$?>
+directly. It should B<only> be called from inside an C<END> block. It
+doesn't actually exit, that's your job.
+
+=cut
+
+sub _my_exit {
+ $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+ return 1;
+}
+
+=back
+
+=end _private
+
+=cut
+
+sub _ending {
+ my $self = shift;
+
+ my $real_exit_code = $?;
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ if( $self->{Original_Pid} != $$ ) {
+ return;
+ }
+
+ # Ran tests but never declared a plan or hit done_testing
+ if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
+ $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+ }
+
+ # Exit if plan() was never called. This is so "require Test::Simple"
+ # doesn't puke.
+ if( !$self->{Have_Plan} ) {
+ return;
+ }
+
+ # Don't do an ending if we bailed out.
+ if( $self->{Bailed_Out} ) {
+ return;
+ }
+
+ # Figure out if we passed or failed and print helpful messages.
+ my $test_results = $self->{Test_Results};
+ if(@$test_results) {
+ # The plan? We have no plan.
+ if( $self->{No_Plan} ) {
+ $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
+ $self->{Expected_Tests} = $self->{Curr_Test};
+ }
+
+ # Auto-extended arrays and elements which aren't explicitly
+ # filled in with a shared reference will puke under 5.8.0
+ # ithreads. So we have to fill them in by hand. :(
+ my $empty_result = &share( {} );
+ for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
+ $test_results->[$idx] = $empty_result
+ unless defined $test_results->[$idx];
+ }
+
+ my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
+
+ my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
+
+ if( $num_extra != 0 ) {
+ my $s = $self->{Expected_Tests} == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
+FAIL
+ }
+
+ if($num_failed) {
+ my $num_tests = $self->{Curr_Test};
+ my $s = $num_failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+
+ $self->diag(<<"FAIL");
+Looks like you failed $num_failed test$s of $num_tests$qualifier.
+FAIL
+ }
+
+ if($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
+FAIL
+
+ _my_exit($real_exit_code) && return;
+ }
+
+ my $exit_code;
+ if($num_failed) {
+ $exit_code = $num_failed <= 254 ? $num_failed : 254;
+ }
+ elsif( $num_extra != 0 ) {
+ $exit_code = 255;
+ }
+ else {
+ $exit_code = 0;
+ }
+
+ _my_exit($exit_code) && return;
+ }
+ elsif( $self->{Skip_All} ) {
+ _my_exit(0) && return;
+ }
+ elsif($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code before it could output anything.
+FAIL
+ _my_exit($real_exit_code) && return;
+ }
+ else {
+ $self->diag("No tests run!\n");
+ _my_exit(255) && return;
+ }
+
+ $self->_whoa( 1, "We fell off the end of _ending()" );
+}
+
+END {
+ $Test->_ending if defined $Test and !$Test->no_ending;
+}
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+=head1 THREADS
+
+In perl 5.8.1 and later, Test::Builder is thread-safe. The test
+number is shared amongst all threads. This means if one thread sets
+the test number using C<current_test()> they will all be effected.
+
+While versions earlier than 5.8.1 had threads they contain too many
+bugs to support.
+
+Test::Builder is only thread-aware if threads.pm is loaded I<before>
+Test::Builder.
+
+=head1 MEMORY
+
+An informative hash, accessable via C<<details()>>, is stored for each
+test you perform. So memory usage will scale linearly with each test
+run. Although this is not a problem for most test suites, it can
+become an issue if you do large (hundred thousands to million)
+combinatorics tests in the same run.
+
+In such cases, you are advised to either split the test file into smaller
+ones, or use a reverse approach, doing "normal" (code) compares and
+triggering fail() should anything go unexpected.
+
+Future versions of Test::Builder will have a way to turn history off.
+
+
+=head1 EXAMPLES
+
+CPAN can provide the best examples. Test::Simple, Test::More,
+Test::Exception and Test::Differences all use Test::Builder.
+
+=head1 SEE ALSO
+
+Test::Simple, Test::More, Test::Harness
+
+=head1 AUTHORS
+
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
+ Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
+
--- /dev/null
+package Test::Builder::IO::Scalar;
+
+
+=head1 NAME
+
+Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder
+
+=head1 DESCRIPTION
+
+This is a copy of IO::Scalar which ships with Test::Builder to
+support scalar references as filehandles on Perl 5.6.
+
+=cut
+
+# This is copied code, I don't care.
+##no critic
+
+use Carp;
+use strict;
+use vars qw($VERSION @ISA);
+use IO::Handle;
+
+use 5.005;
+
+### The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+### Inheritance:
+@ISA = qw(IO::Handle);
+
+#==============================
+
+=head2 Construction
+
+=over 4
+
+=cut
+
+#------------------------------
+
+=item new [ARGS...]
+
+I<Class method.>
+Return a new, unattached scalar handle.
+If any arguments are given, they're sent to open().
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = bless \do { local *FH }, $class;
+ tie *$self, $class, $self;
+ $self->open(@_); ### open on anonymous by default
+ $self;
+}
+sub DESTROY {
+ shift->close;
+}
+
+#------------------------------
+
+=item open [SCALARREF]
+
+I<Instance method.>
+Open the scalar handle on a new scalar, pointed to by SCALARREF.
+If no SCALARREF is given, a "private" scalar is created to hold
+the file data.
+
+Returns the self object on success, undefined on error.
+
+=cut
+
+sub open {
+ my ($self, $sref) = @_;
+
+ ### Sanity:
+ defined($sref) or do {my $s = ''; $sref = \$s};
+ (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
+
+ ### Setup:
+ *$self->{Pos} = 0; ### seek position
+ *$self->{SR} = $sref; ### scalar reference
+ $self;
+}
+
+#------------------------------
+
+=item opened
+
+I<Instance method.>
+Is the scalar handle opened on something?
+
+=cut
+
+sub opened {
+ *{shift()}->{SR};
+}
+
+#------------------------------
+
+=item close
+
+I<Instance method.>
+Disassociate the scalar handle from its underlying scalar.
+Done automatically on destroy.
+
+=cut
+
+sub close {
+ my $self = shift;
+ %{*$self} = ();
+ 1;
+}
+
+=back
+
+=cut
+
+
+
+#==============================
+
+=head2 Input and output
+
+=over 4
+
+=cut
+
+
+#------------------------------
+
+=item flush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub flush { "0 but true" }
+
+#------------------------------
+
+=item getc
+
+I<Instance method.>
+Return the next character, or undef if none remain.
+
+=cut
+
+sub getc {
+ my $self = shift;
+
+ ### Return undef right away if at EOF; else, move pos forward:
+ return undef if $self->eof;
+ substr(${*$self->{SR}}, *$self->{Pos}++, 1);
+}
+
+#------------------------------
+
+=item getline
+
+I<Instance method.>
+Return the next line, or undef on end of string.
+Can safely be called in an array context.
+Currently, lines are delimited by "\n".
+
+=cut
+
+sub getline {
+ my $self = shift;
+
+ ### Return undef right away if at EOF:
+ return undef if $self->eof;
+
+ ### Get next line:
+ my $sr = *$self->{SR};
+ my $i = *$self->{Pos}; ### Start matching at this point.
+
+ ### Minimal impact implementation!
+ ### We do the fast fast thing (no regexps) if using the
+ ### classic input record separator.
+
+ ### Case 1: $/ is undef: slurp all...
+ if (!defined($/)) {
+ *$self->{Pos} = length $$sr;
+ return substr($$sr, $i);
+ }
+
+ ### Case 2: $/ is "\n": zoom zoom zoom...
+ elsif ($/ eq "\012") {
+
+ ### Seek ahead for "\n"... yes, this really is faster than regexps.
+ my $len = length($$sr);
+ for (; $i < $len; ++$i) {
+ last if ord (substr ($$sr, $i, 1)) == 10;
+ }
+
+ ### Extract the line:
+ my $line;
+ if ($i < $len) { ### We found a "\n":
+ $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
+ *$self->{Pos} = $i+1; ### Remember where we finished up.
+ }
+ else { ### No "\n"; slurp the remainder:
+ $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
+ *$self->{Pos} = $len;
+ }
+ return $line;
+ }
+
+ ### Case 3: $/ is ref to int. Do fixed-size records.
+ ### (Thanks to Dominique Quatravaux.)
+ elsif (ref($/)) {
+ my $len = length($$sr);
+ my $i = ${$/} + 0;
+ my $line = substr ($$sr, *$self->{Pos}, $i);
+ *$self->{Pos} += $i;
+ *$self->{Pos} = $len if (*$self->{Pos} > $len);
+ return $line;
+ }
+
+ ### Case 4: $/ is either "" (paragraphs) or something weird...
+ ### This is Graham's general-purpose stuff, which might be
+ ### a tad slower than Case 2 for typical data, because
+ ### of the regexps.
+ else {
+ pos($$sr) = $i;
+
+ ### If in paragraph mode, skip leading lines (and update i!):
+ length($/) or
+ (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
+
+ ### If we see the separator in the buffer ahead...
+ if (length($/)
+ ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
+ : $$sr =~ m,\n\n,g ### (a paragraph)
+ ) {
+ *$self->{Pos} = pos $$sr;
+ return substr($$sr, $i, *$self->{Pos}-$i);
+ }
+ ### Else if no separator remains, just slurp the rest:
+ else {
+ *$self->{Pos} = length $$sr;
+ return substr($$sr, $i);
+ }
+ }
+}
+
+#------------------------------
+
+=item getlines
+
+I<Instance method.>
+Get all remaining lines.
+It will croak() if accidentally called in a scalar context.
+
+=cut
+
+sub getlines {
+ my $self = shift;
+ wantarray or croak("can't call getlines in scalar context!");
+ my ($line, @lines);
+ push @lines, $line while (defined($line = $self->getline));
+ @lines;
+}
+
+#------------------------------
+
+=item print ARGS...
+
+I<Instance method.>
+Print ARGS to the underlying scalar.
+
+B<Warning:> this continues to always cause a seek to the end
+of the string, but if you perform seek()s and tell()s, it is
+still safer to explicitly seek-to-end before subsequent print()s.
+
+=cut
+
+sub print {
+ my $self = shift;
+ *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
+ 1;
+}
+sub _unsafe_print {
+ my $self = shift;
+ my $append = join('', @_) . $\;
+ ${*$self->{SR}} .= $append;
+ *$self->{Pos} += length($append);
+ 1;
+}
+sub _old_print {
+ my $self = shift;
+ ${*$self->{SR}} .= join('', @_) . $\;
+ *$self->{Pos} = length(${*$self->{SR}});
+ 1;
+}
+
+
+#------------------------------
+
+=item read BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Read some bytes from the scalar.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=cut
+
+sub read {
+ my $self = $_[0];
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
+ $n = length($read);
+ *$self->{Pos} += $n;
+ ($off ? substr($_[1], $off) : $_[1]) = $read;
+ return $n;
+}
+
+#------------------------------
+
+=item write BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Write some bytes to the scalar.
+
+=cut
+
+sub write {
+ my $self = $_[0];
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ my $data = substr($_[1], $off, $n);
+ $n = length($data);
+ $self->print($data);
+ return $n;
+}
+
+#------------------------------
+
+=item sysread BUF, LEN, [OFFSET]
+
+I<Instance method.>
+Read some bytes from the scalar.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=cut
+
+sub sysread {
+ my $self = shift;
+ $self->read(@_);
+}
+
+#------------------------------
+
+=item syswrite BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Write some bytes to the scalar.
+
+=cut
+
+sub syswrite {
+ my $self = shift;
+ $self->write(@_);
+}
+
+=back
+
+=cut
+
+
+#==============================
+
+=head2 Seeking/telling and other attributes
+
+=over 4
+
+=cut
+
+
+#------------------------------
+
+=item autoflush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub autoflush {}
+
+#------------------------------
+
+=item binmode
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub binmode {}
+
+#------------------------------
+
+=item clearerr
+
+I<Instance method.> Clear the error and EOF flags. A no-op.
+
+=cut
+
+sub clearerr { 1 }
+
+#------------------------------
+
+=item eof
+
+I<Instance method.> Are we at end of file?
+
+=cut
+
+sub eof {
+ my $self = shift;
+ (*$self->{Pos} >= length(${*$self->{SR}}));
+}
+
+#------------------------------
+
+=item seek OFFSET, WHENCE
+
+I<Instance method.> Seek to a given position in the stream.
+
+=cut
+
+sub seek {
+ my ($self, $pos, $whence) = @_;
+ my $eofpos = length(${*$self->{SR}});
+
+ ### Seek:
+ if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
+ elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
+ elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
+ else { croak "bad seek whence ($whence)" }
+
+ ### Fixup:
+ if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
+ if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
+ return 1;
+}
+
+#------------------------------
+
+=item sysseek OFFSET, WHENCE
+
+I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
+
+=cut
+
+sub sysseek {
+ my $self = shift;
+ $self->seek (@_);
+}
+
+#------------------------------
+
+=item tell
+
+I<Instance method.>
+Return the current position in the stream, as a numeric offset.
+
+=cut
+
+sub tell { *{shift()}->{Pos} }
+
+#------------------------------
+
+=item use_RS [YESNO]
+
+I<Instance method.>
+B<Deprecated and ignored.>
+Obey the curent setting of $/, like IO::Handle does?
+Default is false in 1.x, but cold-welded true in 2.x and later.
+
+=cut
+
+sub use_RS {
+ my ($self, $yesno) = @_;
+ carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
+ }
+
+#------------------------------
+
+=item setpos POS
+
+I<Instance method.>
+Set the current position, using the opaque value returned by C<getpos()>.
+
+=cut
+
+sub setpos { shift->seek($_[0],0) }
+
+#------------------------------
+
+=item getpos
+
+I<Instance method.>
+Return the current position in the string, as an opaque object.
+
+=cut
+
+*getpos = \&tell;
+
+
+#------------------------------
+
+=item sref
+
+I<Instance method.>
+Return a reference to the underlying scalar.
+
+=cut
+
+sub sref { *{shift()}->{SR} }
+
+
+#------------------------------
+# Tied handle methods...
+#------------------------------
+
+# Conventional tiehandle interface:
+sub TIEHANDLE {
+ ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__))
+ ? $_[1]
+ : shift->new(@_));
+}
+sub GETC { shift->getc(@_) }
+sub PRINT { shift->print(@_) }
+sub PRINTF { shift->print(sprintf(shift, @_)) }
+sub READ { shift->read(@_) }
+sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
+sub WRITE { shift->write(@_); }
+sub CLOSE { shift->close(@_); }
+sub SEEK { shift->seek(@_); }
+sub TELL { shift->tell(@_); }
+sub EOF { shift->eof(@_); }
+
+#------------------------------------------------------------
+
+1;
+
+__END__
+
+
+
+=back
+
+=cut
+
+
+=head1 WARNINGS
+
+Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
+it was missing support for C<seek()>, C<tell()>, and C<eof()>.
+Attempting to use these functions with an IO::Scalar will not work
+prior to 5.005_57. IO::Scalar will not have the relevant methods
+invoked; and even worse, this kind of bug can lie dormant for a while.
+If you turn warnings on (via C<$^W> or C<perl -w>),
+and you see something like this...
+
+ attempt to seek on unopened filehandle
+
+...then you are probably trying to use one of these functions
+on an IO::Scalar with an old Perl. The remedy is to simply
+use the OO version; e.g.:
+
+ $SH->seek(0,0); ### GOOD: will work on any 5.005
+ seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
+
+
+=head1 VERSION
+
+$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHORS
+
+=head2 Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=head2 Principal author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+
+=head2 Other contributors
+
+The full set of contributors always includes the folks mentioned
+in L<IO::Stringy/"CHANGE LOG">. But just the same, special
+thanks to the following individuals for their invaluable contributions
+(if I've forgotten or misspelled your name, please email me!):
+
+I<Andy Glew,>
+for contributing C<getc()>.
+
+I<Brandon Browning,>
+for suggesting C<opened()>.
+
+I<David Richter,>
+for finding and fixing the bug in C<PRINTF()>.
+
+I<Eric L. Brine,>
+for his offset-using read() and write() implementations.
+
+I<Richard Jones,>
+for his patches to massively improve the performance of C<getline()>
+and add C<sysread> and C<syswrite>.
+
+I<B. K. Oxley (binkley),>
+for stringification and inheritance improvements,
+and sundry good ideas.
+
+I<Doug Wilson,>
+for the IO::Handle inheritance and automatic tie-ing.
+
+
+=head1 SEE ALSO
+
+L<IO::String>, which is quite similar but which was designed
+more-recently and with an IO::Handle-like interface in mind,
+so you could mix OO- and native-filehandle usage without using tied().
+
+I<Note:> as of version 2.x, these classes all work like
+their IO::Handle counterparts, so we have comparable
+functionality to IO::String.
+
+=cut
+
--- /dev/null
+package Test::Builder::Module;
+
+use strict;
+
+use Test::Builder;
+
+require Exporter;
+our @ISA = qw(Exporter);
+
+our $VERSION = '0.88';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+# 5.004's Exporter doesn't have export_to_level.
+my $_export_to_level = sub {
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # redundant arg
+ my $callpkg = caller($level);
+ $pkg->export( $callpkg, @_ );
+};
+
+=head1 NAME
+
+Test::Builder::Module - Base class for test modules
+
+=head1 SYNOPSIS
+
+ # Emulates Test::Simple
+ package Your::Module;
+
+ my $CLASS = __PACKAGE__;
+
+ use base 'Test::Builder::Module';
+ @EXPORT = qw(ok);
+
+ sub ok ($;$) {
+ my $tb = $CLASS->builder;
+ return $tb->ok(@_);
+ }
+
+ 1;
+
+
+=head1 DESCRIPTION
+
+This is a superclass for Test::Builder-based modules. It provides a
+handful of common functionality and a method of getting at the underlying
+Test::Builder object.
+
+
+=head2 Importing
+
+Test::Builder::Module is a subclass of Exporter which means your
+module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
+all act normally.
+
+A few methods are provided to do the C<use Your::Module tests => 23> part
+for you.
+
+=head3 import
+
+Test::Builder::Module provides an import() method which acts in the
+same basic way as Test::More's, setting the plan and controling
+exporting of functions and variables. This allows your module to set
+the plan independent of Test::More.
+
+All arguments passed to import() are passed onto
+C<< Your::Module->builder->plan() >> with the exception of
+C<import =>[qw(things to import)]>.
+
+ use Your::Module import => [qw(this that)], tests => 23;
+
+says to import the functions this() and that() as well as set the plan
+to be 23 tests.
+
+import() also sets the exported_to() attribute of your builder to be
+the caller of the import() function.
+
+Additional behaviors can be added to your import() method by overriding
+import_extra().
+
+=cut
+
+sub import {
+ my($class) = shift;
+
+ # Don't run all this when loading ourself.
+ return 1 if $class eq 'Test::Builder::Module';
+
+ my $test = $class->builder;
+
+ my $caller = caller;
+
+ $test->exported_to($caller);
+
+ $class->import_extra( \@_ );
+ my(@imports) = $class->_strip_imports( \@_ );
+
+ $test->plan(@_);
+
+ $class->$_export_to_level( 1, $class, @imports );
+}
+
+sub _strip_imports {
+ my $class = shift;
+ my $list = shift;
+
+ my @imports = ();
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'import' ) {
+ push @imports, @{ $list->[ $idx + 1 ] };
+ $idx++;
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return @imports;
+}
+
+=head3 import_extra
+
+ Your::Module->import_extra(\@import_args);
+
+import_extra() is called by import(). It provides an opportunity for you
+to add behaviors to your module based on its import list.
+
+Any extra arguments which shouldn't be passed on to plan() should be
+stripped off by this method.
+
+See Test::More for an example of its use.
+
+B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
+feels like a bit of an ugly hack in its current form.
+
+=cut
+
+sub import_extra { }
+
+=head2 Builder
+
+Test::Builder::Module provides some methods of getting at the underlying
+Test::Builder object.
+
+=head3 builder
+
+ my $builder = Your::Class->builder;
+
+This method returns the Test::Builder object associated with Your::Class.
+It is not a constructor so you can call it as often as you like.
+
+This is the preferred way to get the Test::Builder object. You should
+I<not> get it via C<< Test::Builder->new >> as was previously
+recommended.
+
+The object returned by builder() may change at runtime so you should
+call builder() inside each function rather than store it in a global.
+
+ sub ok {
+ my $builder = Your::Class->builder;
+
+ return $builder->ok(@_);
+ }
+
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
+
+1;
--- /dev/null
+package Test::Builder::Tester;
+
+use strict;
+our $VERSION = "1.18";
+
+use Test::Builder;
+use Symbol;
+use Carp;
+
+=head1 NAME
+
+Test::Builder::Tester - test testsuites that have been built with
+Test::Builder
+
+=head1 SYNOPSIS
+
+ use Test::Builder::Tester tests => 1;
+ use Test::More;
+
+ test_out("not ok 1 - foo");
+ test_fail(+1);
+ fail("foo");
+ test_test("fail works");
+
+=head1 DESCRIPTION
+
+A module that helps you test testing modules that are built with
+B<Test::Builder>.
+
+The testing system is designed to be used by performing a three step
+process for each test you wish to test. This process starts with using
+C<test_out> and C<test_err> in advance to declare what the testsuite you
+are testing will output with B<Test::Builder> to stdout and stderr.
+
+You then can run the test(s) from your test suite that call
+B<Test::Builder>. At this point the output of B<Test::Builder> is
+safely captured by B<Test::Builder::Tester> rather than being
+interpreted as real test output.
+
+The final stage is to call C<test_test> that will simply compare what you
+predeclared to what B<Test::Builder> actually outputted, and report the
+results back with a "ok" or "not ok" (with debugging) to the normal
+output.
+
+=cut
+
+####
+# set up testing
+####
+
+my $t = Test::Builder->new;
+
+###
+# make us an exporter
+###
+
+use Exporter;
+our @ISA = qw(Exporter);
+
+our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
+
+# _export_to_level and import stolen directly from Test::More. I am
+# the king of cargo cult programming ;-)
+
+# 5.004's Exporter doesn't have export_to_level.
+sub _export_to_level {
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # XXX redundant arg
+ my $callpkg = caller($level);
+ $pkg->export( $callpkg, @_ );
+}
+
+sub import {
+ my $class = shift;
+ my(@plan) = @_;
+
+ my $caller = caller;
+
+ $t->exported_to($caller);
+ $t->plan(@plan);
+
+ my @imports = ();
+ foreach my $idx ( 0 .. $#plan ) {
+ if( $plan[$idx] eq 'import' ) {
+ @imports = @{ $plan[ $idx + 1 ] };
+ last;
+ }
+ }
+
+ __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports );
+}
+
+###
+# set up file handles
+###
+
+# create some private file handles
+my $output_handle = gensym;
+my $error_handle = gensym;
+
+# and tie them to this package
+my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
+my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
+
+####
+# exported functions
+####
+
+# for remembering that we're testing and where we're testing at
+my $testing = 0;
+my $testing_num;
+
+# remembering where the file handles were originally connected
+my $original_output_handle;
+my $original_failure_handle;
+my $original_todo_handle;
+
+my $original_test_number;
+my $original_harness_state;
+
+my $original_harness_env;
+
+# function that starts testing and redirects the filehandles for now
+sub _start_testing {
+ # even if we're running under Test::Harness pretend we're not
+ # for now. This needed so Test::Builder doesn't add extra spaces
+ $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
+ $ENV{HARNESS_ACTIVE} = 0;
+
+ # remember what the handles were set to
+ $original_output_handle = $t->output();
+ $original_failure_handle = $t->failure_output();
+ $original_todo_handle = $t->todo_output();
+
+ # switch out to our own handles
+ $t->output($output_handle);
+ $t->failure_output($error_handle);
+ $t->todo_output($error_handle);
+
+ # clear the expected list
+ $out->reset();
+ $err->reset();
+
+ # remeber that we're testing
+ $testing = 1;
+ $testing_num = $t->current_test;
+ $t->current_test(0);
+
+ # look, we shouldn't do the ending stuff
+ $t->no_ending(1);
+}
+
+=head2 Functions
+
+These are the six methods that are exported as default.
+
+=over 4
+
+=item test_out
+
+=item test_err
+
+Procedures for predeclaring the output that your test suite is
+expected to produce until C<test_test> is called. These procedures
+automatically assume that each line terminates with "\n". So
+
+ test_out("ok 1","ok 2");
+
+is the same as
+
+ test_out("ok 1\nok 2");
+
+which is even the same as
+
+ test_out("ok 1");
+ test_out("ok 2");
+
+Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
+been called once all further output from B<Test::Builder> will be
+captured by B<Test::Builder::Tester>. This means that your will not
+be able perform further tests to the normal output in the normal way
+until you call C<test_test> (well, unless you manually meddle with the
+output filehandles)
+
+=cut
+
+sub test_out {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ $out->expect(@_);
+}
+
+sub test_err {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ $err->expect(@_);
+}
+
+=item test_fail
+
+Because the standard failure message that B<Test::Builder> produces
+whenever a test fails will be a common occurrence in your test error
+output, and because has changed between Test::Builder versions, rather
+than forcing you to call C<test_err> with the string all the time like
+so
+
+ test_err("# Failed test ($0 at line ".line_num(+1).")");
+
+C<test_fail> exists as a convenience function that can be called
+instead. It takes one argument, the offset from the current line that
+the line that causes the fail is on.
+
+ test_fail(+1);
+
+This means that the example in the synopsis could be rewritten
+more simply as:
+
+ test_out("not ok 1 - foo");
+ test_fail(+1);
+ fail("foo");
+ test_test("fail works");
+
+=cut
+
+sub test_fail {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ # work out what line we should be on
+ my( $package, $filename, $line ) = caller;
+ $line = $line + ( shift() || 0 ); # prevent warnings
+
+ # expect that on stderr
+ $err->expect("# Failed test ($0 at line $line)");
+}
+
+=item test_diag
+
+As most of the remaining expected output to the error stream will be
+created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
+provides a convience function C<test_diag> that you can use instead of
+C<test_err>.
+
+The C<test_diag> function prepends comment hashes and spacing to the
+start and newlines to the end of the expected output passed to it and
+adds it to the list of expected error output. So, instead of writing
+
+ test_err("# Couldn't open file");
+
+you can write
+
+ test_diag("Couldn't open file");
+
+Remember that B<Test::Builder>'s diag function will not add newlines to
+the end of output and test_diag will. So to check
+
+ Test::Builder->new->diag("foo\n","bar\n");
+
+You would do
+
+ test_diag("foo","bar")
+
+without the newlines.
+
+=cut
+
+sub test_diag {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ # expect the same thing, but prepended with "# "
+ local $_;
+ $err->expect( map { "# $_" } @_ );
+}
+
+=item test_test
+
+Actually performs the output check testing the tests, comparing the
+data (with C<eq>) that we have captured from B<Test::Builder> against
+that that was declared with C<test_out> and C<test_err>.
+
+This takes name/value pairs that effect how the test is run.
+
+=over
+
+=item title (synonym 'name', 'label')
+
+The name of the test that will be displayed after the C<ok> or C<not
+ok>.
+
+=item skip_out
+
+Setting this to a true value will cause the test to ignore if the
+output sent by the test to the output stream does not match that
+declared with C<test_out>.
+
+=item skip_err
+
+Setting this to a true value will cause the test to ignore if the
+output sent by the test to the error stream does not match that
+declared with C<test_err>.
+
+=back
+
+As a convience, if only one argument is passed then this argument
+is assumed to be the name of the test (as in the above examples.)
+
+Once C<test_test> has been run test output will be redirected back to
+the original filehandles that B<Test::Builder> was connected to
+(probably STDOUT and STDERR,) meaning any further tests you run
+will function normally and cause success/errors for B<Test::Harness>.
+
+=cut
+
+sub test_test {
+ # decode the arguements as described in the pod
+ my $mess;
+ my %args;
+ if( @_ == 1 ) {
+ $mess = shift
+ }
+ else {
+ %args = @_;
+ $mess = $args{name} if exists( $args{name} );
+ $mess = $args{title} if exists( $args{title} );
+ $mess = $args{label} if exists( $args{label} );
+ }
+
+ # er, are we testing?
+ croak "Not testing. You must declare output with a test function first."
+ unless $testing;
+
+ # okay, reconnect the test suite back to the saved handles
+ $t->output($original_output_handle);
+ $t->failure_output($original_failure_handle);
+ $t->todo_output($original_todo_handle);
+
+ # restore the test no, etc, back to the original point
+ $t->current_test($testing_num);
+ $testing = 0;
+
+ # re-enable the original setting of the harness
+ $ENV{HARNESS_ACTIVE} = $original_harness_env;
+
+ # check the output we've stashed
+ unless( $t->ok( ( $args{skip_out} || $out->check ) &&
+ ( $args{skip_err} || $err->check ), $mess )
+ )
+ {
+ # print out the diagnostic information about why this
+ # test failed
+
+ local $_;
+
+ $t->diag( map { "$_\n" } $out->complaint )
+ unless $args{skip_out} || $out->check;
+
+ $t->diag( map { "$_\n" } $err->complaint )
+ unless $args{skip_err} || $err->check;
+ }
+}
+
+=item line_num
+
+A utility function that returns the line number that the function was
+called on. You can pass it an offset which will be added to the
+result. This is very useful for working out the correct text of
+diagnostic functions that contain line numbers.
+
+Essentially this is the same as the C<__LINE__> macro, but the
+C<line_num(+3)> idiom is arguably nicer.
+
+=cut
+
+sub line_num {
+ my( $package, $filename, $line ) = caller;
+ return $line + ( shift() || 0 ); # prevent warnings
+}
+
+=back
+
+In addition to the six exported functions there there exists one
+function that can only be accessed with a fully qualified function
+call.
+
+=over 4
+
+=item color
+
+When C<test_test> is called and the output that your tests generate
+does not match that which you declared, C<test_test> will print out
+debug information showing the two conflicting versions. As this
+output itself is debug information it can be confusing which part of
+the output is from C<test_test> and which was the original output from
+your original tests. Also, it may be hard to spot things like
+extraneous whitespace at the end of lines that may cause your test to
+fail even though the output looks similar.
+
+To assist you, if you have the B<Term::ANSIColor> module installed
+(which you should do by default from perl 5.005 onwards), C<test_test>
+can colour the background of the debug information to disambiguate the
+different types of output. The debug output will have it's background
+coloured green and red. The green part represents the text which is
+the same between the executed and actual output, the red shows which
+part differs.
+
+The C<color> function determines if colouring should occur or not.
+Passing it a true or false value will enable or disable colouring
+respectively, and the function called with no argument will return the
+current setting.
+
+To enable colouring from the command line, you can use the
+B<Text::Builder::Tester::Color> module like so:
+
+ perl -Mlib=Text::Builder::Tester::Color test.t
+
+Or by including the B<Test::Builder::Tester::Color> module directly in
+the PERL5LIB.
+
+=cut
+
+my $color;
+
+sub color {
+ $color = shift if @_;
+ $color;
+}
+
+=back
+
+=head1 BUGS
+
+Calls C<<Test::Builder->no_ending>> turning off the ending tests.
+This is needed as otherwise it will trip out because we've run more
+tests than we strictly should have and it'll register any failures we
+had that we were testing for as real failures.
+
+The color function doesn't work unless B<Term::ANSIColor> is installed
+and is compatible with your terminal.
+
+Bugs (and requests for new features) can be reported to the author
+though the CPAN RT system:
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
+
+=head1 AUTHOR
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+Some code taken from B<Test::More> and B<Test::Catch>, written by by
+Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts
+Copyright Micheal G Schwern 2001. Used and distributed with
+permission.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 NOTES
+
+This code has been tested explicitly on the following versions
+of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004.
+
+Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
+me use his testing system to try this module out on.
+
+=head1 SEE ALSO
+
+L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
+
+=cut
+
+1;
+
+####################################################################
+# Helper class that is used to remember expected and received data
+
+package Test::Builder::Tester::Tie;
+
+##
+# add line(s) to be expected
+
+sub expect {
+ my $self = shift;
+
+ my @checks = @_;
+ foreach my $check (@checks) {
+ $check = $self->_translate_Failed_check($check);
+ push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
+ }
+}
+
+sub _translate_Failed_check {
+ my( $self, $check ) = @_;
+
+ if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
+ $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
+ }
+
+ return $check;
+}
+
+##
+# return true iff the expected data matches the got data
+
+sub check {
+ my $self = shift;
+
+ # turn off warnings as these might be undef
+ local $^W = 0;
+
+ my @checks = @{ $self->{wanted} };
+ my $got = $self->{got};
+ foreach my $check (@checks) {
+ $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
+ return 0 unless $got =~ s/^$check//;
+ }
+
+ return length $got == 0;
+}
+
+##
+# a complaint message about the inputs not matching (to be
+# used for debugging messages)
+
+sub complaint {
+ my $self = shift;
+ my $type = $self->type;
+ my $got = $self->got;
+ my $wanted = join "\n", @{ $self->wanted };
+
+ # are we running in colour mode?
+ if(Test::Builder::Tester::color) {
+ # get color
+ eval { require Term::ANSIColor };
+ unless($@) {
+ # colours
+
+ my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
+ my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
+ my $reset = Term::ANSIColor::color("reset");
+
+ # work out where the two strings start to differ
+ my $char = 0;
+ $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
+
+ # get the start string and the two end strings
+ my $start = $green . substr( $wanted, 0, $char );
+ my $gotend = $red . substr( $got, $char ) . $reset;
+ my $wantedend = $red . substr( $wanted, $char ) . $reset;
+
+ # make the start turn green on and off
+ $start =~ s/\n/$reset\n$green/g;
+
+ # make the ends turn red on and off
+ $gotend =~ s/\n/$reset\n$red/g;
+ $wantedend =~ s/\n/$reset\n$red/g;
+
+ # rebuild the strings
+ $got = $start . $gotend;
+ $wanted = $start . $wantedend;
+ }
+ }
+
+ return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
+}
+
+##
+# forget all expected and got data
+
+sub reset {
+ my $self = shift;
+ %$self = (
+ type => $self->{type},
+ got => '',
+ wanted => [],
+ );
+}
+
+sub got {
+ my $self = shift;
+ return $self->{got};
+}
+
+sub wanted {
+ my $self = shift;
+ return $self->{wanted};
+}
+
+sub type {
+ my $self = shift;
+ return $self->{type};
+}
+
+###
+# tie interface
+###
+
+sub PRINT {
+ my $self = shift;
+ $self->{got} .= join '', @_;
+}
+
+sub TIEHANDLE {
+ my( $class, $type ) = @_;
+
+ my $self = bless { type => $type }, $class;
+
+ $self->reset;
+
+ return $self;
+}
+
+sub READ { }
+sub READLINE { }
+sub GETC { }
+sub FILENO { }
+
+1;
--- /dev/null
+package Test::Builder::Tester::Color;
+
+use strict;
+our $VERSION = "1.18";
+
+require Test::Builder::Tester;
+
+
+=head1 NAME
+
+Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester
+
+=head1 SYNOPSIS
+
+ When running a test script
+
+ perl -MTest::Builder::Tester::Color test.t
+
+=head1 DESCRIPTION
+
+Importing this module causes the subroutine color in Test::Builder::Tester
+to be called with a true value causing colour highlighting to be turned
+on in debug output.
+
+The sole purpose of this module is to enable colour highlighting
+from the command line.
+
+=cut
+
+sub import {
+ Test::Builder::Tester::color(1);
+}
+
+=head1 AUTHOR
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 BUGS
+
+This module will have no effect unless Term::ANSIColor is installed.
+
+=head1 SEE ALSO
+
+L<Test::Builder::Tester>, L<Term::ANSIColor>
+
+=cut
+
+1;
--- /dev/null
+package Test::Harness;
+
+require 5.00405;
+
+use strict;
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source::Perl ();
+
+use TAP::Parser::Utils qw( split_shell );
+
+use Config;
+use Exporter;
+
+# TODO: Emulate at least some of these
+use vars qw(
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Color
+ $Directives
+ $Timer
+ $Strap
+ $has_time_hires
+ $IgnoreExit
+);
+
+# $ML $Last_ML_Print
+
+BEGIN {
+ eval q{use Time::HiRes 'time'};
+ $has_time_hires = !$@;
+}
+
+=head1 NAME
+
+Test::Harness - Run Perl standard test scripts with statistics
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+# Backwards compatibility for exportable variable names.
+*verbose = *Verbose;
+*switches = *Switches;
+*debug = *Debug;
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+@ISA = ('Exporter');
+@EXPORT = qw(&runtests);
+@EXPORT_OK = qw(&execute_tests $verbose $switches);
+
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
+$Debug = $ENV{HARNESS_DEBUG} || 0;
+$Switches = '-w';
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Columns--; # Some shells have trouble with a full line of text.
+$Timer = $ENV{HARNESS_TIMER} || 0;
+$Color = $ENV{HARNESS_COLOR} || 0;
+$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
+
+=head1 SYNOPSIS
+
+ use Test::Harness;
+
+ runtests(@test_files);
+
+=head1 DESCRIPTION
+
+Although, for historical reasons, the L<Test::Harness> distribution
+takes its name from this module it now exists only to provide
+L<TAP::Harness> with an interface that is somewhat backwards compatible
+with L<Test::Harness> 2.xx. If you're writing new code consider using
+L<TAP::Harness> directly instead.
+
+Emulation is provided for C<runtests> and C<execute_tests> but the
+pluggable 'Straps' interface that previous versions of L<Test::Harness>
+supported is not reproduced here. Straps is now available as a stand
+alone module: L<Test::Harness::Straps>.
+
+See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
+distribution.
+
+=head1 FUNCTIONS
+
+The following functions are available.
+
+=head2 runtests( @test_files )
+
+This runs all the given I<@test_files> and divines whether they passed
+or failed based on their output to STDOUT (details above). It prints
+out each individual test which failed along with a summary report and
+a how long it all took.
+
+It returns true if everything was ok. Otherwise it will C<die()> with
+one of the messages in the DIAGNOSTICS section.
+
+=cut
+
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
+}
+
+sub _aggregate {
+ my ( $harness, $aggregate, @tests ) = @_;
+
+ # Don't propagate to our children
+ local $ENV{HARNESS_OPTIONS};
+
+ _apply_extra_INC($harness);
+ _aggregate_tests( $harness, $aggregate, @tests );
+}
+
+# Make sure the child seens all the extra junk in @INC
+sub _apply_extra_INC {
+ my $harness = shift;
+
+ $harness->callback(
+ parser_args => sub {
+ my ( $args, $test ) = @_;
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
+ );
+}
+
+sub _aggregate_tests {
+ my ( $harness, $aggregate, @tests ) = @_;
+ $aggregate->start();
+ $harness->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop();
+
+}
+
+sub runtests {
+ my @tests = @_;
+
+ # shield against -l
+ local ( $\, $, );
+
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ _aggregate( $harness, $aggregate, @tests );
+
+ $harness->formatter->summary($aggregate);
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+ my $failed = $aggregate->failed;
+
+ my @parsers = $aggregate->parsers;
+
+ my $num_bad = 0;
+ for my $parser (@parsers) {
+ $num_bad++ if $parser->has_problems;
+ }
+
+ die(sprintf(
+ "Failed %d/%d test programs. %d/%d subtests failed.\n",
+ $num_bad, scalar @parsers, $failed, $total
+ )
+ ) if $num_bad;
+
+ return $total && $total == $passed;
+}
+
+sub _canon {
+ my @list = sort { $a <=> $b } @_;
+ my @ranges = ();
+ my $count = scalar @list;
+ my $pos = 0;
+
+ while ( $pos < $count ) {
+ my $end = $pos + 1;
+ $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
+ push @ranges, ( $end == $pos + 1 )
+ ? $list[$pos]
+ : join( '-', $list[$pos], $list[ $end - 1 ] );
+ $pos = $end;
+ }
+
+ return join( ' ', @ranges );
+}
+
+sub _new_harness {
+ my $sub_args = shift || {};
+
+ my ( @lib, @switches );
+ my @opt = split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} );
+ while ( my $opt = shift @opt ) {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, length($1) ? $1 : shift @opt;
+ }
+ else {
+ push @switches, $opt;
+ }
+ }
+
+ # Do things the old way on VMS...
+ push @lib, _filtered_inc() if IS_VMS;
+
+ # If $Verbose isn't numeric default to 1. This helps core.
+ my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
+
+ my $args = {
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ color => $Color,
+ verbosity => $verbosity,
+ ignore_exit => $IgnoreExit,
+ };
+
+ $args->{stdout} = $sub_args->{out}
+ if exists $sub_args->{out};
+
+ if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
+ for my $opt ( split /:/, $env_opt ) {
+ if ( $opt =~ /^j(\d*)$/ ) {
+ $args->{jobs} = $1 || 9;
+ }
+ elsif ( $opt eq 'c' ) {
+ $args->{color} = 1;
+ }
+ else {
+ die "Unknown HARNESS_OPTIONS item: $opt\n";
+ }
+ }
+ }
+
+ return TAP::Harness->new($args);
+}
+
+# Get the parts of @INC which are changed from the stock list AND
+# preserve reordering of stock directories.
+sub _filtered_inc {
+ my @inc = grep { !ref } @INC; #28567
+
+ if (IS_VMS) {
+
+ # VMS has a 255-byte limit on the length of %ENV entries, so
+ # toss the ones that involve perl_root, the install location
+ @inc = grep !/perl_root/i, @inc;
+
+ }
+ elsif (IS_WIN32) {
+
+ # Lose any trailing backslashes in the Win32 paths
+ s/[\\\/]+$// foreach @inc;
+ }
+
+ my @default_inc = _default_inc();
+
+ my @new_inc;
+ my %seen;
+ for my $dir (@inc) {
+ next if $seen{$dir}++;
+
+ if ( $dir eq ( $default_inc[0] || '' ) ) {
+ shift @default_inc;
+ }
+ else {
+ push @new_inc, $dir;
+ }
+
+ shift @default_inc while @default_inc and $seen{ $default_inc[0] };
+ }
+
+ return @new_inc;
+}
+
+{
+
+ # Cache this to avoid repeatedly shelling out to Perl.
+ my @inc;
+
+ sub _default_inc {
+ return @inc if @inc;
+
+ local $ENV{PERL5LIB};
+ local $ENV{PERLLIB};
+
+ my $perl = $ENV{HARNESS_PERL} || $^X;
+
+ # Avoid using -l for the benefit of Perl 6
+ chomp( @inc = `$perl -e "print join qq[\\n], \@INC, q[]"` );
+ return @inc;
+ }
+}
+
+sub _check_sequence {
+ my @list = @_;
+ my $prev;
+ while ( my $next = shift @list ) {
+ return if defined $prev && $next <= $prev;
+ $prev = $next;
+ }
+
+ return 1;
+}
+
+sub execute_tests {
+ my %args = @_;
+
+ my $harness = _new_harness( \%args );
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ my %tot = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ bad => 0,
+ good => 0,
+ files => 0,
+ tests => 0,
+ sub_skipped => 0,
+ todo => 0,
+ skipped => 0,
+ bench => undef,
+ );
+
+ # Install a callback so we get to see any plans the
+ #Â harness executes.
+ $harness->callback(
+ made_parser => sub {
+ my $parser = shift;
+ $parser->callback(
+ plan => sub {
+ my $plan = shift;
+ if ( $plan->directive eq 'SKIP' ) {
+ $tot{skipped}++;
+ }
+ }
+ );
+ }
+ );
+
+ _aggregate( $harness, $aggregate, @{ $args{tests} } );
+
+ $tot{bench} = $aggregate->elapsed;
+ my @tests = $aggregate->descriptions;
+
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = scalar @tests;
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test (@tests) {
+ my ($parser) = $aggregate->parsers($test);
+
+ my @failed = $parser->failed;
+
+ my $wstat = $parser->wait;
+ my $estat = $parser->exit;
+ my $planned = $parser->tests_planned;
+ my @errors = $parser->parse_errors;
+ my $passed = $parser->passed;
+ my $actual_passed = $parser->actual_passed;
+
+ my $ok_seq = _check_sequence( $parser->actual_passed );
+
+ # Duplicate exit, wait status semantics of old version
+ $estat ||= '' unless $wstat;
+ $wstat ||= '';
+
+ $tot{max} += ( $planned || 0 );
+ $tot{bonus} += $parser->todo_passed;
+ $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
+ $tot{sub_skipped} += $parser->skipped;
+ $tot{todo} += $parser->todo;
+
+ if ( @failed || $estat || @errors ) {
+ $tot{bad}++;
+
+ my $huh_planned = $planned ? undef : '??';
+ my $huh_errors = $ok_seq ? undef : '??';
+
+ $failedtests{$test} = {
+ 'canon' => $huh_planned
+ || $huh_errors
+ || _canon(@failed)
+ || '??',
+ 'estat' => $estat,
+ 'failed' => $huh_planned
+ || $huh_errors
+ || scalar @failed,
+ 'max' => $huh_planned || $planned,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ else {
+ $tot{good}++;
+ }
+
+ my @todo = $parser->todo_passed;
+ if (@todo) {
+ $todo_passed{$test} = {
+ 'canon' => _canon(@todo),
+ 'estat' => $estat,
+ 'failed' => scalar @todo,
+ 'max' => scalar $parser->todo,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ }
+
+ return ( \%tot, \%failedtests, \%todo_passed );
+}
+
+=head2 execute_tests( tests => \@test_files, out => \*FH )
+
+Runs all the given C<@test_files> (just like C<runtests()>) but
+doesn't generate the final report. During testing, progress
+information will be written to the currently selected output
+filehandle (usually C<STDOUT>), or to the filehandle given by the
+C<out> parameter. The I<out> is optional.
+
+Returns a list of two values, C<$total> and C<$failed>, describing the
+results. C<$total> is a hash ref summary of all the tests run. Its
+keys and values are this:
+
+ bonus Number of individual todo tests unexpectedly passed
+ max Number of individual tests ran
+ ok Number of individual tests passed
+ sub_skipped Number of individual tests skipped
+ todo Number of individual todo tests
+
+ files Number of test files ran
+ good Number of test files passed
+ bad Number of test files failed
+ tests Number of test files originally given
+ skipped Number of test files skipped
+
+If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
+got a successful test.
+
+C<$failed> is a hash ref of all the test scripts that failed. Each key
+is the name of a test script, each value is another hash representing
+how that script failed. Its keys are these:
+
+ name Name of the test which failed
+ estat Script's exit value
+ wstat Script's wait status
+ max Number of individual tests
+ failed Number which failed
+ canon List of tests which failed (as string).
+
+C<$failed> should be empty if everything passed.
+
+=cut
+
+1;
+__END__
+
+=head1 EXPORT
+
+C<&runtests> is exported by C<Test::Harness> by default.
+
+C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
+exported upon request.
+
+=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
+
+C<Test::Harness> sets these before executing the individual tests.
+
+=over 4
+
+=item C<HARNESS_ACTIVE>
+
+This is set to a true value. It allows the tests to determine if they
+are being executed through the harness or by any other means.
+
+=item C<HARNESS_VERSION>
+
+This is the version of C<Test::Harness>.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
+
+=over 4
+
+=item C<HARNESS_TIMER>
+
+Setting this to true will make the harness display the number of
+milliseconds each test took. You can also use F<prove>'s C<--timer>
+switch.
+
+=item C<HARNESS_VERBOSE>
+
+If true, C<Test::Harness> will output the verbose results of running
+its tests. Setting C<$Test::Harness::verbose> will override this,
+or you can use the C<-v> switch in the F<prove> utility.
+
+=item C<HARNESS_OPTIONS>
+
+Provide additional options to the harness. Currently supported options are:
+
+=over
+
+=item C<< j<n> >>
+
+Run <n> (default 9) parallel jobs.
+
+=item C<< f >>
+
+Use forked parallelism.
+
+=back
+
+Multiple options may be separated by colons:
+
+ HARNESS_OPTIONS=j9:f make test
+
+=back
+
+=head1 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> C<Test::Harness> (actually
+L<TAP::Parser::Source::Perl>) passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even in taint mode.
+
+=head1 SEE ALSO
+
+L<TAP::Harness>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
+notified, and then you'll automatically be notified of progress on your bug
+as I make changes.
+
+=head1 AUTHORS
+
+Andy Armstrong C<< <andy@hexten.net> >>
+
+L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
+module is based) has this attribution:
+
+ Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+ sure is, that it was inspired by Larry Wall's F<TEST> script that came
+ with perl distributions for ages. Numerous anonymous contributors
+ exist. Andreas Koenig held the torch for many years, and then
+ Michael G Schwern.
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
--- /dev/null
+package Test::More;
+
+use 5.006;
+use strict;
+use warnings;
+
+#---- perlcritic exemptions. ----#
+
+# We use a lot of subroutine prototypes
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
+
+# Can't use Carp because it might cause use_ok() to accidentally succeed
+# even though the module being used forgot to use Carp. Yes, this
+# actually happened.
+sub _carp {
+ my( $file, $line ) = ( caller(1) )[ 1, 2 ];
+ return warn @_, " at $file line $line\n";
+}
+
+our $VERSION = '0.88';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Builder::Module;
+our @ISA = qw(Test::Builder::Module);
+our @EXPORT = qw(ok use_ok require_ok
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
+ pass fail
+ eq_array eq_hash eq_set
+ $TODO
+ plan
+ done_testing
+ can_ok isa_ok new_ok
+ diag note explain
+ BAIL_OUT
+);
+
+=head1 NAME
+
+Test::More - yet another framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use Test::More tests => 23;
+ # or
+ use Test::More skip_all => $reason;
+ # or
+ use Test::More; # see done_testing()
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ require_ok( 'Some::Module' );
+
+ # Various ways to say "ok"
+ ok($got eq $expected, $test_name);
+
+ is ($got, $expected, $test_name);
+ isnt($got, $expected, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($got, qr/expected/, $test_name);
+ unlike($got, qr/expected/, $test_name);
+
+ cmp_ok($got, '==', $expected, $test_name);
+
+ is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
+
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ TODO: {
+ local $TODO = $why;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ can_ok($module, @methods);
+ isa_ok($object, $class);
+
+ pass($test_name);
+ fail($test_name);
+
+ BAIL_OUT($why);
+
+ # UNIMPLEMENTED!!!
+ my @status = Test::More::status;
+
+
+=head1 DESCRIPTION
+
+B<STOP!> If you're just getting started writing tests, have a look at
+L<Test::Simple> first. This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
+
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
+
+
+=head2 I love it when a plan comes together
+
+Before anything else, you need a testing plan. This basically declares
+how many tests your script is going to run to protect against premature
+failure.
+
+The preferred way to do this is to declare a plan when you C<use Test::More>.
+
+ use Test::More tests => 23;
+
+There are cases when you will not know beforehand how many tests your
+script is going to run. In this case, you can declare your tests at
+the end.
+
+ use Test::More;
+
+ ... run your tests ...
+
+ done_testing( $number_of_tests_run );
+
+Sometimes you really don't know how many tests were run, or it's too
+difficult to calculate. In which case you can leave off
+$number_of_tests_run.
+
+In some cases, you'll want to completely skip an entire testing script.
+
+ use Test::More skip_all => $skip_reason;
+
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success). See L<Test::Harness> for
+details.
+
+If you want to control what functions Test::More will export, you
+have to use the 'import' option. For example, to import everything
+but 'fail', you'd do:
+
+ use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function. Useful for when you
+have to calculate the number of tests.
+
+ use Test::More;
+ plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+ use Test::More;
+ if( $^O eq 'MacOS' ) {
+ plan skip_all => 'Test irrelevant on MacOS';
+ }
+ else {
+ plan tests => 42;
+ }
+
+=cut
+
+sub plan {
+ my $tb = Test::More->builder;
+
+ return $tb->plan(@_);
+}
+
+# This implements "use Test::More 'no_diag'" but the behavior is
+# deprecated.
+sub import_extra {
+ my $class = shift;
+ my $list = shift;
+
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'no_diag' ) {
+ $class->builder->no_diag(1);
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return;
+}
+
+=over 4
+
+=item B<done_testing>
+
+ done_testing();
+ done_testing($number_of_tests);
+
+If you don't know how many tests you're going to run, you can issue
+the plan when you're done running tests.
+
+$number_of_tests is the same as plan(), it's the number of tests you
+expected to run. You can omit this, in which case the number of tests
+you ran doesn't matter, just the fact that your tests ran to
+conclusion.
+
+This is safer than and replaces the "no_plan" plan.
+
+=back
+
+=cut
+
+sub done_testing {
+ my $tb = Test::More->builder;
+ $tb->done_testing(@_);
+}
+
+=head2 Test names
+
+By convention, each test is assigned a number in order. This is
+largely done automatically for you. However, it's often very useful to
+assign a name to each test. Which would you rather see:
+
+ ok 4
+ not ok 5
+ ok 6
+
+or
+
+ ok 4 - basic multi-variable
+ not ok 5 - simple exponential
+ ok 6 - force == mass * acceleration
+
+The later gives you some idea of what failed. It also makes it easier
+to find the test in your script, simply search for "simple
+exponential".
+
+All test functions take a name argument. It's optional, but highly
+suggested that you use it.
+
+
+=head2 I'm ok, you're not ok.
+
+The basic purpose of this module is to print out either "ok #" or "not
+ok #" depending on if a given test succeeded or failed. Everything
+else is just gravy.
+
+All of the following print "ok" or "not ok" depending on if the test
+succeeded or failed. They all also return true or false,
+respectively.
+
+=over 4
+
+=item B<ok>
+
+ ok($got eq $expected, $test_name);
+
+This simply evaluates any expression (C<$got eq $expected> is just a
+simple example) and uses that to determine if the test succeeded or
+failed. A true expression passes, a false one fails. Very simple.
+
+For example:
+
+ ok( $exp{9} == 81, 'simple exponential' );
+ ok( Film->can('db_Main'), 'set_db()' );
+ ok( $p->tests == 4, 'saw tests' );
+ ok( !grep !defined $_, @items, 'items populated' );
+
+(Mnemonic: "This is ok.")
+
+$test_name is a very short description of the test that will be printed
+out. It makes it very easy to find a test in your script when it fails
+and gives others an idea of your intentions. $test_name is optional,
+but we B<very> strongly encourage its use.
+
+Should an ok() fail, it will produce some diagnostics:
+
+ not ok 18 - sufficient mucus
+ # Failed test 'sufficient mucus'
+ # in foo.t at line 42.
+
+This is the same as Test::Simple's ok() routine.
+
+=cut
+
+sub ok ($;$) {
+ my( $test, $name ) = @_;
+ my $tb = Test::More->builder;
+
+ return $tb->ok( $test, $name );
+}
+
+=item B<is>
+
+=item B<isnt>
+
+ is ( $got, $expected, $test_name );
+ isnt( $got, $expected, $test_name );
+
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> respectively and use the result of that to
+determine if the test succeeded or failed. So these:
+
+ # Is the ultimate answer 42?
+ is( ultimate_answer(), 42, "Meaning of Life" );
+
+ # $foo isn't empty
+ isnt( $foo, '', "Got some foo" );
+
+are similar to these:
+
+ ok( ultimate_answer() eq 42, "Meaning of Life" );
+ ok( $foo ne '', "Got some foo" );
+
+(Mnemonic: "This is that." "This isn't that.")
+
+So why use these? They produce better diagnostics on failure. ok()
+cannot know what you are testing for (beyond the name), but is() and
+isnt() know what the test was and why it failed. For example this
+test:
+
+ my $foo = 'waffle'; my $bar = 'yarblokos';
+ is( $foo, $bar, 'Is foo the same as bar?' );
+
+Will produce something like this:
+
+ not ok 17 - Is foo the same as bar?
+ # Failed test 'Is foo the same as bar?'
+ # in foo.t at line 139.
+ # got: 'waffle'
+ # expected: 'yarblokos'
+
+So you can figure out what went wrong without rerunning the test.
+
+You are encouraged to use is() and isnt() over ok() where possible,
+however do not be tempted to use them to find out if something is
+true or false!
+
+ # XXX BAD!
+ is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
+
+This does not check if C<exists $brooklyn{tree}> is true, it checks if
+it returns 1. Very different. Similar caveats exist for false and 0.
+In these cases, use ok().
+
+ ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
+
+A simple call to isnt() usually does not provide a strong test but there
+are cases when you cannot say much more about a value than that it is
+different from some other value:
+
+ new_ok $obj, "Foo";
+
+ my $clone = $obj->clone;
+ isa_ok $obj, "Foo", "Foo->clone";
+
+ isnt $obj, $clone, "clone() produces a different object";
+
+For those grammatical pedants out there, there's an C<isn't()>
+function which is an alias of isnt().
+
+=cut
+
+sub is ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->is_eq(@_);
+}
+
+sub isnt ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->isnt_eq(@_);
+}
+
+*isn't = \&isnt;
+
+=item B<like>
+
+ like( $got, qr/expected/, $test_name );
+
+Similar to ok(), like() matches $got against the regex C<qr/expected/>.
+
+So this:
+
+ like($got, qr/expected/, 'this is like that');
+
+is similar to:
+
+ ok( $got =~ /expected/, 'this is like that');
+
+(Mnemonic "This is like that".)
+
+The second argument is a regular expression. It may be given as a
+regex reference (i.e. C<qr//>) or (for better compatibility with older
+perls) as a string that looks like a regex (alternative delimiters are
+currently not supported):
+
+ like( $got, '/expected/', 'this is like that' );
+
+Regex options may be placed on the end (C<'/expected/i'>).
+
+Its advantages over ok() are similar to that of is() and isnt(). Better
+diagnostics on failure.
+
+=cut
+
+sub like ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->like(@_);
+}
+
+=item B<unlike>
+
+ unlike( $got, qr/expected/, $test_name );
+
+Works exactly as like(), only it checks if $got B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->unlike(@_);
+}
+
+=item B<cmp_ok>
+
+ cmp_ok( $got, $op, $expected, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $got eq $expected );
+ cmp_ok( $got, 'eq', $expected, 'this eq that' );
+
+ # ok( $got == $expected );
+ cmp_ok( $got, '==', $expected, 'this == that' );
+
+ # ok( $got && $expected );
+ cmp_ok( $got, '&&', $expected, 'this && that' );
+ ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $got
+and $expected were:
+
+ not ok 1
+ # Failed test in foo.t at line 12.
+ # '23'
+ # &&
+ # undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+It's especially useful when comparing greater-than or smaller-than
+relation between values:
+
+ cmp_ok( $some_value, '<=', $upper_limit );
+
+
+=cut
+
+sub cmp_ok($$$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->cmp_ok(@_);
+}
+
+=item B<can_ok>
+
+ can_ok($module, @methods);
+ can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+ can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
+ );
+
+only without all the typing and with a better interface. Handy for
+quickly testing an interface.
+
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
+=cut
+
+sub can_ok ($@) {
+ my( $proto, @methods ) = @_;
+ my $class = ref $proto || $proto;
+ my $tb = Test::More->builder;
+
+ unless($class) {
+ my $ok = $tb->ok( 0, "->can(...)" );
+ $tb->diag(' can_ok() called with empty class or reference');
+ return $ok;
+ }
+
+ unless(@methods) {
+ my $ok = $tb->ok( 0, "$class->can(...)" );
+ $tb->diag(' can_ok() called with no methods');
+ return $ok;
+ }
+
+ my @nok = ();
+ foreach my $method (@methods) {
+ $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
+ }
+
+ my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
+ "$class->can(...)" ;
+
+ my $ok = $tb->ok( !@nok, $name );
+
+ $tb->diag( map " $class->can('$_') failed\n", @nok );
+
+ return $ok;
+}
+
+=item B<isa_ok>
+
+ isa_ok($object, $class, $object_name);
+ isa_ok($subclass, $class, $object_name);
+ isa_ok($ref, $type, $ref_name);
+
+Checks to see if the given C<< $object->isa($class) >>. Also checks to make
+sure the object was defined in the first place. Handy for this sort
+of thing:
+
+ my $obj = Some::Module->new;
+ isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+ my $obj = Some::Module->new;
+ ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+You can also test a class, to make sure that it has the right ancestor:
+
+ isa_ok( 'Vole', 'Rodent' );
+
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'. If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
+=cut
+
+sub isa_ok ($$;$) {
+ my( $object, $class, $obj_name ) = @_;
+ my $tb = Test::More->builder;
+
+ my $diag;
+
+ if( !defined $object ) {
+ $obj_name = 'The thing' unless defined $obj_name;
+ $diag = "$obj_name isn't defined";
+ }
+ else {
+ my $whatami = ref $object ? 'object' : 'class';
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
+ if($error) {
+ if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
+ # Its an unblessed reference
+ $obj_name = 'The reference' unless defined $obj_name;
+ if( !UNIVERSAL::isa( $object, $class ) ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+ elsif( $error =~ /Can't call method "isa" without a package/ ) {
+ # It's something that can't even be a class
+ $diag = "$obj_name isn't a class or reference";
+ }
+ else {
+ die <<WHOA;
+WHOA! I tried to call ->isa on your $whatami and got some weird error.
+Here's the error.
+$error
+WHOA
+ }
+ }
+ else {
+ $obj_name = "The $whatami" unless defined $obj_name;
+ if( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+ }
+
+ my $name = "$obj_name isa $class";
+ my $ok;
+ if($diag) {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
+ }
+ else {
+ $ok = $tb->ok( 1, $name );
+ }
+
+ return $ok;
+}
+
+=item B<new_ok>
+
+ my $obj = new_ok( $class );
+ my $obj = new_ok( $class => \@args );
+ my $obj = new_ok( $class => \@args, $object_name );
+
+A convenience function which combines creating an object and calling
+isa_ok() on that object.
+
+It is basically equivalent to:
+
+ my $obj = $class->new(@args);
+ isa_ok $obj, $class, $object_name;
+
+If @args is not given, an empty list will be used.
+
+This function only works on new() and it assumes new() will return
+just a single object which isa C<$class>.
+
+=cut
+
+sub new_ok {
+ my $tb = Test::More->builder;
+ $tb->croak("new_ok() must be given at least a class") unless @_;
+
+ my( $class, $args, $object_name ) = @_;
+
+ $args ||= [];
+ $object_name = "The object" unless defined $object_name;
+
+ my $obj;
+ my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
+ if($success) {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ isa_ok $obj, $class, $object_name;
+ }
+ else {
+ $tb->ok( 0, "new() died" );
+ $tb->diag(" Error was: $error");
+ }
+
+ return $obj;
+}
+
+=item B<pass>
+
+=item B<fail>
+
+ pass($test_name);
+ fail($test_name);
+
+Sometimes you just want to say that the tests have passed. Usually
+the case is you've got some complicated condition that is difficult to
+wedge into an ok(). In this case, you can simply use pass() (to
+declare the test ok) or fail (for not ok). They are synonyms for
+ok(1) and ok(0).
+
+Use these very, very, very sparingly.
+
+=cut
+
+sub pass (;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->ok( 1, @_ );
+}
+
+sub fail (;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->ok( 0, @_ );
+}
+
+=back
+
+
+=head2 Module tests
+
+You usually want to test if the module you're testing loads ok, rather
+than just vomiting if its load fails. For such purposes we have
+C<use_ok> and C<require_ok>.
+
+=over 4
+
+=item B<use_ok>
+
+ BEGIN { use_ok($module); }
+ BEGIN { use_ok($module, @imports); }
+
+These simply use the given $module and test to make sure the load
+happened ok. It's recommended that you run use_ok() inside a BEGIN
+block so its functions are exported at compile-time and prototypes are
+properly honored.
+
+If @imports are given, they are passed through to the use. So this:
+
+ BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+ use Some::Module qw(foo bar);
+
+Version numbers can be checked like so:
+
+ # Just like "use Some::Module 1.02"
+ BEGIN { use_ok('Some::Module', 1.02) }
+
+Don't try to do this:
+
+ BEGIN {
+ use_ok('Some::Module');
+
+ ...some code that depends on the use...
+ ...happening at compile time...
+ }
+
+because the notion of "compile-time" is relative. Instead, you want:
+
+ BEGIN { use_ok('Some::Module') }
+ BEGIN { ...some code that depends on the use... }
+
+
+=cut
+
+sub use_ok ($;@) {
+ my( $module, @imports ) = @_;
+ @imports = () unless @imports;
+ my $tb = Test::More->builder;
+
+ my( $pack, $filename, $line ) = caller;
+
+ my $code;
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ $code = <<USE;
+package $pack;
+use $module $imports[0];
+1;
+USE
+ }
+ else {
+ $code = <<USE;
+package $pack;
+use $module \@{\$args[0]};
+1;
+USE
+ }
+
+ my( $eval_result, $eval_error ) = _eval( $code, \@imports );
+ my $ok = $tb->ok( $eval_result, "use $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+ {BEGIN failed--compilation aborted at $filename line $line.}m;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to use '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _eval {
+ my( $code, @args ) = @_;
+
+ # Work around oddities surrounding resetting of $@ by immediately
+ # storing it.
+ my( $sigdie, $eval_result, $eval_error );
+ {
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+ $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+ $eval_error = $@;
+ $sigdie = $SIG{__DIE__} || undef;
+ }
+ # make sure that $code got a chance to set $SIG{__DIE__}
+ $SIG{__DIE__} = $sigdie if defined $sigdie;
+
+ return( $eval_result, $eval_error );
+}
+
+=item B<require_ok>
+
+ require_ok($module);
+ require_ok($file);
+
+Like use_ok(), except it requires the $module or $file.
+
+=cut
+
+sub require_ok ($) {
+ my($module) = shift;
+ my $tb = Test::More->builder;
+
+ my $pack = caller;
+
+ # Try to deterine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ my $code = <<REQUIRE;
+package $pack;
+require $module;
+1;
+REQUIRE
+
+ my( $eval_result, $eval_error ) = _eval($code);
+ my $ok = $tb->ok( $eval_result, "require $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+
+ return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
+}
+
+=back
+
+
+=head2 Complex data structures
+
+Not everything is a simple eq check or regex. There are times you
+need to see if two data structures are equivalent. For these
+instances Test::More provides a handful of useful functions.
+
+B<NOTE> I'm not quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $got, $expected, $test_name );
+
+Similar to is(), except that if $got and $expected are references, it
+does a deep comparison walking each data structure to see if they are
+equivalent. If the two structures are different, it will display the
+place where they start differing.
+
+is_deeply() compares the dereferenced values of references, the
+references themselves (except for their type) are ignored. This means
+aspects such as blessing and ties are not considered "different".
+
+is_deeply() currently has very limited handling of function reference
+and globs. It merely checks if they have the same referent. This may
+improve in the future.
+
+L<Test::Differences> and L<Test::Deep> provide more in-depth functionality
+along these lines.
+
+=cut
+
+our( @Data_Stack, %Refs_Seen );
+my $DNE = bless [], 'Does::Not::Exist';
+
+sub _dne {
+ return ref $_[0] eq ref $DNE;
+}
+
+## no critic (Subroutines::RequireArgUnpacking)
+sub is_deeply {
+ my $tb = Test::More->builder;
+
+ unless( @_ == 2 or @_ == 3 ) {
+ my $msg = <<'WARNING';
+is_deeply() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ _carp sprintf $msg, scalar @_;
+
+ return $tb->ok(0);
+ }
+
+ my( $got, $expected, $name ) = @_;
+
+ $tb->_unoverload_str( \$expected, \$got );
+
+ my $ok;
+ if( !ref $got and !ref $expected ) { # neither is a reference
+ $ok = $tb->is_eq( $got, $expected, $name );
+ }
+ elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
+ }
+ else { # both references
+ local @Data_Stack = ();
+ if( _deep_check( $got, $expected ) ) {
+ $ok = $tb->ok( 1, $name );
+ }
+ else {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack(@Data_Stack) );
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my(@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
+ my @vars = ();
+ ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
+ ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
+
+ my $out = "Structures begin differing at:\n";
+ foreach my $idx ( 0 .. $#vals ) {
+ my $val = $vals[$idx];
+ $vals[$idx]
+ = !defined $val ? 'undef'
+ : _dne($val) ? "Does not exist"
+ : ref $val ? "$val"
+ : "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ return $type if UNIVERSAL::isa( $thing, $type );
+ }
+
+ return '';
+}
+
+=back
+
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Like C<print> @diagnostic_message is simply concatenated
+together.
+
+Returns false, so as to preserve failure.
+
+Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test 'There's a foo user'
+ # in foo.t at line 52.
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=item B<note>
+
+ note(@diagnostic_message);
+
+Like diag(), except the message will not be seen when the test is run
+in a harness. It will only be visible in the verbose TAP stream.
+
+Handy for putting in notes which might be useful for debugging, but
+don't indicate a problem.
+
+ note("Tempfile is $tempfile");
+
+=cut
+
+sub diag {
+ return Test::More->builder->diag(@_);
+}
+
+sub note {
+ return Test::More->builder->note(@_);
+}
+
+=item B<explain>
+
+ my @dump = explain @diagnostic_message;
+
+Will dump the contents of any references in a human readable format.
+Usually you want to pass this into C<note> or C<diag>.
+
+Handy for things like...
+
+ is_deeply($have, $want) || diag explain $have;
+
+or
+
+ note explain \%args;
+ Some::Class->method(%args);
+
+=cut
+
+sub explain {
+ return Test::More->builder->explain(@_);
+}
+
+=back
+
+
+=head2 Conditional tests
+
+Sometimes running a test under certain conditions will cause the
+test script to die. A certain function or method isn't implemented
+(such as fork() on MacOS), some resource isn't available (like a
+net connection) or a module isn't available. In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
+but will work in the future (a todo test).
+
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
+
+The way Test::More handles this is with a named block. Basically, a
+block of tests which can be skipped over or made todo. It's best if I
+just show you...
+
+=over 4
+
+=item B<SKIP: BLOCK>
+
+ SKIP: {
+ skip $why, $how_many if $condition;
+
+ ...normal testing code goes here...
+ }
+
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them. An example is
+the easiest way to illustrate:
+
+ SKIP: {
+ eval { require HTML::Lint };
+
+ skip "HTML::Lint not installed", 2 if $@;
+
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
+
+ $lint->parse( $html );
+ is( $lint->errors, 0, "No errors found in HTML" );
+ }
+
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>. Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
+
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
+
+It's perfectly safe to nest SKIP blocks. Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
+
+You don't skip tests which are failing because there's a bug in your
+program, or for which you don't yet have code written. For that you
+use TODO. Read on.
+
+=cut
+
+## no critic (Subroutines::RequireFinalReturn)
+sub skip {
+ my( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ if( defined $how_many and $how_many =~ /\D/ ) {
+ _carp
+ "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
+ $how_many = 1;
+ }
+
+ for( 1 .. $how_many ) {
+ $tb->skip($why);
+ }
+
+ no warnings 'exiting';
+ last SKIP;
+}
+
+=item B<TODO: BLOCK>
+
+ TODO: {
+ local $TODO = $why if $condition;
+
+ ...normal testing code goes here...
+ }
+
+Declares a block of tests you expect to fail and $why. Perhaps it's
+because you haven't fixed a bug or haven't finished a new feature:
+
+ TODO: {
+ local $TODO = "URI::Geller not finished";
+
+ my $card = "Eight of clubs";
+ is( URI::Geller->your_card, $card, 'Is THIS your card?' );
+
+ my $spoon;
+ URI::Geller->bend_spoon;
+ is( $spoon, 'bent', "Spoon bending, that's original" );
+ }
+
+With a todo block, the tests inside are expected to fail. Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo". Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programmatic todo list. You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+B<NOTE>: TODO tests require a Test::Harness upgrade else it will
+treat it as a normal failure. See L<CAVEATS and NOTES>).
+
+
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+With todo tests, it's best to have the tests actually run. That way
+you'll know when they start passing. Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>. In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "todo_skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ for( 1 .. $how_many ) {
+ $tb->todo_skip($why);
+ }
+
+ no warnings 'exiting';
+ last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
+
+B<If it's something the programmer hasn't done yet>, use TODO. This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
+
+
+=back
+
+
+=head2 Test control
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ BAIL_OUT($reason);
+
+Indicates to the harness that things are going so badly all testing
+should terminate. This includes the running any additional test scripts.
+
+This is typically used when testing cannot continue such as a critical
+module failing to compile or a necessary external utility not being
+available such as a database connection failing.
+
+The test will exit with 255.
+
+For even better control look at L<Test::Most>.
+
+=cut
+
+sub BAIL_OUT {
+ my $reason = shift;
+ my $tb = Test::More->builder;
+
+ $tb->BAIL_OUT($reason);
+}
+
+=back
+
+
+=head2 Discouraged comparison functions
+
+The use of the following functions is discouraged as they are not
+actually testing functions and produce no diagnostics to help figure
+out what went wrong. They were written before is_deeply() existed
+because I couldn't figure out how to display a useful diff of two
+arbitrary data structures.
+
+These functions are usually used inside an ok().
+
+ ok( eq_array(\@got, \@expected) );
+
+C<is_deeply()> can do that better and with diagnostics.
+
+ is_deeply( \@got, \@expected );
+
+They may be deprecated in future versions.
+
+=over 4
+
+=item B<eq_array>
+
+ my $is_eq = eq_array(\@got, \@expected);
+
+Checks if two arrays are equivalent. This is a deep check, so
+multi-level structures are handled correctly.
+
+=cut
+
+#'#
+sub eq_array {
+ local @Data_Stack = ();
+ _deep_check(@_);
+}
+
+sub _eq_array {
+ my( $a1, $a2 ) = @_;
+
+ if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
+ warn "eq_array passed a non-array ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for( 0 .. $max ) {
+ my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+ push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+sub _deep_check {
+ my( $e1, $e2 ) = @_;
+ my $tb = Test::More->builder;
+
+ my $ok = 0;
+
+ # Effectively turn %Refs_Seen into a stack. This avoids picking up
+ # the same referenced used twice (such as [\$a, \$a]) to be considered
+ # circular.
+ local %Refs_Seen = %Refs_Seen;
+
+ {
+ # Quiet uninitialized value warnings when comparing undefs.
+ no warnings 'uninitialized';
+
+ $tb->_unoverload_str( \$e1, \$e2 );
+
+ # Either they're both references or both not.
+ my $same_ref = !( !ref $e1 xor !ref $e2 );
+ my $not_ref = ( !ref $e1 and !ref $e2 );
+
+ if( defined $e1 xor defined $e2 ) {
+ $ok = 0;
+ }
+ elsif( !defined $e1 and !defined $e2 ) {
+ # Shortcut if they're both defined.
+ $ok = 1;
+ }
+ elsif( _dne($e1) xor _dne($e2) ) {
+ $ok = 0;
+ }
+ elsif( $same_ref and( $e1 eq $e2 ) ) {
+ $ok = 1;
+ }
+ elsif($not_ref) {
+ push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ if( $Refs_Seen{$e1} ) {
+ return $Refs_Seen{$e1} eq $e2;
+ }
+ else {
+ $Refs_Seen{$e1} = "$e2";
+ }
+
+ my $type = _type($e1);
+ $type = 'DIFFERENT' unless _type($e2) eq $type;
+
+ if( $type eq 'DIFFERENT' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $ok = _eq_array( $e1, $e2 );
+ }
+ elsif( $type eq 'HASH' ) {
+ $ok = _eq_hash( $e1, $e2 );
+ }
+ elsif( $type eq 'REF' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif($type) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ _whoa( 1, "No type in _deep_check" );
+ }
+ }
+ }
+
+ return $ok;
+}
+
+sub _whoa {
+ my( $check, $desc ) = @_;
+ if($check) {
+ die <<"WHOA";
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+=item B<eq_hash>
+
+ my $is_eq = eq_hash(\%got, \%expected);
+
+Determines if the two hashes contain the same keys and values. This
+is a deep check.
+
+=cut
+
+sub eq_hash {
+ local @Data_Stack = ();
+ return _deep_check(@_);
+}
+
+sub _eq_hash {
+ my( $a1, $a2 ) = @_;
+
+ if( grep _type($_) ne 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ foreach my $k ( keys %$bigger ) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+=item B<eq_set>
+
+ my $is_eq = eq_set(\@got, \@expected);
+
+Similar to eq_array(), except the order of the elements is B<not>
+important. This is a deep check, but the irrelevancy of order only
+applies to the top level.
+
+ ok( eq_set(\@got, \@expected) );
+
+Is better written:
+
+ is_deeply( [sort @got], [sort @expected] );
+
+B<NOTE> By historical accident, this is not a true set comparison.
+While the order of elements does not matter, duplicate elements do.
+
+B<NOTE> eq_set() does not know how to deal with references at the top
+level. The following is an example of a comparison which might not work:
+
+ eq_set([\1, \2], [\2, \1]);
+
+L<Test::Deep> contains much better set comparison functions.
+
+=cut
+
+sub eq_set {
+ my( $a1, $a2 ) = @_;
+ return 0 unless @$a1 == @$a2;
+
+ no warnings 'uninitialized';
+
+ # It really doesn't matter how we sort them, as long as both arrays are
+ # sorted with the same algorithm.
+ #
+ # Ensure that references are not accidentally treated the same as a
+ # string containing the reference.
+ #
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ #
+ # I don't know how references would be sorted so we just don't sort
+ # them. This means eq_set doesn't really work with refs.
+ return eq_array(
+ [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
+ [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
+ );
+}
+
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+ my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+
+=back
+
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+B<NOTE> This behavior may go away in future versions.
+
+
+=head1 CAVEATS and NOTES
+
+=over 4
+
+=item Backwards compatibility
+
+Test::More works with Perls as old as 5.6.0.
+
+
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings> (or in cmp_ok()'s
+case, strings or numbers as appropriate to the comparison op). This
+prevents Test::More from piercing an object's interface allowing
+better blackbox testing. So if a function starts returning overloaded
+objects instead of bare strings your tests won't notice the
+difference. This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects. In this case I would
+suggest L<Test::Deep> which contains more flexible testing functions for
+complex data structures.
+
+
+=item Threads
+
+Test::More will only be aware of threads if "use threads" has been done
+I<before> Test::More is loaded. This is ok:
+
+ use threads;
+ use Test::More;
+
+This may cause problems:
+
+ use Test::More
+ use threads;
+
+5.8.1 and above are supported. Anything below that has too many bugs.
+
+
+=item Test::Harness upgrade
+
+no_plan, todo and done_testing() depend on new Test::Harness features
+and fixes. If you're going to distribute tests that use no_plan or
+todo your end-users will have to upgrade Test::Harness to the latest
+one on CPAN. If you avoid no_plan and TODO tests, the stock
+Test::Harness will work fine.
+
+Installing Test::More should also upgrade Test::Harness.
+
+=back
+
+
+=head1 HISTORY
+
+This is a case of convergent evolution with Joshua Pritikin's Test
+module. I was largely unaware of its existence when I'd first
+written my own ok() routines. This module exists because I can't
+figure out how to easily wedge test names into Test's interface (along
+with a few other problems).
+
+The goal here is to have a testing utility that's simple to learn,
+quick to use and difficult to trip yourself up with while still
+providing more flexibility than the existing Test.pm. As such, the
+names of the most common routines are kept tiny, special cases and
+magic side-effects are kept to a minimum. WYSIWYG.
+
+
+=head1 SEE ALSO
+
+L<Test::Simple> if all this confuses you and you just want to write
+some tests. You can upgrade to Test::More later (it's forward
+compatible).
+
+L<Test::Harness> is the test runner and output interpreter for Perl.
+It's the thing that powers C<make test> and where the C<prove> utility
+comes from.
+
+L<Test::Legacy> tests written with Test.pm, the original testing
+module, do not play well with other testing libraries. Test::Legacy
+emulates the Test.pm interface and does play well with others.
+
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test::Class> is like xUnit but more perlish.
+
+L<Test::Deep> gives you more powerful complex data structure testing.
+
+L<Test::Inline> shows the idea of embedded testing.
+
+L<Bundle::Test> installs a whole bunch of useful test modules.
+
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
+
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/schwern/test-more/>.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
--- /dev/null
+package Test::Simple;
+
+use 5.004;
+
+use strict;
+
+our $VERSION = '0.88';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Builder::Module;
+our @ISA = qw(Test::Builder::Module);
+our @EXPORT = qw(ok);
+
+my $CLASS = __PACKAGE__;
+
+=head1 NAME
+
+Test::Simple - Basic utilities for writing tests.
+
+=head1 SYNOPSIS
+
+ use Test::Simple tests => 1;
+
+ ok( $foo eq $bar, 'foo is bar' );
+
+
+=head1 DESCRIPTION
+
+** If you are unfamiliar with testing B<read Test::Tutorial> first! **
+
+This is an extremely simple, extremely basic module for writing tests
+suitable for CPAN modules and other pursuits. If you wish to do more
+complicated testing, use the Test::More module (a drop-in replacement
+for this one).
+
+The basic unit of Perl testing is the ok. For each thing you want to
+test your program will print out an "ok" or "not ok" to indicate pass
+or fail. You do this with the ok() function (see below).
+
+The only other constraint is you must pre-declare how many tests you
+plan to run. This is in case something goes horribly wrong during the
+test and your test program aborts, or skips a test or whatever. You
+do this like so:
+
+ use Test::Simple tests => 23;
+
+You must have a plan.
+
+
+=over 4
+
+=item B<ok>
+
+ ok( $foo eq $bar, $name );
+ ok( $foo eq $bar );
+
+ok() is given an expression (in this case C<$foo eq $bar>). If it's
+true, the test passed. If it's false, it didn't. That's about it.
+
+ok() prints out either "ok" or "not ok" along with a test number (it
+keeps track of that for you).
+
+ # This produces "ok 1 - Hell not yet frozen over" (or not ok)
+ ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
+
+If you provide a $name, that will be printed along with the "ok/not
+ok" to make it easier to find your test when if fails (just search for
+the name). It also makes it easier for the next guy to understand
+what your test is for. It's highly recommended you use test names.
+
+All tests are run in scalar context. So this:
+
+ ok( @stuff, 'I have some stuff' );
+
+will do what you mean (fail if stuff is empty)
+
+=cut
+
+sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
+ return $CLASS->builder->ok(@_);
+}
+
+=back
+
+Test::Simple will start by printing number of tests run in the form
+"1..M" (so "1..5" means you're going to run 5 tests). This strange
+format lets Test::Harness know how many tests you plan on running in
+case something goes horribly wrong.
+
+If all your tests passed, Test::Simple will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Simple
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+This module is by no means trying to be a complete testing system.
+It's just to get you started. Once you're off the ground its
+recommended you look at L<Test::More>.
+
+
+=head1 EXAMPLE
+
+Here's an example of a simple .t file for the fictional Film module.
+
+ use Test::Simple tests => 5;
+
+ use Film; # What you're testing.
+
+ my $btaste = Film->new({ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 1
+ });
+ ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' );
+
+ ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
+ ok( $btaste->Director eq 'Peter Jackson', 'Director() get' );
+ ok( $btaste->Rating eq 'R', 'Rating() get' );
+ ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
+
+It will produce output like this:
+
+ 1..5
+ ok 1 - new() works
+ ok 2 - Title() get
+ ok 3 - Director() get
+ not ok 4 - Rating() get
+ # Failed test 'Rating() get'
+ # in t/film.t at line 14.
+ ok 5 - NumExplodingSheep() get
+ # Looks like you failed 1 tests of 5
+
+Indicating the Film::Rating() method is broken.
+
+
+=head1 CAVEATS
+
+Test::Simple will only report a maximum of 254 failures in its exit
+code. If this is a problem, you probably have a huge test script.
+Split it into multiple files. (Otherwise blame the Unix folks for
+using an unsigned short integer as the exit status).
+
+Because VMS's exit codes are much, much different than the rest of the
+universe, and perl does horrible mangling to them that gets in my way,
+it works like this on VMS.
+
+ 0 SS$_NORMAL all tests successful
+ 4 SS$_ABORT something went wrong
+
+Unfortunately, I can't differentiate any further.
+
+
+=head1 NOTES
+
+Test::Simple is B<explicitly> tested all the way back to perl 5.004.
+
+Test::Simple is thread-safe in perl 5.8.0 and up.
+
+=head1 HISTORY
+
+This module was conceived while talking with Tony Bowden in his
+kitchen one night about the problems I was having writing some really
+complicated feature into the new Testing module. He observed that the
+main problem is not dealing with these edge cases but that people hate
+to write tests B<at all>. What was needed was a dead simple module
+that took all the hard work out of testing and was really, really easy
+to learn. Paul Johnson simultaneously had this idea (unfortunately,
+he wasn't in Tony's kitchen). This is it.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Test::More>
+
+More testing functions! Once you outgrow Test::Simple, look at
+Test::More. Test::Simple is 100% forward compatible with Test::More
+(i.e. you can just use Test::More instead of Test::Simple in your
+programs and things will still work).
+
+=back
+
+Look in Test::More's SEE ALSO for more testing modules.
+
+
+=head1 AUTHORS
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser>
+and L<TAP::Harness>
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+use constant GOT_TIME_HIRES => do {
+ eval 'use Time::HiRes qw(time);';
+ $@ ? 0 : 1;
+};
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
+
+ # ... later ...
+
+ my $thing = TAP::Whatever->new();
+
+ $thing->callback( event => sub {
+ # do something interesting
+ } );
+
+=head1 DESCRIPTION
+
+C<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for, $ok_callback ) = @_;
+
+ my %ok_map = map { $_ => 1 } @$ok_callback;
+
+ $self->{ok_callbacks} = \%ok_map;
+
+ if ( my $cb = delete $arg_for->{callbacks} ) {
+ while ( my ( $event, $callback ) = each %$cb ) {
+ $self->callback( $event, $callback );
+ }
+ }
+
+ return $self;
+}
+
+=head3 C<callback>
+
+Install a callback for a named event.
+
+=cut
+
+sub callback {
+ my ( $self, $event, $callback ) = @_;
+
+ my %ok_map = %{ $self->{ok_callbacks} };
+
+ $self->_croak('No callbacks may be installed')
+ unless %ok_map;
+
+ $self->_croak( "Callback $event is not supported. Valid callbacks are "
+ . join( ', ', sort keys %ok_map ) )
+ unless exists $ok_map{$event};
+
+ push @{ $self->{code_for}{$event} }, $callback;
+
+ return;
+}
+
+sub _has_callbacks {
+ my $self = shift;
+ return keys %{ $self->{code_for} } != 0;
+}
+
+sub _callback_for {
+ my ( $self, $event ) = @_;
+ return $self->{code_for}{$event};
+}
+
+sub _make_callback {
+ my $self = shift;
+ my $event = shift;
+
+ my $cb = $self->_callback_for($event);
+ return unless defined $cb;
+ return map { $_->(@_) } @$cb;
+}
+
+=head3 C<get_time>
+
+Return the current time using Time::HiRes if available.
+
+=cut
+
+sub get_time { return time() }
+
+=head3 C<time_is_hires>
+
+Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
+
+=cut
+
+sub time_is_hires { return GOT_TIME_HIRES }
+
+1;
--- /dev/null
+package TAP::Formatter::Base;
+
+use strict;
+use TAP::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+my $MAX_ERRORS = 5;
+my %VALIDATION_FOR;
+
+BEGIN {
+ @ISA = qw(TAP::Base);
+
+ %VALIDATION_FOR = (
+ directives => sub { shift; shift },
+ verbosity => sub { shift; shift },
+ normalize => sub { shift; shift },
+ timer => sub { shift; shift },
+ failures => sub { shift; shift },
+ comments => sub { shift; shift },
+ errors => sub { shift; shift },
+ color => sub { shift; shift },
+ jobs => sub { shift; shift },
+ show_count => sub { shift; shift },
+ stdout => sub {
+ my ( $self, $ref ) = @_;
+ $self->_croak("option 'stdout' needs a filehandle")
+ unless ( ref $ref || '' ) eq 'GLOB'
+ or eval { $ref->can('print') };
+ return $ref;
+ },
+ );
+
+ my @getter_setters = qw(
+ _longest
+ _printed_summary_header
+ _colorizer
+ );
+
+ __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
+}
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=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>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (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>, C<failures>, or C<comments>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> is not
+defined it will default to color output if color support is available on
+the current platform and output is not being redirected.
+
+=item * C<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+Called by Test::Harness before any test output is generated.
+
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ }
+
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";
+
+ if ( $self->timer ) {
+ my $stamp = $self->_format_now();
+ return "$stamp $name$periods";
+ }
+ else {
+ return "$name$periods";
+ }
+
+}
+
+=head3 C<open_test>
+
+Called to create a new test session. A test session looks like this:
+
+ my $session = $formatter->open_test( $test, $parser );
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+ $session->close_test;
+
+=cut
+
+sub open_test {
+ die "Unimplemented.";
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_output($msg);
+}
+
+=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_success("All tests successful.\n");
+ }
+
+ # ~TODO option where $aggregate->skipped generates reports
+ if ( $total != $passed or $aggregate->has_problems ) {
+ $self->_output("\nTest Summary Report");
+ $self->_output("\n-------------------\n");
+ foreach my $test (@$tests) {
+ $self->_printed_summary_header(0);
+ my ($parser) = $aggregate->parsers($test);
+ $self->_output_summary_failure(
+ 'failed',
+ [ ' Failed test: ', ' Failed tests: ' ],
+ $test, $parser
+ );
+ $self->_output_summary_failure(
+ 'todo_passed',
+ " TODO passed: ", $test, $parser
+ );
+
+ # ~TODO this cannot be the default
+ #$self->_output_summary_failure( 'skipped', " Tests skipped: " );
+
+ if ( my $exit = $parser->exit ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero exit status: $exit\n");
+ }
+ elsif ( my $wait = $parser->wait ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero wait status: $wait\n");
+ }
+
+ if ( my @errors = $parser->parse_errors ) {
+ my $explain;
+ if ( @errors > $MAX_ERRORS && !$self->errors ) {
+ $explain
+ = "Displayed the first $MAX_ERRORS of "
+ . scalar(@errors)
+ . " TAP syntax errors.\n"
+ . "Re-run prove with the -p option to see them all.\n";
+ splice @errors, $MAX_ERRORS;
+ }
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(
+ sprintf " Parse errors: %s\n",
+ shift @errors
+ );
+ foreach my $error (@errors) {
+ my $spaces = ' ' x 16;
+ $self->_failure_output("$spaces$error\n");
+ }
+ $self->_failure_output($explain) if $explain;
+ }
+ }
+ }
+ my $files = @$tests;
+ $self->_output("Files=$files, Tests=$total, $runtime\n");
+ my $status = $aggregate->get_status;
+ $self->_output("Result: $status\n");
+}
+
+sub _output_summary_failure {
+ my ( $self, $method, $name, $test, $parser ) = @_;
+
+ # ugly hack. Must rethink this :(
+ my $output = $method eq 'failed' ? '_failure_output' : '_output';
+
+ if ( my @r = $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ my ( $singular, $plural )
+ = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
+ $self->$output( @r == 1 ? $singular : $plural );
+ my @results = $self->_balanced_range( 40, @r );
+ $self->$output( sprintf "%s\n" => shift @results );
+ my $spaces = ' ' x 16;
+ while (@results) {
+ $self->$output( sprintf "$spaces%s\n" => shift @results );
+ }
+ }
+}
+
+sub _summary_test_header {
+ my ( $self, $test, $parser ) = @_;
+ return if $self->_printed_summary_header;
+ my $spaces = ' ' x ( $self->_longest - length $test );
+ $spaces = ' ' unless $spaces;
+ my $output = $self->_get_output_method($parser);
+ $self->$output(
+ sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
+ $parser->wait, $parser->tests_run, scalar $parser->failed
+ );
+ $self->_printed_summary_header(1);
+}
+
+sub _output {
+ my $self = shift;
+
+ print { $self->stdout } @_;
+}
+
+sub _failure_output {
+ my $self = shift;
+
+ $self->_output(@_);
+}
+
+sub _balanced_range {
+ my ( $self, $limit, @range ) = @_;
+ @range = $self->_range(@range);
+ my $line = "";
+ my @lines;
+ my $curr = 0;
+ while (@range) {
+ if ( $curr < $limit ) {
+ my $range = ( shift @range ) . ", ";
+ $line .= $range;
+ $curr += length $range;
+ }
+ elsif (@range) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ $line = '';
+ $curr = 0;
+ }
+ }
+ if ($line) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ }
+ return @lines;
+}
+
+sub _range {
+ my ( $self, @numbers ) = @_;
+
+ # shouldn't be needed, but subclasses might call this
+ @numbers = sort { $a <=> $b } @numbers;
+ my ( $min, @range );
+
+ foreach my $i ( 0 .. $#numbers ) {
+ my $num = $numbers[$i];
+ my $next = $numbers[ $i + 1 ];
+ if ( defined $next && $next == $num + 1 ) {
+ if ( !defined $min ) {
+ $min = $num;
+ }
+ }
+ elsif ( defined $min ) {
+ push @range => "$min-$num";
+ undef $min;
+ }
+ else {
+ push @range => $num;
+ }
+ }
+ return @range;
+}
+
+sub _get_output_method {
+ my ( $self, $parser ) = @_;
+ return $parser->has_problems ? '_failure_output' : '_output';
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Color;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+
+@ISA = qw(TAP::Object);
+
+my $NO_COLOR;
+
+BEGIN {
+ $NO_COLOR = 0;
+
+ if (IS_WIN32) {
+ eval 'use Win32::Console';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
+
+ # eval here because we might not know about these variables
+ my $fg = eval '$FG_LIGHTGRAY';
+ my $bg = eval '$BG_BLACK';
+
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+
+ my $var;
+ if ( $color eq 'reset' ) {
+ $fg = eval '$FG_LIGHTGRAY';
+ $bg = eval '$BG_BLACK';
+ }
+ elsif ( $color =~ /^on_(.+)$/ ) {
+ $bg = eval '$BG_' . uc($1);
+ }
+ else {
+ $fg = eval '$FG_' . uc($color);
+ }
+
+ # In case of colors that aren't defined
+ $self->set_color('reset')
+ unless defined $bg && defined $fg;
+
+ $console->Attr( $bg | $fg );
+ };
+ }
+ }
+ else {
+ eval 'use Term::ANSIColor';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+ $output->( color($color) );
+ };
+ }
+ }
+
+ if ($NO_COLOR) {
+ *set_color = sub { };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Color - Run Perl test scripts with color
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+Note that this harness is I<experimental>. You may not like the colors I've
+chosen and I haven't yet provided an easy way to override them.
+
+This test harness is the same as L<TAP::Harness>, but test results are output
+in color. Passing tests are printed in green. Failing tests are in red.
+Skipped tests are blue on a white background and TODO tests are printed in
+white.
+
+If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running
+under Windows) tests will be run without color.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Color;
+ my $harness = TAP::Formatter::Color->new( \%args );
+ $harness->runtests(@tests);
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor returns a new C<TAP::Formatter::Color> object. If
+L<Term::ANSIColor> is not installed, returns undef.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+
+ if ($NO_COLOR) {
+
+ # shorten that message a bit
+ ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
+ warn "Note: Cannot run tests in color: $error\n";
+ return; # abort object construction
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<can_color>
+
+ Test::Formatter::Color->can_color()
+
+Returns a boolean indicating whether or not this module can actually
+generate colored output. This will be false if it could not load the
+modules needed for the current platform.
+
+=cut
+
+sub can_color {
+ return !$NO_COLOR;
+}
+
+=head3 C<set_color>
+
+Set the output color.
+
+=cut
+
+1;
--- /dev/null
+package TAP::Formatter::Console;
+
+use strict;
+use TAP::Formatter::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $class
+ = $self->jobs > 1
+ ? 'TAP::Formatter::Console::ParallelSession'
+ : 'TAP::Formatter::Console::Session';
+
+ eval "require $class";
+ $self->_croak($@) if $@;
+
+ my $session = $class->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ show_count => $self->show_count,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+# Use _colorizer delegate to set output color. NOP if we have no delegate
+sub _set_colors {
+ my ( $self, @colors ) = @_;
+ if ( my $colorizer = $self->_colorizer ) {
+ my $output_func = $self->{_output_func} ||= sub {
+ $self->_output(@_);
+ };
+ $colorizer->set_color( $output_func, $_ ) for @colors;
+ }
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_set_colors('green');
+ $self->_output($msg);
+ $self->_set_colors('reset');
+}
+
+sub _failure_output {
+ my $self = shift;
+ $self->_set_colors('red');
+ my $out = join '', @_;
+ my $has_newline = chomp $out;
+ $self->_output($out);
+ $self->_set_colors('reset');
+ $self->_output($/)
+ if $has_newline;
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Console::ParallelSession;
+
+use strict;
+use File::Spec;
+use File::Path;
+use TAP::Formatter::Console::Session;
+use Carp;
+
+use constant WIDTH => 72; # Because Eric says
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Console::Session);
+
+my %shared;
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ $self->SUPER::_initialize($arg_for);
+ my $formatter = $self->formatter;
+
+ # Horrid bodge. This creates our shared context per harness. Maybe
+ # TAP::Harness should give us this?
+ my $context = $shared{$formatter} ||= $self->_create_shared_context;
+ push @{ $context->{active} }, $self;
+
+ return $self;
+}
+
+sub _create_shared_context {
+ my $self = shift;
+ return {
+ active => [],
+ tests => 0,
+ fails => 0,
+ };
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for L<TAP::Harness>
+when run with multiple L<TAP::Harness/jobs>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+Output test preamble
+
+=cut
+
+sub header {
+}
+
+sub _clear_ruler {
+ my $self = shift;
+ $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
+}
+
+my $now = 0;
+my $start;
+
+my $trailer = '... )===';
+my $chop_length = WIDTH - length $trailer;
+
+sub _output_ruler {
+ my ( $self, $refresh ) = @_;
+ my $new_now = time;
+ return if $new_now == $now and !$refresh;
+ $now = $new_now;
+ $start ||= $now;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $context = $shared{$formatter};
+
+ my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start;
+
+ foreach my $active ( @{ $context->{active} } ) {
+ my $parser = $active->parser;
+ my $tests = $parser->tests_run;
+ my $planned = $parser->tests_planned || '?';
+
+ $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests;
+ }
+ chop $ruler; # Remove a trailing space
+ $ruler .= ')===';
+
+ if ( length $ruler > WIDTH ) {
+ $ruler =~ s/(.{$chop_length}).*/$1$trailer/o;
+ }
+ else {
+ $ruler .= '=' x ( WIDTH - length($ruler) );
+ }
+ $formatter->_output("\r$ruler");
+}
+
+=head3 C<result>
+
+ Called by the harness for each line of TAP it receives .
+
+=cut
+
+sub result {
+ my ( $self, $result ) = @_;
+ my $formatter = $self->formatter;
+
+ # my $really_quiet = $formatter->really_quiet;
+ # my $show_count = $self->_should_show_count;
+
+ if ( $result->is_test ) {
+ my $context = $shared{$formatter};
+ $context->{tests}++;
+
+ my $active = $context->{active};
+ if ( @$active == 1 ) {
+
+ # There is only one test, so use the serial output format.
+ return $self->SUPER::result($result);
+ }
+
+ $self->_output_ruler( $self->parser->tests_run == 1 );
+ }
+ elsif ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+}
+
+=head3 C<clear_for_close>
+
+=cut
+
+sub clear_for_close {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+ my $context = $shared{$formatter};
+ if ( @{ $context->{active} } == 1 ) {
+ $self->SUPER::clear_for_close;
+ }
+ else {
+ $self->_clear_ruler;
+ }
+}
+
+=head3 C<close_test>
+
+=cut
+
+sub close_test {
+ my $self = shift;
+ my $name = $self->name;
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ $self->SUPER::close_test;
+
+ my $active = $context->{active};
+
+ my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
+
+ die "Can't find myself" unless @pos;
+ splice @$active, $pos[0], 1;
+
+ if ( @$active > 1 ) {
+ $self->_output_ruler(1);
+ }
+ elsif ( @$active == 1 ) {
+
+ # Print out "test/name.t ...."
+ $active->[0]->SUPER::header;
+ }
+ else {
+
+ # $self->formatter->_output("\n");
+ delete $shared{$formatter};
+ }
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Console::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+my @ACCESSOR;
+
+BEGIN {
+ my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
+
+ for my $method (@CLOSURE_BINDING) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return ( $self->{_closures} ||= $self->_closures )->{$method}
+ ->(@_);
+ };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::Session - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=cut
+
+sub _get_output_result {
+ my $self = shift;
+
+ my @color_map = (
+ { test => sub { $_->is_test && !$_->is_ok },
+ colors => ['red'],
+ },
+ { test => sub { $_->is_test && $_->has_skip },
+ colors => [
+ 'white',
+ 'on_blue'
+ ],
+ },
+ { test => sub { $_->is_test && $_->has_todo },
+ colors => ['yellow'],
+ },
+ );
+
+ my $formatter = $self->formatter;
+ my $parser = $self->parser;
+
+ return $formatter->_colorizer
+ ? sub {
+ my $result = shift;
+ for my $col (@color_map) {
+ local $_ = $result;
+ if ( $col->{test}->() ) {
+ $formatter->_set_colors( @{ $col->{colors} } );
+ last;
+ }
+ }
+ $formatter->_output( $self->_format_for_output($result) );
+ $formatter->_set_colors('reset');
+ }
+ : sub {
+ $formatter->_output( $self->_format_for_output(shift) );
+ };
+}
+
+sub _closures {
+ my $self = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+ my $show_count = $self->show_count;
+
+ my $really_quiet = $formatter->really_quiet;
+ my $quiet = $formatter->quiet;
+ my $verbose = $formatter->verbose;
+ my $directives = $formatter->directives;
+ my $failures = $formatter->failures;
+ my $comments = $formatter->comments;
+
+ my $output_result = $self->_get_output_result;
+
+ my $output = '_output';
+ my $plan = '';
+ my $newline_printed = 0;
+
+ my $last_status_printed = 0;
+
+ return {
+ header => sub {
+ $formatter->_output($pretty)
+ unless $really_quiet;
+ },
+
+ result => sub {
+ my $result = shift;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ return if $really_quiet;
+
+ my $is_test = $result->is_test;
+
+ # These are used in close_test - but only if $really_quiet
+ # is false - so it's safe to only set them here unless that
+ # relationship changes.
+
+ if ( !$plan ) {
+ my $planned = $parser->tests_planned || '?';
+ $plan = "/$planned ";
+ }
+ $output = $formatter->_get_output_method($parser);
+
+ if ( $show_count and $is_test ) {
+ my $number = $result->number;
+ my $now = CORE::time;
+
+ # Print status roughly once per second.
+ # We will always get the first number as a side effect of
+ # $last_status_printed starting with the value 0, which $now
+ # will never be. (Unless someone sets their clock to 1970)
+ if ( $last_status_printed != $now ) {
+ $formatter->$output("\r$pretty$number$plan");
+ $last_status_printed = $now;
+ }
+ }
+
+ if (!$quiet
+ && ( $verbose
+ || ( $is_test && $failures && !$result->is_ok )
+ || ( $comments && $result->is_comment )
+ || ( $directives && $result->has_directive ) )
+ )
+ {
+ unless ($newline_printed) {
+ $formatter->_output("\n");
+ $newline_printed = 1;
+ }
+ $output_result->($result);
+ $formatter->_output("\n");
+ }
+ },
+
+ clear_for_close => sub {
+ my $spaces
+ = ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
+ $formatter->$output("\r$spaces");
+ },
+
+ close_test => sub {
+ if ( $show_count && !$really_quiet ) {
+ $self->clear_for_close;
+ $formatter->$output("\r$pretty");
+ }
+
+ # Avoid circular references
+ $self->parser(undef);
+ $self->{_closures} = {};
+
+ return if $really_quiet;
+
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output("skipped: $skip_all\n");
+ }
+ elsif ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output("ok$time_report\n");
+ }
+ },
+ };
+}
+
+=head2 C<< clear_for_close >>
+
+=head2 C<< close_test >>
+
+=head2 C<< header >>
+
+=head2 C<< result >>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Formatter::File;
+
+use strict;
+use TAP::Formatter::Base ();
+use TAP::Formatter::File::Session;
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::File - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::File;
+ my $harness = TAP::Formatter::File->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $session = TAP::Formatter::File::Session->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+sub _should_show_count {
+ return 0;
+}
+
+1;
--- /dev/null
+package TAP::Formatter::File::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+=head1 NAME
+
+TAP::Formatter::File::Session - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for L<TAP::Harness>.
+It is particularly important when running with parallel tests, as it
+ensures that test results are not interleaved, even when run
+verbosely.
+
+=cut
+
+=head1 METHODS
+
+=head2 result
+
+Stores results for later output, all together.
+
+=cut
+
+sub result {
+ my $self = shift;
+ my $result = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ return;
+ }
+
+ if (!$formatter->quiet
+ && ( $formatter->verbose
+ || ( $result->is_test && $formatter->failures && !$result->is_ok )
+ || ( $formatter->comments && $result->is_comment )
+ || ( $result->has_directive && $formatter->directives ) )
+ )
+ {
+ $self->{results} .= $self->_format_for_output($result) . "\n";
+ }
+}
+
+=head2 close_test
+
+When the test file finishes, outputs the summary, together.
+
+=cut
+
+sub close_test {
+ my $self = shift;
+
+ # Avoid circular references
+ $self->parser(undef);
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+
+ return if $formatter->really_quiet;
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output( $pretty . "skipped: $skip_all\n" );
+ }
+ elsif ( $parser->has_problems ) {
+ $formatter->_output(
+ $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) );
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output( $pretty
+ . ( $self->{results} ? "\n" . $self->{results} : "" )
+ . "ok$time_report\n" );
+ }
+}
+
+1;
--- /dev/null
+package TAP::Formatter::Session;
+
+use strict;
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+my @ACCESSOR;
+
+BEGIN {
+
+ @ACCESSOR = qw( name formatter parser show_count );
+
+ for my $method (@ACCESSOR) {
+ no strict 'refs';
+ *$method = sub { shift->{$method} };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Session - Abstract base class for harness output delegate
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=item * C<show_count>
+
+=back
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name (@ACCESSOR) {
+ $self->{$name} = delete $arg_for{$name};
+ }
+
+ if ( !defined $self->show_count ) {
+ $self->{show_count} = 1; # defaults to true
+ }
+ if ( $self->show_count ) { # but may be a damned lie!
+ $self->{show_count} = $self->_should_show_count;
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ return $self;
+}
+
+=head3 C<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+Called to close a test session.
+
+=head3 C<clear_for_close>
+
+Called by C<close_test> to clear the line showing test progress, or the parallel
+test ruler, prior to printing the final test result.
+
+=cut
+
+sub header { }
+
+sub result { }
+
+sub close_test { }
+
+sub clear_for_close { }
+
+sub _should_show_count {
+ my $self = shift;
+ return
+ !$self->formatter->verbose
+ && -t $self->formatter->stdout
+ && !$ENV{HARNESS_NOTTY};
+}
+
+sub _format_for_output {
+ my ( $self, $result ) = @_;
+ return $self->formatter->normalize ? $result->as_string : $result->raw;
+}
+
+sub _output_test_failure {
+ my ( $self, $parser ) = @_;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $tests_run = $parser->tests_run;
+ my $tests_planned = $parser->tests_planned;
+
+ my $total
+ = defined $tests_planned
+ ? $tests_planned
+ : $tests_run;
+
+ my $passed = $parser->passed;
+
+ # The total number of fails includes any tests that were planned but
+ # didn't run
+ my $failed = $parser->failed + $total - $tests_run;
+ my $exit = $parser->exit;
+
+ if ( my $exit = $parser->exit ) {
+ my $wstat = $parser->wait;
+ my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
+ $formatter->_failure_output("Dubious, test returned $status\n");
+ }
+
+ if ( $failed == 0 ) {
+ $formatter->_failure_output(
+ $total
+ ? "All $total subtests passed "
+ : 'No subtests run '
+ );
+ }
+ else {
+ $formatter->_failure_output("Failed $failed/$total subtests ");
+ if ( !$total ) {
+ $formatter->_failure_output("\nNo tests run!");
+ }
+ }
+
+ if ( my $skipped = $parser->skipped ) {
+ $passed -= $skipped;
+ my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
+ $formatter->_output(
+ "\n\t(less $skipped skipped $test: $passed okay)");
+ }
+
+ if ( my $failed = $parser->todo_passed ) {
+ my $test = $failed > 1 ? 'tests' : 'test';
+ $formatter->_output(
+ "\n\t($failed TODO $test unexpectedly succeeded)");
+ }
+
+ $formatter->_output("\n");
+}
+
+1;
--- /dev/null
+package TAP::Harness;
+
+use strict;
+use Carp;
+
+use File::Spec;
+use File::Path;
+use IO::Handle;
+
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run test scripts with statistics
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+$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 comments errors stdout color
+ show_count normalize
+ );
+
+ %VALIDATION_FOR = (
+ lib => sub {
+ my ( $self, $libs ) = @_;
+ $libs = [$libs] unless 'ARRAY' eq ref $libs;
+
+ return [ map {"-I$_"} @$libs ];
+ },
+ switches => sub { shift; shift },
+ exec => sub { shift; shift },
+ merge => sub { shift; shift },
+ aggregator_class => sub { shift; shift },
+ formatter_class => sub { shift; shift },
+ multiplexer_class => sub { shift; shift },
+ parser_class => sub { shift; shift },
+ scheduler_class => sub { shift; shift },
+ formatter => sub { shift; shift },
+ jobs => sub { shift; shift },
+ test_args => sub { shift; shift },
+ ignore_exit => sub { shift; shift },
+ rules => sub { shift; shift },
+ );
+
+ for my $method ( sort keys %VALIDATION_FOR ) {
+ no strict 'refs';
+ if ( $method eq 'lib' || $method eq 'switches' ) {
+ *{$method} = sub {
+ my $self = shift;
+ unless (@_) {
+ $self->{$method} ||= [];
+ return wantarray
+ ? @{ $self->{$method} }
+ : $self->{$method};
+ }
+ $self->_croak("Too many arguments to method '$method'")
+ if @_ > 1;
+ my $args = shift;
+ $args = [$args] unless ref $args;
+ $self->{$method} = $args;
+ return $self;
+ };
+ }
+ else {
+ *{$method} = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+
+ for my $method (@FORMATTER_ARGS) {
+ no strict 'refs';
+ *{$method} = sub {
+ my $self = shift;
+ return $self->formatter->$method(@_);
+ };
+ }
+}
+
+##############################################################################
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbosity => 1,
+ lib => [ 'lib', 'blib/lib', 'blib/arch' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an
+optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level:
+
+ 1 verbose Print individual test results to STDOUT.
+ 0 normal
+ -1 quiet Suppress some test output (mostly failures
+ while tests are running).
+ -2 really quiet Suppress everything but the tests summary.
+ -3 silent Suppress everything.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if
+available.
+
+=item * C<failures>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (this is a no-op if C<verbose> is selected).
+
+=item * C<show_count>
+
+Update the running test count during testing.
+
+=item * C<normalize>
+
+Set to a true value to normalize the TAP that is emitted in verbose modes.
+
+=item * C<lib>
+
+Accepts a scalar value or array ref of scalar values indicating which
+paths to allowed libraries should be included if Perl tests are
+executed. Naturally, this only makes sense in the context of tests
+written in Perl.
+
+=item * C<switches>
+
+Accepts a scalar value or array ref of scalar values indicating which
+switches should be included if Perl tests are executed. Naturally, this
+only makes sense in the context of tests written in Perl.
+
+=item * C<test_args>
+
+A reference to an C<@INC> style array of arguments to be passed to each
+test program.
+
+=item * C<color>
+
+Attempt to produce color output.
+
+=item * C<exec>
+
+Typically, Perl tests are run through this. However, anything which
+spits out TAP is fine. You can use this argument to specify the name of
+the program (and optional switches) to run your tests with:
+
+ exec => ['/usr/bin/ruby', '-w']
+
+You can also pass a subroutine reference in order to determine and
+return the proper program to run based on a given test script. The
+subroutine reference should expect the TAP::Harness object itself as the
+first argument, and the file name as the second argument. It should
+return an array reference containing the command to be run and including
+the test file name. It can also simply return C<undef>, in which case
+TAP::Harness will fall back on executing the test script in Perl:
+
+ exec => sub {
+ my ( $harness, $test_file ) = @_;
+
+ # Let Perl tests run.
+ return undef if $test_file =~ /[.]t$/;
+ return [ qw( /usr/bin/ruby -w ), $test_file ]
+ if $test_file =~ /[.]rb$/;
+ }
+
+If the subroutine returns a scalar with a newline or a filehandle, it
+will be interpreted as raw TAP or as a TAP stream, respectively.
+
+=item * C<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<aggregator_class>
+
+The name of the class to use to aggregate test results. The default is
+L<TAP::Parser::Aggregator>.
+
+=item * C<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
+isn't a TTY.
+
+=item * C<multiplexer_class>
+
+The name of the class to use to multiplex tests during parallel testing.
+The default is L<TAP::Parser::Multiplexer>.
+
+=item * C<parser_class>
+
+The name of the class to use to parse TAP. The default is
+L<TAP::Parser>.
+
+=item * C<scheduler_class>
+
+The name of the class to use to schedule test execution. The default is
+L<TAP::Parser::Scheduler>.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting the
+TAP output. See L<TAP::Formatter::Console> for an example.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be
+made in the summary report. To see all of the parse errors, set this
+argument to true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be
+displayed. This overrides other settings such as C<verbose> or
+C<failures>.
+
+=item * C<ignore_exit>
+
+If set to a true value instruct C<TAP::Parser> to ignore exit and wait
+status from test scripts.
+
+=item * C<jobs>
+
+The maximum number of parallel tests to run at any time. Which tests
+can be run in parallel is controlled by C<rules>. The default is to
+run only one test at a time.
+
+=item * C<rules>
+
+A reference to a hash of rules that control which tests may be
+executed in parallel. This is an experimental feature and the
+interface may change.
+
+ $harness->rules(
+ { par => [
+ { seq => '../ext/DB_File/t/*' },
+ { seq => '../ext/IO_Compress_Zlib/t/*' },
+ { seq => '../lib/CPANPLUS/*' },
+ { seq => '../lib/ExtUtils/t/*' },
+ '*'
+ ]
+ }
+ );
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+{
+ my @legal_callback = qw(
+ parser_args
+ made_parser
+ before_runtests
+ after_runtests
+ after_test
+ );
+
+ my %default_class = (
+ aggregator_class => 'TAP::Parser::Aggregator',
+ formatter_class => 'TAP::Formatter::Console',
+ multiplexer_class => 'TAP::Parser::Multiplexer',
+ parser_class => 'TAP::Parser',
+ scheduler_class => 'TAP::Parser::Scheduler',
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name ( sort keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+
+ my $value = $self->$validate($property);
+ if ( $self->_error ) {
+ $self->_croak;
+ }
+ $self->$name($value);
+ }
+ }
+
+ $self->jobs(1) unless defined $self->jobs;
+
+ local $default_class{formatter_class} = 'TAP::Formatter::File'
+ unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY};
+
+ while ( my ( $attr, $class ) = each %default_class ) {
+ $self->$attr( $self->$attr() || $class );
+ }
+
+ unless ( $self->formatter ) {
+
+ # This is a little bodge to preserve legacy behaviour. It's
+ # pretty horrible that we know which args are destined for
+ # the formatter.
+ my %formatter_args = ( jobs => $self->jobs );
+ for my $name (@FORMATTER_ARGS) {
+ if ( defined( my $property = delete $arg_for{$name} ) ) {
+ $formatter_args{$name} = $property;
+ }
+ }
+
+ $self->formatter(
+ $self->_construct( $self->formatter_class, \%formatter_args )
+ );
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+
+ return $self;
+ }
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<runtests>
+
+ $harness->runtests(@tests);
+
+Accepts and array of C<@tests> to be run. This should generally be the
+names of test files, but this is not required. Each element in C<@tests>
+will be passed to C<TAP::Parser::new()> as a C<source>. See
+L<TAP::Parser> for more information.
+
+It is possible to provide aliases that will be displayed in place of the
+test name by supplying the test as a reference to an array containing
+C<< [ $test, $alias ] >>:
+
+ $harness->runtests( [ 't/foo.t', 'Foo Once' ],
+ [ 't/foo.t', 'Foo Twice' ] );
+
+Normally it is an error to attempt to run the same test twice. Aliases
+allow you to overcome this limitation by giving each run of the test a
+unique name.
+
+Tests will be run in the order found.
+
+If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
+should name a directory into which a copy of the raw TAP for each test
+will be written. TAP is written to files named for each test.
+Subdirectories will be created as needed.
+
+Returns a L<TAP::Parser::Aggregator> containing the test results.
+
+=cut
+
+sub runtests {
+ my ( $self, @tests ) = @_;
+
+ my $aggregate = $self->_construct( $self->aggregator_class );
+
+ $self->_make_callback( 'before_runtests', $aggregate );
+ $aggregate->start;
+ $self->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop;
+ $self->summary($aggregate);
+ $self->_make_callback( 'after_runtests', $aggregate );
+
+ return $aggregate;
+}
+
+=head3 C<summary>
+
+Output the summary for a TAP::Parser::Aggregator.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+ $self->formatter->summary($aggregate);
+}
+
+sub _after_test {
+ my ( $self, $aggregate, $job, $parser ) = @_;
+
+ $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
+ $aggregate->add( $job->description, $parser );
+}
+
+sub _bailout {
+ my ( $self, $result ) = @_;
+ my $explanation = $result->explanation;
+ die "FAILED--Further testing stopped"
+ . ( $explanation ? ": $explanation\n" : ".\n" );
+}
+
+sub _aggregate_parallel {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ my $jobs = $self->jobs;
+ my $mux = $self->_construct( $self->multiplexer_class );
+
+ RESULT: {
+
+ # Keep multiplexer topped up
+ FILL:
+ while ( $mux->parsers < $jobs ) {
+ my $job = $scheduler->get_job;
+
+ # If we hit a spinner stop filling and start running.
+ last FILL if !defined $job || $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+ $mux->add( $parser, [ $session, $job ] );
+ }
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ my ( $session, $job ) = @$stash;
+ if ( defined $result ) {
+ $session->result($result);
+ $self->_bailout($result) if $result->is_bailout;
+ }
+ else {
+
+ # End of parser. Automatically removed from the mux.
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+ redo RESULT;
+ }
+ }
+
+ return;
+}
+
+sub _aggregate_single {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ JOB:
+ while ( my $job = $scheduler->get_job ) {
+ next JOB if $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ if ( $result->is_bailout ) {
+
+ # Keep reading until input is exhausted in the hope
+ # of allowing any pending diagnostics to show up.
+ 1 while $parser->next;
+ $self->_bailout($result);
+ }
+ }
+
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+
+ return;
+}
+
+=head3 C<aggregate_tests>
+
+ $harness->aggregate_tests( $aggregate, @tests );
+
+Run the named tests and display a summary of result. Tests will be run
+in the order found.
+
+Test results will be added to the supplied L<TAP::Parser::Aggregator>.
+C<aggregate_tests> may be called multiple times to run several sets of
+tests. Multiple C<Test::Harness> instances may be used to pass results
+to a single aggregator so that different parts of a complex test suite
+may be run using different C<TAP::Harness> settings. This is useful, for
+example, in the case where some tests should run in parallel but others
+are unsuitable for parallel execution.
+
+ my $formatter = TAP::Formatter::Console->new;
+ my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
+ my $par_harness = TAP::Harness->new(
+ { formatter => $formatter,
+ jobs => 9
+ }
+ );
+ my $aggregator = TAP::Parser::Aggregator->new;
+
+ $aggregator->start();
+ $ser_harness->aggregate_tests( $aggregator, @ser_tests );
+ $par_harness->aggregate_tests( $aggregator, @par_tests );
+ $aggregator->stop();
+ $formatter->summary($aggregator);
+
+Note that for simpler testing requirements it will often be possible to
+replace the above code with a single call to C<runtests>.
+
+Each elements of the @tests array is either
+
+=over
+
+=item * the file name of a test script to run
+
+=item * a reference to a [ file name, display name ] array
+
+=back
+
+When you supply a separate display name it becomes possible to run a
+test more than once; the display name is effectively the alias by which
+the test is known inside the harness. The harness doesn't care if it
+runs the same script more than once when each invocation uses a
+different name.
+
+=cut
+
+sub aggregate_tests {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $jobs = $self->jobs;
+ my $scheduler = $self->make_scheduler(@tests);
+
+ # #12458
+ local $ENV{HARNESS_IS_VERBOSE} = 1
+ if $self->formatter->verbosity > 0;
+
+ # Formatter gets only names.
+ $self->formatter->prepare( map { $_->description } $scheduler->get_all );
+
+ if ( $self->jobs > 1 ) {
+ $self->_aggregate_parallel( $aggregate, $scheduler );
+ }
+ else {
+ $self->_aggregate_single( $aggregate, $scheduler );
+ }
+
+ return;
+}
+
+sub _add_descriptions {
+ my $self = shift;
+
+ # Turn unwrapped scalars into anonymous arrays and copy the name as
+ # the description for tests that have only a name.
+ return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ }
+ map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
+}
+
+=head3 C<make_scheduler>
+
+Called by the harness when it needs to create a
+L<TAP::Parser::Scheduler>. Override in a subclass to provide an
+alternative scheduler. C<make_scheduler> is passed the list of tests
+that was passed to C<aggregate_tests>.
+
+=cut
+
+sub make_scheduler {
+ my ( $self, @tests ) = @_;
+ return $self->_construct(
+ $self->scheduler_class,
+ tests => [ $self->_add_descriptions(@tests) ],
+ rules => $self->rules
+ );
+}
+
+=head3 C<jobs>
+
+Gets or sets the number of concurrent test runs the harness is
+handling. By default, this value is 1 -- for parallel testing, this
+should be set higher.
+
+=cut
+
+##############################################################################
+
+=head1 SUBCLASSING
+
+C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
+don't like how a particular feature functions, just override the
+desired methods.
+
+=head2 Methods
+
+TODO: This is out of date
+
+The following methods are ones you may wish to override if you want to
+subclass C<TAP::Harness>.
+
+=head3 C<summary>
+
+ $harness->summary( \%args );
+
+C<summary> prints the summary report after all tests are run. The
+argument is a hashref with the following keys:
+
+=over 4
+
+=item * C<start>
+
+This is created with C<< Benchmark->new >> and it the time the tests
+started. You can print a useful summary time, if desired, with:
+
+ $self->output(
+ timestr( timediff( Benchmark->new, $start_time ), 'nop' ) );
+
+=item * C<tests>
+
+This is an array reference of all test names. To get the L<TAP::Parser>
+object for individual tests:
+
+ my $aggregate = $args->{aggregate};
+ my $tests = $args->{tests};
+
+ for my $name ( @$tests ) {
+ my ($parser) = $aggregate->parsers($test);
+ ... do something with $parser
+ }
+
+This is a bit clunky and will be cleaned up in a later release.
+
+=back
+
+=cut
+
+sub _get_parser_args {
+ my ( $self, $job ) = @_;
+ my $test_prog = $job->filename;
+ my %args = ();
+ my @switches;
+ @switches = $self->lib if $self->lib;
+ push @switches => $self->switches if $self->switches;
+ $args{switches} = \@switches;
+ $args{spool} = $self->_open_spool($test_prog);
+ $args{merge} = $self->merge;
+ $args{ignore_exit} = $self->ignore_exit;
+
+ if ( my $exec = $self->exec ) {
+ $args{exec}
+ = ref $exec eq 'CODE'
+ ? $exec->( $self, $test_prog )
+ : [ @$exec, $test_prog ];
+ if ( not defined $args{exec} ) {
+ $args{source} = $test_prog;
+ }
+ elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) {
+ $args{source} = delete $args{exec};
+ }
+ }
+ else {
+ $args{source} = $test_prog;
+ }
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ return \%args;
+}
+
+=head3 C<make_parser>
+
+Make a new parser and display formatter session. Typically used and/or
+overridden in subclasses.
+
+ my ( $parser, $session ) = $harness->make_parser;
+
+=cut
+
+sub make_parser {
+ my ( $self, $job ) = @_;
+
+ my $args = $self->_get_parser_args($job);
+ $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
+ my $parser = $self->_construct( $self->parser_class, $args );
+
+ $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
+ my $session = $self->formatter->open_test( $job->description, $parser );
+
+ return ( $parser, $session );
+}
+
+=head3 C<finish_parser>
+
+Terminate use of a parser. Typically used and/or overridden in
+subclasses. The parser isn't destroyed as a result of this.
+
+=cut
+
+sub finish_parser {
+ my ( $self, $parser, $session ) = @_;
+
+ $session->close_test;
+ $self->_close_spool($parser);
+
+ return $parser;
+}
+
+sub _open_spool {
+ my $self = shift;
+ my $test = shift;
+
+ if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
+
+ my $spool = File::Spec->catfile( $spool_dir, $test );
+
+ # Make the directory
+ my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
+ my $path = File::Spec->catpath( $vol, $dir, '' );
+ eval { mkpath($path) };
+ $self->_croak($@) if $@;
+
+ my $spool_handle = IO::Handle->new;
+ open( $spool_handle, ">$spool" )
+ or $self->_croak(" Can't write $spool ( $! ) ");
+
+ return $spool_handle;
+ }
+
+ return;
+}
+
+sub _close_spool {
+ my $self = shift;
+ my ($parser) = @_;
+
+ if ( my $spool_handle = $parser->delete_spool ) {
+ close($spool_handle)
+ or $self->_croak(" Error closing TAP spool file( $! ) \n ");
+ }
+
+ return;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ unless ($message) {
+ $message = $self->_error;
+ }
+ $self->SUPER::_croak($message);
+
+ return;
+}
+
+=head1 REPLACING
+
+If you like the C<prove> utility and L<TAP::Parser> but you want your
+own harness, all you need to do is write one and provide C<new> and
+C<runtests> methods. Then you can use the C<prove> utility like so:
+
+ prove --harness My::Test::Harness
+
+Note that while C<prove> accepts a list of tests (or things to be
+tested), C<new> has a fairly rich set of arguments. You'll probably want
+to read over this code carefully to see how all of them are being used.
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+package TAP::Object;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Object - Base class that provides common functionality to all C<TAP::*> modules
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use strict;
+ use vars qw(@ISA);
+
+ use TAP::Object;
+
+ @ISA = qw(TAP::Object);
+
+ # new() implementation by TAP::Object
+ sub _initialize {
+ my ( $self, @args) = @_;
+ # initialize your object
+ return $self;
+ }
+
+ # ... later ...
+ my $obj = TAP::Whatever->new(@args);
+
+=head1 DESCRIPTION
+
+C<TAP::Object> provides a default constructor and exception model for all
+C<TAP::*> classes. Exceptions are raised using L<Carp>.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new object. Any arguments passed to C<new> will be passed on to the
+L</_initialize> method. Returns a new object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->_initialize(@_);
+}
+
+=head2 Instance Methods
+
+=head3 C<_initialize>
+
+Initializes a new object. This method is a stub by default, you should override
+it as appropriate.
+
+I<Note:> L</new> expects you to return C<$self> or raise an exception. See
+L</_croak>, and L<Carp>.
+
+=cut
+
+sub _initialize {
+ return $_[0];
+}
+
+=head3 C<_croak>
+
+Raise an exception using C<croak> from L<Carp>, eg:
+
+ $self->_croak( 'why me?', 'aaarrgh!' );
+
+May also be called as a I<class> method.
+
+ $class->_croak( 'this works too' );
+
+=cut
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+ return;
+}
+
+=head3 C<_construct>
+
+Create a new instance of the specified class.
+
+=cut
+
+sub _construct {
+ my ( $self, $class, @args ) = @_;
+
+ $self->_croak("Bad module name $class")
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ unless ( $class->can('new') ) {
+ local $@;
+ eval "require $class";
+ $self->_croak("Can't load $class") if $@;
+ }
+
+ return $class->new(@args);
+}
+
+=head3 C<mk_methods>
+
+Create simple getter/setters.
+
+ __PACKAGE__->mk_methods(@method_names);
+
+=cut
+
+sub mk_methods {
+ my ( $class, @methods ) = @_;
+ foreach my $method_name (@methods) {
+ my $method = "${class}::$method_name";
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method_name} = shift if @_;
+ return $self->{$method_name};
+ };
+ }
+}
+
+1;
+
--- /dev/null
+package TAP::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Base ();
+use TAP::Parser::Grammar ();
+use TAP::Parser::Result ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::Source ();
+use TAP::Parser::Source::Perl ();
+use TAP::Parser::Iterator ();
+use TAP::Parser::IteratorFactory ();
+
+use Carp qw( confess );
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+my $DEFAULT_TAP_VERSION = 12;
+my $MAX_TAP_VERSION = 13;
+
+$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{TAP_VERSION};
+}
+
+BEGIN { # making accessors
+ @ISA = qw(TAP::Base);
+
+ __PACKAGE__->mk_methods(
+ qw(
+ _stream
+ _spool
+ exec
+ exit
+ is_good_plan
+ plan
+ tests_planned
+ tests_run
+ wait
+ version
+ in_todo
+ start_time
+ end_time
+ skip_all
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ )
+ );
+} # done making accessors
+
+=head1 SYNOPSIS
+
+ use TAP::Parser;
+
+ my $parser = TAP::Parser->new( { source => $source } );
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser> is designed to produce a proper parse of TAP output. For
+an example of how to run tests through this module, see the simple
+harnesses C<examples/>.
+
+There's a wiki dedicated to the Test Anything Protocol:
+
+L<http://testanything.org>
+
+It includes the TAP::Parser Cookbook:
+
+L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $parser = TAP::Parser->new(\%args);
+
+Returns a new C<TAP::Parser> object.
+
+The arguments should be a hashref with I<one> of the following keys:
+
+=over 4
+
+=item * C<source>
+
+This is the preferred method of passing arguments to the constructor. To
+determine how to handle the source, the following steps are taken.
+
+If the source contains a newline, it's assumed to be a string of raw TAP
+output.
+
+If the source is a reference, it's assumed to be something to pass to
+the L<TAP::Parser::Iterator::Stream> constructor. This is used
+internally and you should not use it.
+
+Otherwise, the parser does a C<-e> check to see if the source exists. If so,
+it attempts to execute the source and read the output as a stream. This is by
+far the preferred method of using the parser.
+
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new( { source => $file } );
+ # do stuff with the parser
+ }
+
+=item * C<tap>
+
+The value should be the complete TAP output.
+
+=item * C<exec>
+
+If passed an array reference, will attempt to create the iterator by
+passing a L<TAP::Parser::Source> object to
+L<TAP::Parser::Iterator::Source>, using the array reference strings as
+the command arguments to L<IPC::Open3::open3|IPC::Open3>:
+
+ exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
+
+Note that C<source> and C<exec> are mutually exclusive.
+
+=back
+
+The following keys are optional.
+
+=over 4
+
+=item * C<callback>
+
+If present, each callback corresponding to a given result type will be called
+with the result as the argument if the C<run> method is used:
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+=item * C<switches>
+
+If using a Perl file as a source, optional switches may be passed which will
+be used when invoking the perl executable.
+
+ my $parser = TAP::Parser->new( {
+ source => $test_file,
+ switches => '-Ilib',
+ } );
+
+=item * C<test_args>
+
+Used in conjunction with the C<source> option to supply a reference to
+an C<@ARGV> style array of arguments to pass to the test program.
+
+=item * C<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+If false, STDERR is not captured (though it is 'relayed' to keep it
+somewhat synchronized with STDOUT.)
+
+If true, STDERR and STDOUT are the same filehandle. This may cause
+breakage if STDERR contains anything resembling TAP format, but does
+allow exact synchronization.
+
+Subtleties of this behavior may be platform-dependent and may change in
+the future.
+
+=item * C<source_class>
+
+This option was introduced to let you easily customize which I<source> class
+the parser should use. It defaults to L<TAP::Parser::Source>.
+
+See also L</make_source>.
+
+=item * C<perl_source_class>
+
+This option was introduced to let you easily customize which I<perl source>
+class the parser should use. It defaults to L<TAP::Parser::Source::Perl>.
+
+See also L</make_perl_source>.
+
+=item * C<grammar_class>
+
+This option was introduced to let you easily customize which I<grammar> class
+the parser should use. It defaults to L<TAP::Parser::Grammar>.
+
+See also L</make_grammar>.
+
+=item * C<iterator_factory_class>
+
+This option was introduced to let you easily customize which I<iterator>
+factory class the parser should use. It defaults to
+L<TAP::Parser::IteratorFactory>.
+
+See also L</make_iterator>.
+
+=item * C<result_factory_class>
+
+This option was introduced to let you easily customize which I<result>
+factory class the parser should use. It defaults to
+L<TAP::Parser::ResultFactory>.
+
+See also L</make_result>.
+
+=back
+
+=cut
+
+# new() implementation supplied by TAP::Base
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub _default_source_class {'TAP::Parser::Source'}
+sub _default_perl_source_class {'TAP::Parser::Source::Perl'}
+sub _default_grammar_class {'TAP::Parser::Grammar'}
+sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
+sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ my $parser = TAP::Parser->new( { source => $file } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This method returns the results of the parsing, one result at a time. Note
+that it is destructive. You can't rewind and examine previous results.
+
+If callbacks are used, they will be issued before this call returns.
+
+Each result returned is a subclass of L<TAP::Parser::Result>. See that
+module and related classes for more information on how to use them.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+##############################################################################
+
+=head3 C<run>
+
+ $parser->run;
+
+This method merely runs the parser and parses all of the TAP.
+
+=cut
+
+sub run {
+ my $self = shift;
+ while ( defined( my $result = $self->next ) ) {
+
+ # do nothing
+ }
+}
+
+##############################################################################
+
+=head3 C<make_source>
+
+Make a new L<TAP::Parser::Source> object and return it. Passes through any
+arguments given.
+
+The C<source_class> can be customized, as described in L</new>.
+
+=head3 C<make_perl_source>
+
+Make a new L<TAP::Parser::Source::Perl> object and return it. Passes through
+any arguments given.
+
+The C<perl_source_class> can be customized, as described in L</new>.
+
+=head3 C<make_grammar>
+
+Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
+arguments given.
+
+The C<grammar_class> can be customized, as described in L</new>.
+
+=head3 C<make_iterator>
+
+Make a new L<TAP::Parser::Iterator> object using the parser's
+L<TAP::Parser::IteratorFactory>, and return it. Passes through any arguments
+given.
+
+The C<iterator_factory_class> can be customized, as described in L</new>.
+
+=head3 C<make_result>
+
+Make a new L<TAP::Parser::Result> object using the parser's
+L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments
+given.
+
+The C<result_factory_class> can be customized, as described in L</new>.
+
+=cut
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub make_source { shift->source_class->new(@_); }
+sub make_perl_source { shift->perl_source_class->new(@_); }
+sub make_grammar { shift->grammar_class->new(@_); }
+sub make_iterator { shift->iterator_factory_class->make_iterator(@_); }
+sub make_result { shift->result_factory_class->make_result(@_); }
+
+sub _iterator_for_source {
+ my ( $self, $source ) = @_;
+
+ # If the source has a get_stream method then use it. This makes it
+ # possible to pass a pre-existing source object to the parser's
+ # constructor.
+ if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) {
+ return $source->get_stream($self);
+ }
+ else {
+ return $self->iterator_factory_class->make_iterator($source);
+ }
+}
+
+{
+
+ # of the following, anything beginning with an underscore is strictly
+ # internal and should not be exposed.
+ my %initialize = (
+ version => $DEFAULT_TAP_VERSION,
+ plan => '', # the test plan (e.g., 1..3)
+ tap => '', # the TAP
+ tests_run => 0, # actual current test numbers
+ results => [], # TAP parser results
+ skipped => [], #
+ todo => [], #
+ passed => [], #
+ failed => [], #
+ actual_failed => [], # how many tests really failed
+ actual_passed => [], # how many tests really passed
+ todo_passed => [], # tests which unexpectedly succeed
+ parse_errors => [], # perfect TAP should have none
+ );
+
+ # We seem to have this list hanging around all over the place. We could
+ #Â probably get it from somewhere else to avoid the repetition.
+ my @legal_callback = qw(
+ test
+ version
+ plan
+ comment
+ bailout
+ unknown
+ yaml
+ ALL
+ ELSE
+ EOF
+ );
+
+ my @class_overrides = qw(
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ # everything here is basically designed to convert any TAP source to a
+ # stream.
+
+ # Shallow copy
+ my %args = %{ $arg_for || {} };
+
+ $self->SUPER::_initialize( \%args, \@legal_callback );
+
+ # get any class overrides out first:
+ for my $key (@class_overrides) {
+ my $default_method = "_default_$key";
+ my $val = delete $args{$key} || $self->$default_method();
+ $self->$key($val);
+ }
+
+ my $stream = delete $args{stream};
+ my $tap = delete $args{tap};
+ my $source = delete $args{source};
+ my $exec = delete $args{exec};
+ my $merge = delete $args{merge};
+ my $spool = delete $args{spool};
+ my $switches = delete $args{switches};
+ my $ignore_exit = delete $args{ignore_exit};
+ my @test_args = @{ delete $args{test_args} || [] };
+
+ if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
+ $self->_croak(
+ "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
+ );
+ }
+
+ if ( my @excess = sort keys %args ) {
+ $self->_croak("Unknown options: @excess");
+ }
+
+ if ($tap) {
+ $stream = $self->_iterator_for_source( [ split "\n" => $tap ] );
+ }
+ elsif ($exec) {
+ my $source = $self->make_source;
+ $source->source( [ @$exec, @test_args ] );
+ $source->merge($merge); # XXX should just be arguments?
+ $stream = $source->get_stream($self);
+ }
+ elsif ($source) {
+ if ( $source =~ /\n/ ) {
+ $stream
+ = $self->_iterator_for_source( [ split "\n" => $source ] );
+ }
+ elsif ( ref $source ) {
+ $stream = $self->_iterator_for_source($source);
+ }
+ elsif ( -e $source ) {
+ my $perl = $self->make_perl_source;
+
+ $perl->switches($switches)
+ if $switches;
+
+ $perl->merge($merge); # XXX args to new()?
+ $perl->source( [ $source, @test_args ] );
+ $stream = $perl->get_stream($self);
+ }
+ else {
+ $self->_croak("Cannot determine source for $source");
+ }
+ }
+
+ unless ($stream) {
+ $self->_croak('PANIC: could not determine stream');
+ }
+
+ while ( my ( $k, $v ) = each %initialize ) {
+ $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
+ }
+
+ $self->_stream($stream);
+ $self->_spool($spool);
+ $self->ignore_exit($ignore_exit);
+
+ return $self;
+ }
+}
+
+=head1 INDIVIDUAL RESULTS
+
+If you've read this far in the docs, you've seen this:
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+Each result returned is a L<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=head2 Result types
+
+Basically, you fetch individual results from the TAP. The six types, with
+examples of each, are as follows:
+
+=over 4
+
+=item * Version
+
+ TAP version 12
+
+=item * Plan
+
+ 1..42
+
+=item * Pragma
+
+ pragma +strict
+
+=item * Test
+
+ ok 3 - We should start with some foobar!
+
+=item * Comment
+
+ # Hope we don't use up the foobar.
+
+=item * Bailout
+
+ Bail out! We ran out of foobar!
+
+=item * Unknown
+
+ ... yo, this ain't TAP! ...
+
+=back
+
+Each result fetched is a result object of a different type. There are common
+methods to each result object and different types may have methods unique to
+their type. Sometimes a type method may be overridden in a subclass, but its
+use is guaranteed to be identical.
+
+=head2 Common type methods
+
+=head3 C<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+Indicates whether or not this is a comment. Comments will generally only
+appear in the TAP stream if STDERR is merged to STDOUT. See the
+C<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut
+which allows you to do this:
+
+ my $parser = TAP::Parser->new( { source => $source } );
+ while ( my $result = $parser->next ) {
+ # only print failing results
+ print $result->as_string unless $result->is_ok;
+ }
+
+=head2 C<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<pragma> methods
+
+ if ( $result->is_pragma ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<pragmas>
+
+Returns a list of pragmas each of which is a + or - followed by the
+pragma name.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=head2 C<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+B<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ if ( $parser->in_todo ) { ... }
+
+True while the most recent result was a TODO. Becomes true before the
+TODO result is returned and stays true until just before the next non-
+TODO test is returned.
+
+=head1 TOTAL RESULTS
+
+After parsing the TAP, there are many methods available to let you dig through
+the results and determine what is meaningful to you.
+
+=head2 Individual Results
+
+These results refer to individual tests which are run.
+
+=head3 C<passed>
+
+ my @passed = $parser->passed; # the test numbers which passed
+ my $passed = $parser->passed; # the number of tests which passed
+
+This method lets you know which (or how many) tests passed. If a test failed
+but had a TODO directive, it will be counted as a passed test.
+
+=cut
+
+sub passed { @{ shift->{passed} } }
+
+=head3 C<failed>
+
+ my @failed = $parser->failed; # the test numbers which failed
+ my $failed = $parser->failed; # the number of tests which failed
+
+This method lets you know which (or how many) tests failed. If a test passed
+but had a TODO directive, it will B<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # the test numbers which actually passed
+ my @actual_passed = $parser->actual_passed;
+
+ # the number of tests which actually passed
+ my $actual_passed = $parser->actual_passed;
+
+This method lets you know which (or how many) tests actually passed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_passed { @{ shift->{actual_passed} } }
+*actual_ok = \&actual_passed;
+
+=head3 C<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # the test numbers which actually failed
+ my @actual_failed = $parser->actual_failed;
+
+ # the number of tests which actually failed
+ my $actual_failed = $parser->actual_failed;
+
+This method lets you know which (or how many) tests actually failed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_failed { @{ shift->{actual_failed} } }
+
+##############################################################################
+
+=head3 C<todo>
+
+ my @todo = $parser->todo; # the test numbers with todo directives
+ my $todo = $parser->todo; # the number of tests with todo directives
+
+This method lets you know which (or how many) tests had TODO directives.
+
+=cut
+
+sub todo { @{ shift->{todo} } }
+
+=head3 C<todo_passed>
+
+ # the test numbers which unexpectedly succeeded
+ my @todo_passed = $parser->todo_passed;
+
+ # the number of tests which unexpectedly succeeded
+ my $todo_passed = $parser->todo_passed;
+
+This method lets you know which (or how many) tests actually passed but were
+declared as "TODO" tests.
+
+=cut
+
+sub todo_passed { @{ shift->{todo_passed} } }
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ my @skipped = $parser->skipped; # the test numbers with SKIP directives
+ my $skipped = $parser->skipped; # the number of tests with SKIP directives
+
+This method lets you know which (or how many) tests had SKIP directives.
+
+=cut
+
+sub skipped { @{ shift->{skipped} } }
+
+=head2 Pragmas
+
+=head3 C<pragma>
+
+Get or set a pragma. To get the state of a pragma:
+
+ if ( $p->pragma('strict') ) {
+ # be strict
+ }
+
+To set the state of a pragma:
+
+ $p->pragma('strict', 1); # enable strict mode
+
+=cut
+
+sub pragma {
+ my ( $self, $pragma ) = splice @_, 0, 2;
+
+ return $self->{pragma}->{$pragma} unless @_;
+
+ if ( my $state = shift ) {
+ $self->{pragma}->{$pragma} = 1;
+ }
+ else {
+ delete $self->{pragma}->{$pragma};
+ }
+
+ return;
+}
+
+=head3 C<pragmas>
+
+Get a list of all the currently enabled pragmas:
+
+ my @pragmas_enabled = $p->pragmas;
+
+=cut
+
+sub pragmas { sort keys %{ shift->{pragma} || {} } }
+
+=head2 Summary Results
+
+These results are "meta" information about the total results of an individual
+test program.
+
+=head3 C<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ if ( $parser->is_good_plan ) { ... }
+
+Returns a boolean value indicating whether or not the number of tests planned
+matches the number of tests run.
+
+B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ print $parser->tests_planned;
+
+Returns the number of tests planned, according to the plan. For example, a
+plan of '1..17' will mean that 17 tests were planned.
+
+=head3 C<tests_run>
+
+ print $parser->tests_run;
+
+Returns the number of tests which actually were run. Hopefully this will
+match the number of C<< $parser->tests_planned >>.
+
+=head3 C<skip_all>
+
+Returns a true value (actually the reason for skipping) if all tests
+were skipped.
+
+=head3 C<start_time>
+
+Returns the time when the Parser was created.
+
+=head3 C<end_time>
+
+Returns the time when the end of TAP input was seen.
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+This is a 'catch-all' method which returns true if any tests have currently
+failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
+}
+
+=head3 C<version>
+
+ $parser->version;
+
+Once the parser is done, this will return the version number for the
+parsed TAP. Version numbers were introduced with TAP version 13 so if no
+version number is found version 12 is assumed.
+
+=head3 C<exit>
+
+ $parser->exit;
+
+Once the parser is done, this will return the exit status. If the parser ran
+an executable, it returns the exit status of the executable.
+
+=head3 C<wait>
+
+ $parser->wait;
+
+Once the parser is done, this will return the wait status. If the parser ran
+an executable, it returns the wait status of the executable. Otherwise, this
+mererely returns the C<exit> status.
+
+=head2 C<ignore_exit>
+
+ $parser->ignore_exit(1);
+
+Tell the parser to ignore the exit status from the test when determining
+whether the test passed. Normally tests with non-zero exit status are
+considered to have failed even if all individual tests passed. In cases
+where it is not possible to control the exit value of the test script
+use this option to ignore it.
+
+=cut
+
+sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
+
+=head3 C<parse_errors>
+
+ my @errors = $parser->parse_errors; # the parser errors
+ my $errors = $parser->parse_errors; # the number of parser_errors
+
+Fortunately, all TAP output is perfect. In the event that it is not, this
+method will return parser errors. Note that a junk line which the parser does
+not recognize is C<not> an error. This allows this parser to handle future
+versions of TAP. The following are all TAP errors reported by the parser:
+
+=over 4
+
+=item * Misplaced plan
+
+The plan (for example, '1..5'), must only come at the beginning or end of the
+TAP output.
+
+=item * No plan
+
+Gotta have a plan!
+
+=item * More than one plan
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+ 1..3
+
+Right. Very funny. Don't do that.
+
+=item * Test numbers out of sequence
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+That last test line above should have the number '3' instead of '2'.
+
+Note that it's perfectly acceptable for some lines to have test numbers and
+others to not have them. However, when a test number is found, it must be in
+sequence. The following is also an error:
+
+ 1..3
+ ok 1 - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+But this is not:
+
+ 1..3
+ ok - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+
+=back
+
+=cut
+
+sub parse_errors { @{ shift->{parse_errors} } }
+
+sub _add_error {
+ my ( $self, $error ) = @_;
+ push @{ $self->{parse_errors} } => $error;
+ return $self;
+}
+
+sub _make_state_table {
+ my $self = shift;
+ my %states;
+ my %planned_todo = ();
+
+ #Â These transitions are defaults for all states
+ my %state_globals = (
+ comment => {},
+ bailout => {},
+ yaml => {},
+ version => {
+ act => sub {
+ $self->_add_error(
+ 'If TAP version is present it must be the first line of output'
+ );
+ },
+ },
+ unknown => {
+ act => sub {
+ my $unk = shift;
+ if ( $self->pragma('strict') ) {
+ $self->_add_error(
+ 'Unknown TAP token: "' . $unk->raw . '"' );
+ }
+ },
+ },
+ pragma => {
+ act => sub {
+ my ($pragma) = @_;
+ for my $pr ( $pragma->pragmas ) {
+ if ( $pr =~ /^ ([-+])(\w+) $/x ) {
+ $self->pragma( $2, $1 eq '+' );
+ }
+ }
+ },
+ },
+ );
+
+ # Provides default elements for transitions
+ my %state_defaults = (
+ plan => {
+ act => sub {
+ my ($plan) = @_;
+ $self->tests_planned( $plan->tests_planned );
+ $self->plan( $plan->plan );
+ if ( $plan->has_skip ) {
+ $self->skip_all( $plan->explanation
+ || '(no reason given)' );
+ }
+
+ $planned_todo{$_}++ for @{ $plan->todo_list };
+ },
+ },
+ test => {
+ act => sub {
+ my ($test) = @_;
+
+ my ( $number, $tests_run )
+ = ( $test->number, ++$self->{tests_run} );
+
+ # Fake TODO state
+ if ( defined $number && delete $planned_todo{$number} ) {
+ $test->set_directive('TODO');
+ }
+
+ my $has_todo = $test->has_todo;
+
+ $self->in_todo($has_todo);
+ if ( defined( my $tests_planned = $self->tests_planned ) ) {
+ if ( $tests_run > $tests_planned ) {
+ $test->is_unplanned(1);
+ }
+ }
+
+ if ( defined $number ) {
+ if ( $number != $tests_run ) {
+ my $count = $tests_run;
+ $self->_add_error( "Tests out of sequence. Found "
+ . "($number) but expected ($count)" );
+ }
+ }
+ else {
+ $test->_number( $number = $tests_run );
+ }
+
+ push @{ $self->{todo} } => $number if $has_todo;
+ push @{ $self->{todo_passed} } => $number
+ if $test->todo_passed;
+ push @{ $self->{skipped} } => $number
+ if $test->has_skip;
+
+ push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
+ $number;
+ push @{
+ $self->{
+ $test->is_actual_ok
+ ? 'actual_passed'
+ : 'actual_failed'
+ }
+ } => $number;
+ },
+ },
+ yaml => { act => sub { }, },
+ );
+
+ # Each state contains a hash the keys of which match a token type. For
+ # each token
+ # type there may be:
+ # act A coderef to run
+ # goto The new state to move to. Stay in this state if
+ # missing
+ # continue Goto the new state and run the new state for the
+ # current token
+ %states = (
+ INIT => {
+ version => {
+ act => sub {
+ my ($version) = @_;
+ my $ver_num = $version->version;
+ if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
+ my $ver_min = $DEFAULT_TAP_VERSION + 1;
+ $self->_add_error(
+ "Explicit TAP version must be at least "
+ . "$ver_min. Got version $ver_num" );
+ $ver_num = $DEFAULT_TAP_VERSION;
+ }
+ if ( $ver_num > $MAX_TAP_VERSION ) {
+ $self->_add_error(
+ "TAP specified version $ver_num but "
+ . "we don't know about versions later "
+ . "than $MAX_TAP_VERSION" );
+ $ver_num = $MAX_TAP_VERSION;
+ }
+ $self->version($ver_num);
+ $self->_grammar->set_version($ver_num);
+ },
+ goto => 'PLAN'
+ },
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLAN => {
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLANNED => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => {
+ act => sub {
+ my ($version) = @_;
+ $self->_add_error(
+ 'More than one plan found in TAP output');
+ },
+ },
+ },
+ PLANNED_AFTER_TEST => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => { act => sub { }, continue => 'PLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ GOT_PLAN => {
+ test => {
+ act => sub {
+ my ($plan) = @_;
+ my $line = $self->plan;
+ $self->_add_error(
+ "Plan ($line) must be at the beginning "
+ . "or end of the TAP output" );
+ $self->is_good_plan(0);
+ },
+ continue => 'PLANNED'
+ },
+ plan => { continue => 'PLANNED' },
+ },
+ UNPLANNED => {
+ test => { goto => 'UNPLANNED_AFTER_TEST' },
+ plan => { goto => 'GOT_PLAN' },
+ },
+ UNPLANNED_AFTER_TEST => {
+ test => { act => sub { }, continue => 'UNPLANNED' },
+ plan => { act => sub { }, continue => 'UNPLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ );
+
+ # Apply globals and defaults to state table
+ for my $name ( keys %states ) {
+
+ # Merge with globals
+ my $st = { %state_globals, %{ $states{$name} } };
+
+ # Add defaults
+ for my $next ( sort keys %{$st} ) {
+ if ( my $default = $state_defaults{$next} ) {
+ for my $def ( sort keys %{$default} ) {
+ $st->{$next}->{$def} ||= $default->{$def};
+ }
+ }
+ }
+
+ # Stuff back in table
+ $states{$name} = $st;
+ }
+
+ return \%states;
+}
+
+=head3 C<get_select_handles>
+
+Get an a list of file handles which can be passed to C<select> to
+determine the readiness of this parser.
+
+=cut
+
+sub get_select_handles { shift->_stream->get_select_handles }
+
+sub _grammar {
+ my $self = shift;
+ return $self->{_grammar} = shift if @_;
+
+ return $self->{_grammar} ||= $self->make_grammar(
+ { stream => $self->_stream,
+ parser => $self,
+ version => $self->version
+ }
+ );
+}
+
+sub _iter {
+ my $self = shift;
+ my $stream = $self->_stream;
+ my $grammar = $self->_grammar;
+ my $spool = $self->_spool;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ $self->start_time( $self->get_time );
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ TRANS: {
+ my $state_spec = $state_table->{$state}
+ or die "Illegal state: $state";
+
+ if ( my $next = $state_spec->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $act->($token);
+ }
+ if ( my $cont = $next->{continue} ) {
+ $state = $cont;
+ redo TRANS;
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $state = $goto;
+ }
+ }
+ else {
+ confess("Unhandled token type: $type\n");
+ }
+ }
+ return $token;
+ };
+
+ # Handle end of stream - which means either pop a block or finish
+ my $end_handler = sub {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ return;
+ };
+
+ # Finally make the closure that we return. For performance reasons
+ # there are two versions of the returned function: one that handles
+ # callbacks and one that does not.
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $_->($result) for @{$code};
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ $self->_make_callback( 'EOF', $self )
+ unless defined $result;
+ }
+
+ return $result;
+ };
+ } # _has_callbacks
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ }
+
+ return $result;
+ };
+ } # no callbacks
+}
+
+sub _finish {
+ my $self = shift;
+
+ $self->end_time( $self->get_time );
+
+ # Avoid leaks
+ $self->_stream(undef);
+ $self->_grammar(undef);
+
+ # If we just delete the iter we won't get a fault if it's recreated.
+ # Instead we set it to a sub that returns an infinite
+ # stream of undef. This segfaults on 5.5.4, presumably because
+ # we're still executing the closure that gets replaced and it hasn't
+ # been protected with a refcount.
+ $self->{_iter} = sub {return}
+ if $] >= 5.006;
+
+ # sanity checks
+ if ( !$self->plan ) {
+ $self->_add_error('No plan found in TAP output');
+ }
+ else {
+ $self->is_good_plan(1) unless defined $self->is_good_plan;
+ }
+ if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
+ $self->is_good_plan(0);
+ if ( defined( my $planned = $self->tests_planned ) ) {
+ my $ran = $self->tests_run;
+ $self->_add_error(
+ "Bad plan. You planned $planned tests but ran $ran.");
+ }
+ }
+ if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
+
+ # this should never happen
+ my $actual = $self->tests_run;
+ my $passed = $self->passed;
+ my $failed = $self->failed;
+ $self->_croak( "Panic: planned test count ($actual) did not equal "
+ . "sum of passed ($passed) and failed ($failed) tests!" );
+ }
+
+ $self->is_good_plan(0) unless defined $self->is_good_plan;
+ return $self;
+}
+
+=head3 C<delete_spool>
+
+Delete and return the spool.
+
+ my $fh = $parser->delete_spool;
+
+=cut
+
+sub delete_spool {
+ my $self = shift;
+
+ return delete $self->{_spool};
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will
+be invoked. Thus, if all of the previous result types are specified as
+callbacks, this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is no
+accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO
+lists in the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was
+listed as a TODO test on the plan line. However, we are not aware of
+anyone actually using this feature and hard-coding test numbers is
+discouraged because it's very easy to add a test and break the test
+number sequence. This makes test suites very fragile. Instead, the
+following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter
+'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've
+never run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 SUBCLASSING
+
+If you find you need to provide custom functionality (as you would have using
+L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
+designed to be easily subclassed.
+
+Before you start, it's important to know a few things:
+
+=over 2
+
+=item 1
+
+All C<TAP::*> objects inherit from L<TAP::Object>.
+
+=item 2
+
+Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
+
+=item 3
+
+Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
+responsible for creating new objects in the C<TAP::Parser::*> namespace.
+
+This makes it possible for you to have a single point of configuring what
+subclasses should be used, which in turn means that in many cases you'll find
+you only need to sub-class one of the parser's components.
+
+=item 4
+
+By subclassing, you may end up overriding undocumented methods. That's not
+a bad thing per se, but be forewarned that undocumented methods may change
+without warning from one release to the next - we cannot guarantee backwards
+compatability. If any I<documented> method needs changing, it will be
+deprecated first, and changed in a later release.
+
+=back
+
+=head2 Parser Components
+
+=head3 Sources
+
+A TAP parser consumes input from a I<source>. There are currently two types
+of sources: L<TAP::Parser::Source> for general non-perl commands, and
+L<TAP::Parser::Source::Perl>. You can subclass both of them. You'll need to
+customize your parser by setting the C<source_class> & C<perl_source_class>
+parameters. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_source> or L</make_perl_source>.
+
+=head3 Iterators
+
+A TAP parser uses I<iterators> to loop through the I<stream> provided by the
+parser's I<source>. There are quite a few types of Iterators available.
+Choosing which class to use is the responsibility of the I<iterator factory>.
+
+To create your own iterators you'll have to subclass
+L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>. Then you'll
+need to customize the class used by your parser by setting the
+C<iterator_factory_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_iterator>.
+
+=head3 Results
+
+A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
+input I<stream>. There are quite a few result types available; choosing
+which class to use is the responsibility of the I<result factory>.
+
+To create your own result types you have two options:
+
+=over 2
+
+=item option 1
+
+Subclass L<TAP::Parser::Result> and register your new result type/class with
+the default L<TAP::Parser::ResultFactory>.
+
+=item option 2
+
+Subclass L<TAP::Parser::ResultFactory> itself and implement your own
+L<TAP::Parser::Result> creation logic. Then you'll need to customize the
+class used by your parser by setting the C<result_factory_class> parameter.
+See L</new> for more details.
+
+=back
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_result>.
+
+=head3 Grammar
+
+L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
+input I<stream> and produces results. If you need to customize its behaviour
+you should probably familiarize yourself with the source first. Enough
+lecturing.
+
+Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
+C<grammar_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_grammar>
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral
+support, or just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=item * David Wheeler
+
+=item * Alex Vandiver
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid@cpan.org>
+
+Andy Armstong <andy@hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+Michael Peters <mpeters at plusthree dot com>
+
+Leif Eriksen <leif dot eriksen at bigpond dot com>
+
+Steve Purkis <spurkis@cpan.org>
+
+Nicholas Clark <nick@ccl4.org>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
+We will be notified, and then you'll automatically be notified of
+progress on your bug as we make changes.
+
+Obviously, bugs which include patches are best. If you prefer, you can
+patch against bleed by via anonymous checkout of the latest version:
+
+ svn checkout http://svn.hexten.net/tapx
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Aggregator;
+
+use strict;
+use Benchmark;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Aggregator;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+ $aggregate->add( 't/00-load.t', $load_parser );
+ $aggregate->add( 't/10-lex.t', $lex_parser );
+
+ my $summary = <<'END_SUMMARY';
+ Passed: %s
+ Failed: %s
+ Unexpectedly succeeded: %s
+ END_SUMMARY
+ printf $summary,
+ scalar $aggregate->passed,
+ scalar $aggregate->failed,
+ scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN { # install summary methods
+ %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+ failed
+ parse_errors
+ passed
+ skipped
+ todo
+ todo_passed
+ total
+ wait
+ exit
+ );
+ $SUMMARY_METHOD_FOR{total} = 'tests_run';
+ $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
+
+ foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
+ next if 'total' eq $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return wantarray
+ ? @{ $self->{"descriptions_for_$method"} }
+ : $self->{$method};
+ };
+ }
+} # end install summary methods
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.) It is used as a unique identifier (see e.g.
+L<"parsers">.) Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak( "You already have a parser for ($description)."
+ . " Perhaps you have run the same test twice." );
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+
+ # Slightly nasty. Instead we should maybe have 'cooked' accessors
+ # for results that may be masked by the parser.
+ next
+ if ( $method eq 'exit' || $method eq 'wait' )
+ && $parser->ignore_exit;
+
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method. Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->_get_parsers(@_) if @_;
+ my $descriptions = $self->{parse_order};
+ my @parsers = @{ $self->{parser_for} }{@$descriptions};
+
+ # Note: Because of the way context works, we must assign the parsers to
+ # the @parsers array or else this method does not work as documented.
+ return @parsers;
+}
+
+sub _get_parsers {
+ my ( $self, @descriptions ) = @_;
+ my @parsers;
+ foreach my $description (@descriptions) {
+ $self->_croak("A parser for ($description) could not be found")
+ unless exists $self->{parser_for}{$description};
+ push @parsers => $self->{parser_for}{$description};
+ }
+ return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to
+the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+ my $self = shift;
+ $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+ my $self = shift;
+ $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+ my $self = shift;
+
+ require Carp;
+ Carp::croak
+ q{Can't call elapsed without first calling start and then stop}
+ unless defined $self->{start_time} && defined $self->{end_time};
+ return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>. This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+ my $self = shift;
+
+ my $elapsed = $self->elapsed;
+
+ return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+ my $self = shift;
+ return
+ $self->total
+ && $self->total == $self->passed
+ && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+ my $self = shift;
+
+ my $total = $self->total;
+ my $passed = $self->passed;
+
+ return
+ ( $self->has_errors || $total != $passed ) ? 'FAIL'
+ : $total ? 'PASS'
+ : 'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * planned
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded. This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->todo_passed
+ || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+ if ( $parser->has_errors ) {
+ ...
+ }
+
+Returns true if I<any> of the parsers failed. This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse errors
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::YAMLish::Reader ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Grammar;
+ my $grammar = $self->make_grammar({
+ stream => $tap_parser_stream,
+ parser => $tap_parser,
+ version => 12,
+ });
+
+ my $result = $grammar->tokenize;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $grammar = TAP::Parser::Grammar->new({
+ stream => $stream,
+ parser => $parser,
+ version => $version,
+ });
+
+Returns L<TAP::Parser> grammar object that will parse the specified stream.
+Both C<stream> and C<parser> are required arguments. If C<version> is not set
+it defaults to C<12> (see L</set_version> for more details).
+
+=cut
+
+# new() implementation supplied by TAP::Object
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{stream} = $args->{stream}; # TODO: accessor
+ $self->{parser} = $args->{parser}; # TODO: accessor
+ $self->set_version( $args->{version} || 12 );
+ return $self;
+}
+
+my %language_for;
+
+{
+
+ # XXX the 'not' and 'ok' might be on separate lines in VMS ...
+ my $ok = qr/(?:not )?ok\b/;
+ my $num = qr/\d+/;
+
+ my %v12 = (
+ version => {
+ syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $version = $1;
+ return $self->_make_version_token( $line, $version, );
+ },
+ },
+ plan => {
+ syntax => qr/^1\.\.(\d+)\s*(.*)\z/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $tail ) = ( $1, $2 );
+ my $explanation = undef;
+ my $skip = '';
+
+ if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
+ my @todo = split /\s+/, _trim($1);
+ return $self->_make_plan_token(
+ $line, $tests_planned, 'TODO',
+ '', \@todo
+ );
+ }
+ elsif ( 0 == $tests_planned ) {
+ $skip = 'SKIP';
+
+ # If we can't match # SKIP the directive should be undef.
+ ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i;
+ }
+ elsif ( $tail !~ /^\s*$/ ) {
+ return $self->_make_unknown_token($line);
+ }
+
+ $explanation = '' unless defined $explanation;
+
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+
+ },
+ },
+
+ # An optimization to handle the most common test lines without
+ # directives.
+ simple_test => {
+ syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+
+ return $self->_make_test_token(
+ $line, $ok, $num,
+ $desc
+ );
+ },
+ },
+ test => {
+ syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+ my ( $dir, $explanation ) = ( '', '' );
+ if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
+ \# \s* (SKIP|TODO) \b \s* (.*) $/ix
+ )
+ {
+ ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
+ }
+ return $self->_make_test_token(
+ $line, $ok, $num, $desc,
+ $dir, $explanation
+ );
+ },
+ },
+ comment => {
+ syntax => qr/^#(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $comment = $1;
+ return $self->_make_comment_token( $line, $comment );
+ },
+ },
+ bailout => {
+ syntax => qr/^Bail out!\s*(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $explanation = $1;
+ return $self->_make_bailout_token(
+ $line,
+ $explanation
+ );
+ },
+ },
+ );
+
+ my %v13 = (
+ %v12,
+ plan => {
+ syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $explanation ) = ( $1, $2 );
+ my $skip
+ = ( 0 == $tests_planned || defined $explanation )
+ ? 'SKIP'
+ : '';
+ $explanation = '' unless defined $explanation;
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+ },
+ },
+ yaml => {
+ syntax => qr/^ (\s+) (---.*) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $pad, $marker ) = ( $1, $2 );
+ return $self->_make_yaml_token( $pad, $marker );
+ },
+ },
+ pragma => {
+ syntax =>
+ qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $pragmas = $1;
+ return $self->_make_pragma_token( $line, $pragmas );
+ },
+ },
+ );
+
+ %language_for = (
+ '12' => {
+ tokens => \%v12,
+ },
+ '13' => {
+ tokens => \%v13,
+ setup => sub {
+ shift->{stream}->handle_unicode;
+ },
+ },
+ );
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<set_version>
+
+ $grammar->set_version(13);
+
+Tell the grammar which TAP syntax version to support. The lowest
+supported version is 12. Although 'TAP version' isn't valid version 12
+syntax it is accepted so that higher version numbers may be parsed.
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ my $version = shift;
+
+ if ( my $language = $language_for{$version} ) {
+ $self->{version} = $version;
+ $self->{tokens} = $language->{tokens};
+
+ if ( my $setup = $language->{setup} ) {
+ $self->$setup();
+ }
+
+ $self->_order_tokens;
+ }
+ else {
+ require Carp;
+ Carp::croak("Unsupported syntax version: $version");
+ }
+}
+
+# Optimization to put the most frequent tokens first.
+sub _order_tokens {
+ my $self = shift;
+
+ my %copy = %{ $self->{tokens} };
+ my @ordered_tokens = grep {defined}
+ map { delete $copy{$_} } qw( simple_test test comment plan );
+ push @ordered_tokens, values %copy;
+
+ $self->{ordered_tokens} = \@ordered_tokens;
+}
+
+##############################################################################
+
+=head3 C<tokenize>
+
+ my $token = $grammar->tokenize;
+
+This method will return a L<TAP::Parser::Result> object representing the
+current line of TAP.
+
+=cut
+
+sub tokenize {
+ my $self = shift;
+
+ my $line = $self->{stream}->next;
+ unless ( defined $line ) {
+ delete $self->{parser}; # break circular ref
+ return;
+ }
+
+ my $token;
+
+ foreach my $token_data ( @{ $self->{ordered_tokens} } ) {
+ if ( $line =~ $token_data->{syntax} ) {
+ my $handler = $token_data->{handler};
+ $token = $self->$handler($line);
+ last;
+ }
+ }
+
+ $token = $self->_make_unknown_token($line) unless $token;
+
+ return $self->{parser}->make_result($token);
+}
+
+##############################################################################
+
+=head3 C<token_types>
+
+ my @types = $grammar->token_types;
+
+Returns the different types of tokens which this grammar can parse.
+
+=cut
+
+sub token_types {
+ my $self = shift;
+ return keys %{ $self->{tokens} };
+}
+
+##############################################################################
+
+=head3 C<syntax_for>
+
+ my $syntax = $grammar->syntax_for($token_type);
+
+Returns a pre-compiled regular expression which will match a chunk of TAP
+corresponding to the token type. For example (not that you should really pay
+attention to this, C<< $grammar->syntax_for('comment') >> will return
+C<< qr/^#(.*)/ >>.
+
+=cut
+
+sub syntax_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{syntax};
+}
+
+##############################################################################
+
+=head3 C<handler_for>
+
+ my $handler = $grammar->handler_for($token_type);
+
+Returns a code reference which, when passed an appropriate line of TAP,
+returns the lexed token corresponding to that line. As a result, the basic
+TAP parsing loop looks similar to the following:
+
+ my @tokens;
+ my $grammar = TAP::Grammar->new;
+ LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
+ foreach my $type ( $grammar->token_types ) {
+ my $syntax = $grammar->syntax_for($type);
+ if ( $line =~ $syntax ) {
+ my $handler = $grammar->handler_for($type);
+ push @tokens => $grammar->$handler($line);
+ next LINE;
+ }
+ }
+ push @tokens => $grammar->_make_unknown_token($line);
+ }
+
+=cut
+
+sub handler_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{handler};
+}
+
+sub _make_version_token {
+ my ( $self, $line, $version ) = @_;
+ return {
+ type => 'version',
+ raw => $line,
+ version => $version,
+ };
+}
+
+sub _make_plan_token {
+ my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
+
+ if ( $directive eq 'SKIP'
+ && 0 != $tests_planned
+ && $self->{version} < 13 )
+ {
+ warn
+ "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+ }
+
+ return {
+ type => 'plan',
+ raw => $line,
+ tests_planned => $tests_planned,
+ directive => $directive,
+ explanation => _trim($explanation),
+ todo_list => $todo,
+ };
+}
+
+sub _make_test_token {
+ my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+ return {
+ ok => $ok,
+ test_num => $num,
+ description => _trim($desc),
+ directive => ( defined $dir ? uc $dir : '' ),
+ explanation => _trim($explanation),
+ raw => $line,
+ type => 'test',
+ };
+}
+
+sub _make_unknown_token {
+ my ( $self, $line ) = @_;
+ return {
+ raw => $line,
+ type => 'unknown',
+ };
+}
+
+sub _make_comment_token {
+ my ( $self, $line, $comment ) = @_;
+ return {
+ type => 'comment',
+ raw => $line,
+ comment => _trim($comment)
+ };
+}
+
+sub _make_bailout_token {
+ my ( $self, $line, $explanation ) = @_;
+ return {
+ type => 'bailout',
+ raw => $line,
+ bailout => _trim($explanation)
+ };
+}
+
+sub _make_yaml_token {
+ my ( $self, $pad, $marker ) = @_;
+
+ my $yaml = TAP::Parser::YAMLish::Reader->new;
+
+ my $stream = $self->{stream};
+
+ # Construct a reader that reads from our input stripping leading
+ # spaces from each line.
+ my $leader = length($pad);
+ my $strip = qr{ ^ (\s{$leader}) (.*) $ }x;
+ my @extra = ($marker);
+ my $reader = sub {
+ return shift @extra if @extra;
+ my $line = $stream->next;
+ return $2 if $line =~ $strip;
+ return;
+ };
+
+ my $data = $yaml->read($reader);
+
+ # Reconstitute input. This is convoluted. Maybe we should just
+ # record it on the way in...
+ chomp( my $raw = $yaml->get_raw );
+ $raw =~ s/^/$pad/mg;
+
+ return {
+ type => 'yaml',
+ raw => $raw,
+ data => $data
+ };
+}
+
+sub _make_pragma_token {
+ my ( $self, $line, $pragmas ) = @_;
+ return {
+ type => 'pragma',
+ raw => $line,
+ pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
+ };
+}
+
+sub _trim {
+ my $data = shift;
+
+ return '' unless defined $data;
+
+ $data =~ s/^\s+//;
+ $data =~ s/\s+$//;
+ return $data;
+}
+
+1;
+
+=head1 TAP GRAMMAR
+
+B<NOTE:> This grammar is slightly out of date. There's still some discussion
+about it and a new one will be provided when we have things better defined.
+
+The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
+stream-based protocol. In fact, it's quite legal to have an infinite stream.
+For the same reason that we don't apply regexes to streams, we're not using a
+formal grammar here. Instead, we parse the TAP in lines.
+
+For purposes for forward compatability, any result which does not match the
+following grammar is currently referred to as
+L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
+
+A formal grammar would look similar to the following:
+
+ (*
+ For the time being, I'm cheating on the EBNF by allowing
+ certain terms to be defined by POSIX character classes by
+ using the following syntax:
+
+ digit ::= [:digit:]
+
+ As far as I am aware, that's not valid EBNF. Sue me. I
+ didn't know how to write "char" otherwise (Unicode issues).
+ Suggestions welcome.
+ *)
+
+ tap ::= version? { comment | unknown } leading_plan lines
+ |
+ lines trailing_plan {comment}
+
+ version ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
+
+ leading_plan ::= plan skip_directive? "\n"
+
+ trailing_plan ::= plan "\n"
+
+ plan ::= '1..' nonNegativeInteger
+
+ lines ::= line {line}
+
+ line ::= (comment | test | unknown | bailout ) "\n"
+
+ test ::= status positiveInteger? description? directive?
+
+ status ::= 'not '? 'ok '
+
+ description ::= (character - (digit | '#')) {character - '#'}
+
+ directive ::= todo_directive | skip_directive
+
+ todo_directive ::= hash_mark 'TODO' ' ' {character}
+
+ skip_directive ::= hash_mark 'SKIP' ' ' {character}
+
+ comment ::= hash_mark {character}
+
+ hash_mark ::= '#' {' '}
+
+ bailout ::= 'Bail out!' {character}
+
+ unknown ::= { (character - "\n") }
+
+ (* POSIX character classes and other terminals *)
+
+ digit ::= [:digit:]
+ character ::= ([:print:] - "\n")
+ positiveInteger ::= ( digit - '0' ) {digit}
+ nonNegativeInteger ::= digit {digit}
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
+do is read through the code. There's no easy way of summarizing it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Result>,
+
+=cut
--- /dev/null
+package TAP::Parser::Iterator;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for general usage
+
+ # to subclass:
+ use vars qw(@ISA);
+ use TAP::Parser::Iterator ();
+ @ISA = qw(TAP::Parser::Iterator);
+ sub _initialize {
+ # see TAP::Object...
+ }
+
+=head1 DESCRIPTION
+
+This is a simple iterator base class that defines L<TAP::Parser>'s iterator
+API. See C<TAP::Parser::IteratorFactory> for the preferred way of creating
+iterators.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Provided by L<TAP::Object>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+B<Note:> this method is abstract and should be overridden.
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub next {
+ my $self = shift;
+ my $line = $self->next_raw;
+
+ # vms nit: When encountering 'not ok', vms often has the 'not' on a line
+ # by itself:
+ # not
+ # ok 1 - 'I hate VMS'
+ if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
+ $line .= ( $self->next_raw || '' );
+ }
+
+ return $line;
+}
+
+sub next_raw {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+=head3 C<handle_unicode>
+
+If necessary switch the input stream to handle unicode. This only has
+any effect for I/O handle based streams.
+
+The default implementation does nothing.
+
+=cut
+
+sub handle_unicode { }
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle-based should return an empty list.
+
+The default implementation does nothing.
+
+=cut
+
+sub get_select_handles {
+ return;
+}
+
+=head3 C<wait>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->wait;
+
+Return the C<wait> status for this iterator.
+
+=head3 C<exit>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->exit;
+
+Return the C<exit> status for this iterator.
+
+=cut
+
+sub wait {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+sub exit {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+You must override the abstract methods as noted above.
+
+=head2 Example
+
+L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
+There's not much point repeating it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Iterator::Array;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Array;
+ my @data = ('foo', 'bar', baz');
+ my $it = TAP::Parser::Iterator::Array->new(\@data);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for arrays of scalar content, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Takes one argument: an C<$array_ref>
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. For an array iterator this will always
+be zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. For an array iterator this will always
+be zero.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ chomp @$thing;
+ $self->{idx} = 0;
+ $self->{array} = $thing;
+ $self->{exit} = undef;
+ return $self;
+}
+
+sub wait { shift->exit }
+
+sub exit {
+ my $self = shift;
+ return 0 if $self->{idx} >= @{ $self->{array} };
+ return;
+}
+
+sub next_raw {
+ my $self = shift;
+ return $self->{array}->[ $self->{idx}++ ];
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Iterator::Process;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+use Config;
+use IO::Handle;
+
+@ISA = 'TAP::Parser::Iterator';
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Process;
+ my %args = (
+ command => ['python', 'setup.py', 'test'],
+ merge => 1,
+ setup => sub { ... },
+ teardown => sub { ... },
+ );
+ my $it = TAP::Parser::Iterator::Process->new(\%args);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for executing external processes, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a hashref of the form:
+
+ command => \@command_to_execute
+ merge => $attempt_merge_stderr_and_stdout?
+ setup => $callback_to_setup_command
+ teardown => $callback_to_teardown_command
+
+Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
+process if they are available. Falls back onto C<open()>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through the process output, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator's process.
+
+=head3 C<exit>
+
+Get the exit status for this iterator's process.
+
+=cut
+
+eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+if ($@) {
+ *_wait2exit = sub { $_[1] >> 8 };
+}
+else {
+ *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
+}
+
+sub _use_open3 {
+ my $self = shift;
+ return unless $Config{d_fork} || $IS_WIN32;
+ for my $module (qw( IPC::Open3 IO::Select )) {
+ eval "use $module";
+ return if $@;
+ }
+ return 1;
+}
+
+{
+ my $got_unicode;
+
+ sub _get_unicode {
+ return $got_unicode if defined $got_unicode;
+ eval 'use Encode qw(decode_utf8);';
+ $got_unicode = $@ ? 0 : 1;
+
+ }
+}
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+
+ my @command = @{ delete $args->{command} || [] }
+ or die "Must supply a command to execute";
+
+ # Private. Used to frig with chunk size during testing.
+ my $chunk_size = delete $args->{_chunk_size} || 65536;
+
+ my $merge = delete $args->{merge};
+ my ( $pid, $err, $sel );
+
+ if ( my $setup = delete $args->{setup} ) {
+ $setup->(@command);
+ }
+
+ my $out = IO::Handle->new;
+
+ if ( $self->_use_open3 ) {
+
+ # HOTPATCH {{{
+ my $xclose = \&IPC::Open3::xclose;
+ local $^W; # no warnings
+ local *IPC::Open3::xclose = sub {
+ my $fh = shift;
+ no strict 'refs';
+ return if ( fileno($fh) == fileno(STDIN) );
+ $xclose->($fh);
+ };
+
+ # }}}
+
+ if ($IS_WIN32) {
+ $err = $merge ? '' : '>&STDERR';
+ eval {
+ $pid = open3(
+ '<&STDIN', $out, $merge ? '' : $err,
+ @command
+ );
+ };
+ die "Could not execute (@command): $@" if $@;
+ if ( $] >= 5.006 ) {
+
+ # Kludge to avoid warning under 5.5
+ eval 'binmode($out, ":crlf")';
+ }
+ }
+ else {
+ $err = $merge ? '' : IO::Handle->new;
+ eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
+ die "Could not execute (@command): $@" if $@;
+ $sel = $merge ? undef : IO::Select->new( $out, $err );
+ }
+ }
+ else {
+ $err = '';
+ my $command
+ = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
+ open( $out, "$command|" )
+ or die "Could not execute ($command): $!";
+ }
+
+ $self->{out} = $out;
+ $self->{err} = $err;
+ $self->{sel} = $sel;
+ $self->{pid} = $pid;
+ $self->{exit} = undef;
+ $self->{chunk_size} = $chunk_size;
+
+ if ( my $teardown = delete $args->{teardown} ) {
+ $self->{teardown} = sub {
+ $teardown->(@command);
+ };
+ }
+
+ return $self;
+}
+
+=head3 C<handle_unicode>
+
+Upgrade the input stream to handle UTF8.
+
+=cut
+
+sub handle_unicode {
+ my $self = shift;
+
+ if ( $self->{sel} ) {
+ if ( _get_unicode() ) {
+
+ # Make sure our iterator has been constructed and...
+ my $next = $self->{_next} ||= $self->_next;
+
+ # ...wrap it to do UTF8 casting
+ $self->{_next} = sub {
+ my $line = $next->();
+ return decode_utf8($line) if defined $line;
+ return;
+ };
+ }
+ }
+ else {
+ if ( $] >= 5.008 ) {
+ eval 'binmode($self->{out}, ":utf8")';
+ }
+ }
+
+}
+
+##############################################################################
+
+sub wait { shift->{wait} }
+sub exit { shift->{exit} }
+
+sub _next {
+ my $self = shift;
+
+ if ( my $out = $self->{out} ) {
+ if ( my $sel = $self->{sel} ) {
+ my $err = $self->{err};
+ my @buf = ();
+ my $partial = ''; # Partial line
+ my $chunk_size = $self->{chunk_size};
+ return sub {
+ return shift @buf if @buf;
+
+ READ:
+ while ( my @ready = $sel->can_read ) {
+ for my $fh (@ready) {
+ my $got = sysread $fh, my ($chunk), $chunk_size;
+
+ if ( $got == 0 ) {
+ $sel->remove($fh);
+ }
+ elsif ( $fh == $err ) {
+ print STDERR $chunk; # echo STDERR
+ }
+ else {
+ $chunk = $partial . $chunk;
+ $partial = '';
+
+ # Make sure we have a complete line
+ unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
+ my $nl = rindex $chunk, "\n";
+ if ( $nl == -1 ) {
+ $partial = $chunk;
+ redo READ;
+ }
+ else {
+ $partial = substr( $chunk, $nl + 1 );
+ $chunk = substr( $chunk, 0, $nl );
+ }
+ }
+
+ push @buf, split /\n/, $chunk;
+ return shift @buf if @buf;
+ }
+ }
+ }
+
+ # Return partial last line
+ if ( length $partial ) {
+ my $last = $partial;
+ $partial = '';
+ return $last;
+ }
+
+ $self->_finish;
+ return;
+ };
+ }
+ else {
+ return sub {
+ if ( defined( my $line = <$out> ) ) {
+ chomp $line;
+ return $line;
+ }
+ $self->_finish;
+ return;
+ };
+ }
+ }
+ else {
+ return sub {
+ $self->_finish;
+ return;
+ };
+ }
+}
+
+sub next_raw {
+ my $self = shift;
+ return ( $self->{_next} ||= $self->_next )->();
+}
+
+sub _finish {
+ my $self = shift;
+
+ my $status = $?;
+
+ # Avoid circular refs
+ $self->{_next} = sub {return}
+ if $] >= 5.006;
+
+ # If we have a subprocess we need to wait for it to terminate
+ if ( defined $self->{pid} ) {
+ if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+ $status = $?;
+ }
+ }
+
+ ( delete $self->{out} )->close if $self->{out};
+
+ # If we have an IO::Select we also have an error handle to close.
+ if ( $self->{sel} ) {
+ ( delete $self->{err} )->close;
+ delete $self->{sel};
+ }
+ else {
+ $status = $?;
+ }
+
+ # Sometimes we get -1 on Windows. Presumably that means status not
+ # available.
+ $status = 0 if $IS_WIN32 && $status == -1;
+
+ $self->{wait} = $status;
+ $self->{exit} = $self->_wait2exit($status);
+
+ if ( my $teardown = $self->{teardown} ) {
+ $teardown->();
+ }
+
+ return $self;
+}
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {
+ my $self = shift;
+ return grep $_, ( $self->{out}, $self->{err} );
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Iterator::Stream;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Stream;
+ open( TEST, 'test.tap' );
+ my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for reading from filehandles, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a filehandle.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ $self->{fh} = $thing;
+ return $self;
+}
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. Always returns zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. Always returns zero.
+
+=cut
+
+sub wait { shift->exit }
+sub exit { shift->{fh} ? () : 0 }
+
+sub next_raw {
+ my $self = shift;
+ my $fh = $self->{fh};
+
+ if ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ return $line;
+ }
+ else {
+ $self->_finish;
+ return;
+ }
+}
+
+sub _finish {
+ my $self = shift;
+ close delete $self->{fh};
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::IteratorFactory;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::Iterator::Array ();
+use TAP::Parser::Iterator::Stream ();
+use TAP::Parser::Iterator::Process ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::IteratorFactory;
+ my $factory = TAP::Parser::IteratorFactory->new;
+ my $iter = $factory->make_iterator(\*TEST);
+ my $iter = $factory->make_iterator(\@array);
+ my $iter = $factory->make_iterator(\%hash);
+
+ my $line = $iter->next;
+
+=head1 DESCRIPTION
+
+This is a factory class for simple iterator wrappers for arrays, filehandles,
+and hashes. Unless you're subclassing, you probably won't need to use this
+module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_iterator>
+
+Create an iterator. The type of iterator created depends on the arguments to
+the constructor:
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $filehandle );
+
+Creates a I<stream> iterator (see L</make_stream_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $array_reference );
+
+Creates an I<array> iterator (see L</make_array_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference );
+
+Creates a I<process> iterator (see L</make_process_iterator>).
+
+=cut
+
+sub make_iterator {
+ my ( $proto, $thing ) = @_;
+
+ my $ref = ref $thing;
+ if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+ return $proto->make_stream_iterator($thing);
+ }
+ elsif ( $ref eq 'ARRAY' ) {
+ return $proto->make_array_iterator($thing);
+ }
+ elsif ( $ref eq 'HASH' ) {
+ return $proto->make_process_iterator($thing);
+ }
+ else {
+ die "Can't iterate with a $ref";
+ }
+}
+
+=head3 C<make_stream_iterator>
+
+Make a new stream iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Stream>.
+
+=head3 C<make_array_iterator>
+
+Make a new array iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Array>.
+
+=head3 C<make_process_iterator>
+
+Make a new process iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Process>.
+
+=cut
+
+sub make_stream_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Stream->new(@_);
+}
+
+sub make_array_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Array->new(@_);
+}
+
+sub make_process_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Process->new(@_);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=back
+
+=head2 Example
+
+ package MyIteratorFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyStreamIterator;
+ use TAP::Parser::IteratorFactory;
+
+ @ISA = qw( TAP::Parser::IteratorFactory );
+
+ # override stream iterator
+ sub make_stream_iterator {
+ my $proto = shift;
+ MyStreamIterator->new(@_);
+ }
+
+ 1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Multiplexer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use IO::Select;
+use TAP::Object ();
+
+use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
+use constant IS_VMS => $^O eq 'VMS';
+use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+
+@ISA = 'TAP::Object';
+
+=head1 NAME
+
+TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Multiplexer;
+
+ my $mux = TAP::Parser::Multiplexer->new;
+ $mux->add( $parser1, $stash1 );
+ $mux->add( $parser2, $stash2 );
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+ # do stuff
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
+Internally it calls select on the input file handles for those parsers
+to wait for one or more of them to have input available.
+
+See L<TAP::Harness> for an example of its use.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $mux = TAP::Parser::Multiplexer->new;
+
+Returns a new C<TAP::Parser::Multiplexer> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ $self->{select} = IO::Select->new;
+ $self->{avid} = []; # Parsers that can't select
+ $self->{count} = 0;
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $mux->add( $parser, $stash );
+
+Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
+reference that will be returned from C<next> along with the parser and
+the next result.
+
+=cut
+
+sub add {
+ my ( $self, $parser, $stash ) = @_;
+
+ if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
+ my $sel = $self->{select};
+
+ # We have to turn handles into file numbers here because by
+ # the time we want to remove them from our IO::Select they
+ # will already have been closed by the iterator.
+ my @filenos = map { fileno $_ } @handles;
+ for my $h (@handles) {
+ $sel->add( [ $h, $parser, $stash, @filenos ] );
+ }
+
+ $self->{count}++;
+ }
+ else {
+ push @{ $self->{avid} }, [ $parser, $stash ];
+ }
+}
+
+=head3 C<parsers>
+
+ my $count = $mux->parsers;
+
+Returns the number of parsers. Parsers are removed from the multiplexer
+when their input is exhausted.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->{count} + scalar @{ $self->{avid} };
+}
+
+sub _iter {
+ my $self = shift;
+
+ my $sel = $self->{select};
+ my $avid = $self->{avid};
+ my @ready = ();
+
+ return sub {
+
+ # Drain all the non-selectable parsers first
+ if (@$avid) {
+ my ( $parser, $stash ) = @{ $avid->[0] };
+ my $result = $parser->next;
+ shift @$avid unless defined $result;
+ return ( $parser, $stash, $result );
+ }
+
+ unless (@ready) {
+ return unless $sel->count;
+ @ready = $sel->can_read;
+ }
+
+ my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
+ my $result = $parser->next;
+
+ unless ( defined $result ) {
+ $sel->remove(@handles);
+ $self->{count}--;
+
+ # Force another can_read - we may now have removed a handle
+ # thought to have been ready.
+ @ready = ();
+ }
+
+ return ( $parser, $stash, $result );
+ };
+}
+
+=head3 C<next>
+
+Return a result from the next available parser. Returns a list
+containing the parser from which the result came, the stash that
+corresponds with that parser and the result.
+
+ my ( $parser, $stash, $result ) = $mux->next;
+
+If C<$result> is undefined the corresponding parser has reached the end
+of its input (and will automatically be removed from the multiplexer).
+
+When all parsers are exhausted an empty list will be returned.
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ if ( ! defined $result ) {
+ # End of this parser
+ }
+ else {
+ # Process result
+ }
+ }
+ else {
+ # All parsers finished
+ }
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Result;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+
+BEGIN {
+
+ # make is_* methods
+ my @attrs = qw( plan pragma test comment bailout version unknown yaml );
+ no strict 'refs';
+ for my $token (@attrs) {
+ my $method = "is_$token";
+ *$method = sub { return $token eq shift->type };
+ }
+}
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::Result - Base class for TAP::Parser output objects
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # abstract class - not meany to be used directly
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # directly:
+ use TAP::Parser::Result;
+ my $token = {...};
+ my $result = TAP::Parser::Result->new( $token );
+
+=head2 DESCRIPTION
+
+This is a simple base class used by L<TAP::Parser> to store objects that
+represent the current bit of test output data from TAP (usually a single
+line). Unless you're subclassing, you probably won't need to use this module
+directly.
+
+=head2 METHODS
+
+=head3 C<new>
+
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # to use directly:
+ my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+# new() implementation provided by TAP::Object
+
+sub _initialize {
+ my ( $self, $token ) = @_;
+ if ($token) {
+
+ # assign to a hash slice to make a shallow copy of the token.
+ # I guess we could assign to the hash as (by default) there are not
+ # contents, but that seems less helpful if someone wants to subclass us
+ @{$self}{ keys %$token } = values %$token;
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Boolean methods
+
+The following methods all return a boolean value and are to be overridden in
+the appropriate subclass.
+
+=over 4
+
+=item * C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+ 1..3
+
+=item * C<is_pragma>
+
+Indicates whether or not this is a pragma line.
+
+ pragma +strict
+
+=item * C<is_test>
+
+Indicates whether or not this is a test line.
+
+ ok 1 Is OK!
+
+=item * C<is_comment>
+
+Indicates whether or not this is a comment.
+
+ # this is a comment
+
+=item * C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+ Bail out! We're out of dilithium crystals.
+
+=item * C<is_version>
+
+Indicates whether or not this is a TAP version line.
+
+ TAP version 4
+
+=item * C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+ ... this line is junk ...
+
+=item * C<is_yaml>
+
+Indicates whether or not this is a YAML chunk.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head3 C<raw>
+
+ print $result->raw;
+
+Returns the original line of text which was parsed.
+
+=cut
+
+sub raw { shift->{raw} }
+
+##############################################################################
+
+=head3 C<type>
+
+ my $type = $result->type;
+
+Returns the "type" of a token, such as C<comment> or C<test>.
+
+=cut
+
+sub type { shift->{type} }
+
+##############################################################################
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=cut
+
+sub as_string { shift->{raw} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut.
+
+=cut
+
+sub is_ok {1}
+
+##############################################################################
+
+=head3 C<passed>
+
+Deprecated. Please use C<is_ok> instead.
+
+=cut
+
+sub passed {
+ warn 'passed() is deprecated. Please use "is_ok()"';
+ shift->is_ok;
+}
+
+##############################################################################
+
+=head3 C<has_directive>
+
+ if ( $result->has_directive ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO or SKIP directive.
+
+=cut
+
+sub has_directive {
+ my $self = shift;
+ return ( $self->has_todo || $self->has_skip );
+}
+
+##############################################################################
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO directive.
+
+=cut
+
+sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) {
+ ...
+ }
+
+Indicates whether or not the given result has a SKIP directive.
+
+=cut
+
+sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
+
+=head3 C<set_directive>
+
+Set the directive associated with this token. Used internally to fake
+TODO tests.
+
+=cut
+
+sub set_directive {
+ my ( $self, $dir ) = @_;
+ $self->{directive} = $dir;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+Remember: if you want your subclass to be automatically used by the parser,
+you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
+
+If you're creating a completely new result I<type>, you'll probably need to
+subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
+
+=head2 Example
+
+ package MyResult;
+
+ use strict;
+ use vars '@ISA';
+
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ sub as_string { 'My results all look the same' }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::ResultFactory>,
+L<TAP::Parser::Result::Bailout>,
+L<TAP::Parser::Result::Comment>,
+L<TAP::Parser::Result::Plan>,
+L<TAP::Parser::Result::Pragma>,
+L<TAP::Parser::Result::Test>,
+L<TAP::Parser::Result::Unknown>,
+L<TAP::Parser::Result::Version>,
+L<TAP::Parser::Result::YAML>,
+
+=cut
--- /dev/null
+package TAP::Parser::Result::Bailout;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Bailout - Bailout result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a bail out line is encountered.
+
+ 1..5
+ ok 1 - woo hooo!
+ Bail out! Well, so much for "woo hooo!"
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=cut
+
+sub explanation { shift->{bailout} }
+sub as_string { shift->{bailout} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Comment;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Comment - Comment result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a comment line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+ # this is a comment
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+Note that this method merely returns the comment preceded by a '# '.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=cut
+
+sub comment { shift->{comment} }
+sub as_string { shift->{raw} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Plan;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Plan - Plan result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a plan line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub plan { '1..' . shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<tests_planned>
+
+ my $planned = $result->tests_planned;
+
+Returns the number of tests planned. For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=cut
+
+sub tests_planned { shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $plan->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<explanation>
+
+ my $explanation = $plan->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+=head3 C<todo_list>
+
+ my $todo = $result->todo_list;
+ for ( @$todo ) {
+ ...
+ }
+
+=cut
+
+sub todo_list { shift->{todo_list} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Pragma;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Pragma - TAP pragma token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a pragma is encountered.
+
+ TAP version 13
+ pragma +strict, -foo
+
+Pragmas are only supported from TAP version 13 onwards.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<pragmas>
+
+if ( $result->is_pragma ) {
+ @pragmas = $result->pragmas;
+}
+
+=cut
+
+sub pragmas {
+ my @pragmas = @{ shift->{pragmas} };
+ return wantarray ? @pragmas : \@pragmas;
+}
+
+1;
--- /dev/null
+package TAP::Parser::Result::Test;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system. Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+ my ( $self, $number ) = @_;
+ $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false. See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+ my $self = shift;
+
+ return if $self->is_unplanned;
+
+ # TODO directives reverse the sense of a test.
+ return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+ my $self = shift;
+ return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated. Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+ warn 'actual_passed() is deprecated. Please use "is_actual_ok()"';
+ goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+ if ( $test->todo_passed ) {
+ # test unexpectedly succeeded
+ }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+ my $self = shift;
+ return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn 'todo_failed() is deprecated. Please use "todo_passed()"';
+ goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+This method prints the test as a string. It will probably be similar, but
+not necessarily identical, to the original test line. Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line. If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ my $string = $self->ok . " " . $self->number;
+ if ( my $description = $self->description ) {
+ $string .= " $description";
+ }
+ if ( my $directive = $self->directive ) {
+ my $explanation = $self->explanation;
+ $string .= " # $directive $explanation";
+ }
+ return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+ $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+ print <<'END';
+ ok 1
+ ok 2
+ 1..1
+ END
+
+=cut
+
+sub is_unplanned {
+ my $self = shift;
+ return ( $self->{unplanned} || '' ) unless @_;
+ $self->{unplanned} = !!shift;
+ return $self;
+}
+
+1;
--- /dev/null
+package TAP::Parser::Result::Unknown;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Unknown - Unknown result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if the parser does not recognize the token line. For example:
+
+ 1..5
+ VERSION 7
+ ok 1 - woo hooo!
+ ... woo hooo! is cool!
+
+In the above "TAP", the second and fourth lines will generate "Unknown"
+tokens.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Result::Version;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Version - TAP syntax version token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a version line is encountered.
+
+ TAP version 13
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 13.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<version>
+
+ if ( $result->is_version ) {
+ print $result->version;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub version { shift->{version} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::YAML;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::YAML - YAML result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a YAML block is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<data>
+
+ if ( $result->is_yaml ) {
+ print $result->data;
+ }
+
+Return the parsed YAML data for this result
+
+=cut
+
+sub data { shift->{data} }
+
+1;
--- /dev/null
+package TAP::Parser::ResultFactory;
+
+use strict;
+use vars qw($VERSION @ISA %CLASS_FOR);
+
+use TAP::Object ();
+use TAP::Parser::Result::Bailout ();
+use TAP::Parser::Result::Comment ();
+use TAP::Parser::Result::Plan ();
+use TAP::Parser::Result::Pragma ();
+use TAP::Parser::Result::Test ();
+use TAP::Parser::Result::Unknown ();
+use TAP::Parser::Result::Version ();
+use TAP::Parser::Result::YAML ();
+
+@ISA = 'TAP::Object';
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::ResultFactory;
+ my $token = {...};
+ my $factory = TAP::Parser::ResultFactory->new;
+ my $result = $factory->make_result( $token );
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head2 DESCRIPTION
+
+This is a simple factory class which returns a L<TAP::Parser::Result> subclass
+representing the current bit of test data from TAP (usually a single line).
+It is used primarily by L<TAP::Parser::Grammar>. Unless you're subclassing,
+you probably won't need to use this module directly.
+
+=head2 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_result>
+
+Returns an instance the appropriate class for the test token passed in.
+
+ my $result = TAP::Parser::ResultFactory->make_result($token);
+
+Can also be called as an instance method.
+
+=cut
+
+sub make_result {
+ my ( $proto, $token ) = @_;
+ my $type = $token->{type};
+ return $proto->class_for($type)->new($token);
+}
+
+=head3 C<class_for>
+
+Takes one argument: C<$type>. Returns the class for this $type, or C<croak>s
+with an error.
+
+=head3 C<register_type>
+
+Takes two arguments: C<$type>, C<$class>
+
+This lets you override an existing type with your own custom type, or register
+a completely new type, eg:
+
+ # create a custom result type:
+ package MyResult;
+ use strict;
+ use vars qw(@ISA);
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ # use it:
+ my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
+
+Your custom type should then be picked up automatically by the L<TAP::Parser>.
+
+=cut
+
+BEGIN {
+ %CLASS_FOR = (
+ plan => 'TAP::Parser::Result::Plan',
+ pragma => 'TAP::Parser::Result::Pragma',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+ );
+}
+
+sub class_for {
+ my ( $class, $type ) = @_;
+
+ # return target class:
+ return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
+
+ # or complain:
+ require Carp;
+ Carp::croak("Could not determine class for result type '$type'");
+}
+
+sub register_type {
+ my ( $class, $type, $rclass ) = @_;
+
+ # register it blindly, assume they know what they're doing
+ $CLASS_FOR{$type} = $rclass;
+ return $class;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=item 2
+
+C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
+This I<will> change in a future version!
+
+=item 3
+
+L<TAP::Parser::Result> subclasses will register themselves with
+L<TAP::Parser::ResultFactory> directly:
+
+ package MyFooResult;
+ TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
+
+Of course, it's up to you to decide whether or not to ignore them.
+
+=back
+
+=head2 Example
+
+ package MyResultFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyResult;
+ use TAP::Parser::ResultFactory;
+
+ @ISA = qw( TAP::Parser::ResultFactory );
+
+ # force all results to be 'MyResult'
+ sub class_for {
+ return 'MyResult';
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<TAP::Parser>,
+L<TAP::Parser::Result>,
+L<TAP::Parser::Grammar>
+
+=cut
--- /dev/null
+package TAP::Parser::Scheduler;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use TAP::Parser::Scheduler::Job;
+use TAP::Parser::Scheduler::Spinner;
+
+=head1 NAME
+
+TAP::Parser::Scheduler - Schedule tests during parallel testing
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $sched = TAP::Parser::Scheduler->new;
+
+Returns a new C<TAP::Parser::Scheduler> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ croak "Need a number of key, value pairs" if @_ % 2;
+
+ my %args = @_;
+ my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+ my $rules = delete $args{rules} || { par => '**' };
+
+ croak "Unknown arg(s): ", join ', ', sort keys %args
+ if keys %args;
+
+ # Turn any simple names into a name, description pair. TODO: Maybe
+ # construct jobs here?
+ my $self = bless {}, $class;
+
+ $self->_set_rules( $rules, $tests );
+
+ return $self;
+}
+
+# Build the scheduler data structure.
+#
+# SCHEDULER-DATA ::= JOB
+# || ARRAY OF ARRAY OF SCHEDULER-DATA
+#
+# The nested arrays are the key to scheduling. The outer array contains
+# a list of things that may be executed in parallel. Whenever an
+# eligible job is sought any element of the outer array that is ready to
+# execute can be selected. The inner arrays represent sequential
+# execution. They can only proceed when the first job is ready to run.
+
+sub _set_rules {
+ my ( $self, $rules, $tests ) = @_;
+ my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
+ map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+ my $schedule = $self->_rule_clause( $rules, \@tests );
+
+ # If any tests are left add them as a sequential block at the end of
+ # the run.
+ $schedule = [ [ $schedule, @tests ] ] if @tests;
+
+ $self->{schedule} = $schedule;
+}
+
+sub _rule_clause {
+ my ( $self, $rule, $tests ) = @_;
+ croak 'Rule clause must be a hash'
+ unless 'HASH' eq ref $rule;
+
+ my @type = keys %$rule;
+ croak 'Rule clause must have exactly one key'
+ unless @type == 1;
+
+ my %handlers = (
+ par => sub {
+ [ map { [$_] } @_ ];
+ },
+ seq => sub { [ [@_] ] },
+ );
+
+ my $handler = $handlers{ $type[0] }
+ || croak 'Unknown scheduler type: ', $type[0];
+ my $val = $rule->{ $type[0] };
+
+ return $handler->(
+ map {
+ 'HASH' eq ref $_
+ ? $self->_rule_clause( $_, $tests )
+ : $self->_expand( $_, $tests )
+ } 'ARRAY' eq ref $val ? @$val : $val
+ );
+}
+
+sub _glob_to_regexp {
+ my ( $self, $glob ) = @_;
+ my $nesting;
+ my $pattern;
+
+ while (1) {
+ if ( $glob =~ /\G\*\*/gc ) {
+
+ # ** is any number of characters, including /, within a pathname
+ $pattern .= '.*?';
+ }
+ elsif ( $glob =~ /\G\*/gc ) {
+
+ # * is zero or more characters within a filename/directory name
+ $pattern .= '[^/]*';
+ }
+ elsif ( $glob =~ /\G\?/gc ) {
+
+ # ? is exactly one character within a filename/directory name
+ $pattern .= '[^/]';
+ }
+ elsif ( $glob =~ /\G\{/gc ) {
+
+ # {foo,bar,baz} is any of foo, bar or baz.
+ $pattern .= '(?:';
+ ++$nesting;
+ }
+ elsif ( $nesting and $glob =~ /\G,/gc ) {
+
+ # , is only special inside {}
+ $pattern .= '|';
+ }
+ elsif ( $nesting and $glob =~ /\G\}/gc ) {
+
+ # } that matches { is special. But unbalanced } are not.
+ $pattern .= ')';
+ --$nesting;
+ }
+ elsif ( $glob =~ /\G(\\.)/gc ) {
+
+ # A quoted literal
+ $pattern .= $1;
+ }
+ elsif ( $glob =~ /\G([\},])/gc ) {
+
+ # Sometimes meta characters
+ $pattern .= '\\' . $1;
+ }
+ else {
+
+ # Eat everything that is not a meta character.
+ $glob =~ /\G([^{?*\\\},]*)/gc;
+ $pattern .= quotemeta $1;
+ }
+ return $pattern if pos $glob == length $glob;
+ }
+}
+
+sub _expand {
+ my ( $self, $name, $tests ) = @_;
+
+ my $pattern = $self->_glob_to_regexp($name);
+ $pattern = qr/^ $pattern $/x;
+ my @match = ();
+
+ for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+ if ( $tests->[$ti]->filename =~ $pattern ) {
+ push @match, splice @$tests, $ti, 1;
+ $ti--;
+ }
+ }
+
+ return @match;
+}
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+ my $self = shift;
+ my @all = $self->_gather( $self->{schedule} );
+ $self->{count} = @all;
+ @all;
+}
+
+sub _gather {
+ my ( $self, $rule ) = @_;
+ return unless defined $rule;
+ return $rule unless 'ARRAY' eq ref $rule;
+ return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job or C<undef> if none are available. Returns
+a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
+jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+ my $self = shift;
+ $self->{count} ||= $self->get_all;
+ my @jobs = $self->_find_next_job( $self->{schedule} );
+ if (@jobs) {
+ --$self->{count};
+ return $jobs[0];
+ }
+
+ return TAP::Parser::Scheduler::Spinner->new
+ if $self->{count};
+
+ return;
+}
+
+sub _not_empty {
+ my $ar = shift;
+ return 1 unless 'ARRAY' eq ref $ar;
+ foreach (@$ar) {
+ return 1 if _not_empty($_);
+ }
+ return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+ my ( $self, $rule ) = @_;
+
+ my @queue = ();
+ my $index = 0;
+ while ( $index < @$rule ) {
+ my $seq = $rule->[$index];
+
+ # Prune any exhausted items.
+ shift @$seq while @$seq && _is_empty( $seq->[0] );
+ if (@$seq) {
+ if ( defined $seq->[0] ) {
+ if ( 'ARRAY' eq ref $seq->[0] ) {
+ push @queue, $seq;
+ }
+ else {
+ my $job = splice @$seq, 0, 1, undef;
+ $job->on_finish( sub { shift @$seq } );
+ return $job;
+ }
+ }
+ ++$index;
+ }
+ else {
+
+ # Remove the empty sub-array from the array
+ splice @$rule, $index, 1;
+ }
+ }
+
+ for my $seq (@queue) {
+ if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
+ return @jobs;
+ }
+ }
+
+ return;
+}
+
+=head3 C<as_string>
+
+Return a human readable representation of the scheduling tree.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ return $self->_as_string( $self->{schedule} );
+}
+
+sub _as_string {
+ my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
+ my $pad = ' ' x 2;
+ my $indent = $pad x $depth;
+ if ( !defined $rule ) {
+ return "$indent(undef)\n";
+ }
+ elsif ( 'ARRAY' eq ref $rule ) {
+ return unless @$rule;
+ my $type = ( 'par', 'seq' )[ $depth % 2 ];
+ return join(
+ '', "$indent$type:\n",
+ map { $self->_as_string( $_, $depth + 1 ) } @$rule
+ );
+ }
+ else {
+ return "$indent'" . $rule->filename . "'\n";
+ }
+}
+
+1;
--- /dev/null
+package TAP::Parser::Scheduler::Job;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Job - A single testing job.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Job;
+
+=head1 DESCRIPTION
+
+Represents a single test 'job'.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Job->new(
+ $name, $desc
+ );
+
+Returns a new C<TAP::Parser::Scheduler::Job> object.
+
+=cut
+
+sub new {
+ my ( $class, $name, $desc, @ctx ) = @_;
+ return bless {
+ filename => $name,
+ description => $desc,
+ @ctx ? ( context => \@ctx ) : (),
+ }, $class;
+}
+
+=head3 C<on_finish>
+
+Register a closure to be called when this job is destroyed.
+
+=cut
+
+sub on_finish {
+ my ( $self, $cb ) = @_;
+ $self->{on_finish} = $cb;
+}
+
+=head3 C<finish>
+
+Called when a job is complete to unlock it.
+
+=cut
+
+sub finish {
+ my $self = shift;
+ if ( my $cb = $self->{on_finish} ) {
+ $cb->($self);
+ }
+}
+
+=head3 C<filename>
+
+=head3 C<description>
+
+=head3 C<context>
+
+=cut
+
+sub filename { shift->{filename} }
+sub description { shift->{description} }
+sub context { @{ shift->{context} || [] } }
+
+=head3 C<as_array_ref>
+
+For backwards compatibility in callbacks.
+
+=cut
+
+sub as_array_ref {
+ my $self = shift;
+ return [ $self->filename, $self->description, $self->{context} ||= [] ];
+}
+
+=head3 C<is_spinner>
+
+Returns false indicating that this is a real job rather than a
+'spinner'. Spinners are returned when the scheduler still has pending
+jobs but can't (because of locking) return one right now.
+
+=cut
+
+sub is_spinner {0}
+
+1;
--- /dev/null
+package TAP::Parser::Scheduler::Spinner;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Spinner - A no-op job.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Spinner;
+
+=head1 DESCRIPTION
+
+A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
+the harness to spin (keep executing tests) while the scheduler can't
+return a real job.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Spinner->new;
+
+Returns a new C<TAP::Parser::Scheduler::Spinner> object.
+
+=cut
+
+sub new { bless {}, shift }
+
+=head3 C<is_spinner>
+
+Returns true indicating that is a 'spinner' job. Spinners are returned
+when the scheduler still has pending jobs but can't (because of locking)
+return one right now.
+
+=cut
+
+sub is_spinner {1}
+
+1;
--- /dev/null
+package TAP::Parser::Source;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::IteratorFactory ();
+
+@ISA = qw(TAP::Object);
+
+# Causes problem on MacOS and shouldn't be necessary anyway
+#$SIG{CHLD} = sub { wait };
+
+=head1 NAME
+
+TAP::Parser::Source - Stream output from some source
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new;
+ my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a command and hopefully returns a stream from it.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{switches} = [];
+ _autoflush( \*STDOUT );
+ _autoflush( \*STDERR );
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+ my $source = $source->source;
+ $source->source(['./some_prog some_test_file']);
+
+ # or
+ $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
+
+Getter/setter for the source. The source should generally consist of an array
+reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>,
+should return a filehandle which returns successive rows of TAP. C<croaks> if
+it doesn't get an arrayref.
+
+=cut
+
+sub source {
+ my $self = shift;
+ return $self->{source} unless @_;
+ unless ( 'ARRAY' eq ref $_[0] ) {
+ $self->_croak('Argument to &source must be an array reference');
+ }
+ $self->{source} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream;
+
+Returns a L<TAP::Parser::Iterator> stream of the output generated by executing
+C<source>. C<croak>s if there was no command found.
+
+Must be passed an object that implements a C<make_iterator> method.
+Typically this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+ my @command = $self->_get_command
+ or $self->_croak('No command found!');
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge
+ }
+ );
+}
+
+sub _get_command { return @{ shift->source || [] } }
+
+##############################################################################
+
+=head3 C<merge>
+
+ my $merge = $source->merge;
+
+Sets or returns the flag that dictates whether STDOUT and STDERR are merged.
+
+=cut
+
+sub merge {
+ my $self = shift;
+ return $self->{merge} unless @_;
+ $self->{merge} = shift;
+ return $self;
+}
+
+# Turns on autoflush for the handle passed
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyRubySource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source;
+
+ @ISA = qw( TAP::Parser::Source );
+
+ # expect $source->(['mytest.rb', 'cmdline', 'args']);
+ sub source {
+ my ($self, $args) = @_;
+ my ($rb_file) = @$args;
+ croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+ return $self->SUPER::source(['/usr/bin/ruby', @$args]);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source::Perl>,
+
+=cut
+
--- /dev/null
+package TAP::Parser::Source::Perl;
+
+use strict;
+use Config;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::Source;
+use TAP::Parser::Utils qw( split_shell );
+
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new;
+ my $stream = $perl->source( [ $filename, @args ] )->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a filename and hopefully returns a stream from it. The filename should
+be the name of a Perl program.
+
+Note that this is a subclass of L<TAP::Parser::Source>. See that module for
+more methods.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+Returns a new C<TAP::Parser::Source::Perl> object.
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+Getter/setter the name of the test program and any arguments it requires.
+
+ my ($filename, @args) = @{ $perl->source };
+ $perl->source( [ $filename, @args ] );
+
+C<croak>s if C<$filename> could not be found.
+
+=cut
+
+sub source {
+ my $self = shift;
+ $self->_croak("Cannot find ($_[0][0])")
+ if @_ && !-f $_[0][0];
+ return $self->SUPER::source(@_);
+}
+
+=head3 C<switches>
+
+ my $switches = $perl->switches;
+ my @switches = $perl->switches;
+ $perl->switches( \@switches );
+
+Getter/setter for the additional switches to pass to the perl executable. One
+common switch would be to set an include directory:
+
+ $perl->switches( ['-Ilib'] );
+
+=cut
+
+sub switches {
+ my $self = shift;
+ unless (@_) {
+ return wantarray ? @{ $self->{switches} } : $self->{switches};
+ }
+ my $switches = shift;
+ $self->{switches} = [@$switches]; # force a copy
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream($parser);
+
+Returns a stream of the output generated by executing C<source>. Must be
+passed an object that implements a C<make_iterator> method. Typically
+this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+
+ my @switches = $self->_switches;
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+
+ # Filter out any -I switches to be handled as libs later.
+ #
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ #
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ my @filtered_switches;
+ for (@switches) {
+ if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+ push @libs, $1;
+ }
+ else {
+ push @filtered_switches, $_;
+ }
+ }
+ @switches = @filtered_switches;
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB}
+ = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $previous = $ENV{PERL5LIB};
+ my $teardown = sub {
+ if ( defined $previous ) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ # Taint mode ignores environment variables so we must retranslate
+ # PERL5LIB as -I switches and place PERL5OPT on the command line
+ # in order that it be seen.
+ if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
+ push @switches, $self->_libs2switches(@libs);
+ push @switches, split_shell( $ENV{PERL5OPT} );
+ }
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my $self = shift;
+ my @switches = @_;
+ my ( $file, @args ) = @{ $self->source };
+ my $command = $self->_get_perl;
+
+# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
+#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file, @args );
+ return @command;
+}
+
+sub _get_command {
+ my $self = shift;
+ return $self->_get_command_for_switches( $self->_switches );
+}
+
+sub _libs2switches {
+ my $self = shift;
+ return map {"-I$_"} grep {$_} @_;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my $file = shift;
+ local *TEST;
+ my $shebang;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ close(TEST) or print "Can't close $file. $!\n";
+ }
+ else {
+ print "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ unless ( exists $shebang_for{$file} ) {
+ $shebang_for{$file} = _read_shebang($file);
+ }
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
+sub _switches {
+ my $self = shift;
+ my ( $file, @args ) = @{ $self->source };
+ my @switches = (
+ $self->switches,
+ );
+
+ my $shebang = $self->shebang($file);
+ return unless defined $shebang;
+
+ my $taint = $self->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
+
+ # Quote the argument if we're VMS, since VMS will downcase anything
+ # not quoted.
+ if (IS_VMS) {
+ for (@switches) {
+ $_ = qq["$_"];
+ }
+ }
+
+ return @switches;
+}
+
+sub _get_perl {
+ my $self = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyPerlSource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source::Perl;
+
+ @ISA = qw( TAP::Parser::Source::Perl );
+
+ sub source {
+ my ($self, $args) = @_;
+ if ($args) {
+ $self->{file} = $args->[0];
+ return $self->SUPER::source($args);
+ }
+ return $self->SUPER::source;
+ }
+
+ # use the version of perl from the shebang line in the test file
+ sub _get_perl {
+ my $self = shift;
+ if (my $shebang = $self->shebang( $self->{file} )) {
+ $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+ return $1 if $1;
+ }
+ return $self->SUPER::_get_perl(@_);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+
+=cut
--- /dev/null
+package TAP::Parser::Utils;
+
+use strict;
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( split_shell );
+
+=head1 NAME
+
+TAP::Parser::Utils - Internal TAP::Parser utilities
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Utils qw( split_shell )
+ my @switches = split_shell( $arg );
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+=head2 INTERFACE
+
+=head3 C<split_shell>
+
+Shell style argument parsing. Handles backslash escaping, single and
+double quoted strings but not shell substitutions.
+
+Pass one or more strings containing shell escaped arguments. The return
+value is an array of arguments parsed from the input strings according
+to (approximate) shell parsing rules. It's legal to pass C<undef> in
+which case an empty array will be returned. That makes it possible to
+
+ my @args = split_shell( $ENV{SOME_ENV_VAR} );
+
+without worrying about whether the environment variable exists.
+
+This is used to split HARNESS_PERL_ARGS into individual switches.
+
+=cut
+
+sub split_shell {
+ my @parts = ();
+
+ for my $switch ( grep defined && length, @_ ) {
+ push @parts, $1 while $switch =~ /
+ (
+ (?: [^\\"'\s]+
+ | \\.
+ | " (?: \\. | [^"] )* "
+ | ' (?: \\. | [^'] )* '
+ )+
+ ) /xg;
+ }
+
+ for (@parts) {
+ s/ \\(.) | ['"] /defined $1 ? $1 : ''/exg;
+ }
+
+ return @parts;
+}
+
+1;
--- /dev/null
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
+
+# TODO:
+# Handle blessed object syntax
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
+my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
+my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
+my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
+my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
+
+# new() implementation supplied by TAP::Object
+
+sub read {
+ my $self = shift;
+ my $obj = shift;
+
+ die "Must have a code reference to read input from"
+ unless ref $obj eq 'CODE';
+
+ $self->{reader} = $obj;
+ $self->{capture} = [];
+
+ #Â Prime the reader
+ $self->_next;
+ return unless $self->{next};
+
+ my $doc = $self->_read;
+
+ # The terminator is mandatory otherwise we'd consume a line from the
+ # iterator that doesn't belong to us. If we want to remove this
+ # restriction we'll have to implement look-ahead in the iterators.
+ # Which might not be a bad idea.
+ my $dots = $self->_peek;
+ die "Missing '...' at end of YAMLish"
+ unless defined $dots
+ and $dots =~ $IS_END_YAML;
+
+ delete $self->{reader};
+ delete $self->{next};
+
+ return $doc;
+}
+
+sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
+
+sub _peek {
+ my $self = shift;
+ return $self->{next} unless wantarray;
+ my $line = $self->{next};
+ $line =~ /^ (\s*) (.*) $ /x;
+ return ( $2, length $1 );
+}
+
+sub _next {
+ my $self = shift;
+ die "_next called with no reader"
+ unless $self->{reader};
+ my $line = $self->{reader}->();
+ $self->{next} = $line;
+ push @{ $self->{capture} }, $line;
+}
+
+sub _read {
+ my $self = shift;
+
+ my $line = $self->_peek;
+
+ # Do we have a document header?
+ if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) {
+ $self->_next;
+
+ return $self->_read_scalar($1) if defined $1; # Inline?
+
+ my ( $next, $indent ) = $self->_peek;
+
+ if ( $next =~ /^ - /x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $next =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $next, $indent );
+ }
+ elsif ( $next =~ $IS_END_YAML ) {
+ die "Premature end of YAMLish";
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$next'";
+ }
+ }
+ else {
+ die "YAMLish document header not found";
+ }
+}
+
+# Parse a double quoted string
+sub _read_qq {
+ my $self = shift;
+ my $str = shift;
+
+ unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
+ die "Internal: not a quoted string";
+ }
+
+ $str =~ s/\\"/"/gx;
+ $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
+ / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
+ return $str;
+}
+
+# Parse a scalar string to the actual scalar
+sub _read_scalar {
+ my $self = shift;
+ my $string = shift;
+
+ return undef if $string eq '~';
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ if ( $string eq '>' || $string eq '|' ) {
+
+ my ( $line, $indent ) = $self->_peek;
+ die "Multi-line scalar content missing" unless defined $line;
+
+ my @multiline = ($line);
+
+ while (1) {
+ $self->_next;
+ my ( $next, $ind ) = $self->_peek;
+ last if $ind < $indent;
+
+ my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
+ push @multiline, $pad . $next;
+ }
+
+ return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
+ }
+
+ if ( $string =~ /^ ' (.*) ' $/x ) {
+ ( my $rv = $1 ) =~ s/''/'/g;
+ return $rv;
+ }
+
+ if ( $string =~ $IS_QQ_STRING ) {
+ return $self->_read_qq($string);
+ }
+
+ if ( $string =~ /^['"]/ ) {
+
+ # A quote with folding... we don't support that
+ die __PACKAGE__ . " does not support multi-line quoted scalars";
+ }
+
+ # Regular unquoted string
+ return $string;
+}
+
+sub _read_nested {
+ my $self = shift;
+
+ my ( $line, $indent ) = $self->_peek;
+
+ if ( $line =~ /^ -/x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $line, $indent );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+}
+
+# Parse an array
+sub _read_array {
+ my ( $self, $limit ) = @_;
+
+ my $ar = [];
+
+ while (1) {
+ my ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+
+ if ( $indent > $limit ) {
+ die "Array line over-indented";
+ }
+
+ if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
+ $indent += length $1;
+ $line =~ s/-\s+//;
+ push @$ar, $self->_read_hash( $line, $indent );
+ }
+ elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
+ die "Unexpected start of YAMLish" if $line =~ /^---/;
+ $self->_next;
+ push @$ar, $self->_read_scalar($1);
+ }
+ elsif ( $line =~ /^ - \s* $/x ) {
+ $self->_next;
+ push @$ar, $self->_read_nested;
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ $self->_next;
+ push @$ar, $self->_read_hash( $line, $indent, );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+ }
+
+ return $ar;
+}
+
+sub _read_hash {
+ my ( $self, $line, $limit ) = @_;
+
+ my $indent;
+ my $hash = {};
+
+ while (1) {
+ die "Badly formed hash line: '$line'"
+ unless $line =~ $HASH_LINE;
+
+ my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
+ $self->_next;
+
+ if ( defined $value ) {
+ $hash->{$key} = $self->_read_scalar($value);
+ }
+ else {
+ $hash->{$key} = $self->_read_nested;
+ }
+
+ ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+ }
+
+ return $hash;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Note that parts of this code were derived from L<YAML::Tiny> with the
+permission of Adam Kennedy.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Reader> object.
+
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+
+=head2 Instance Methods
+
+=head3 C<read>
+
+ my $got = $reader->read($stream);
+
+Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
+represents.
+
+=head3 C<get_raw>
+
+ my $source = $reader->get_source;
+
+Return the raw YAMLish source from the most recent C<read>.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
+the YAML matching regular expressions for this module.
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+Portions copyright 2006-2008 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
--- /dev/null
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
+my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
+
+my @UNPRINTABLE = qw(
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1a e x1c x1d x1e x1f
+);
+
+# new() implementation supplied by TAP::Object
+
+sub write {
+ my $self = shift;
+
+ die "Need something to write"
+ unless @_;
+
+ my $obj = shift;
+ my $out = shift || \*STDOUT;
+
+ die "Need a reference to something I can write to"
+ unless ref $out;
+
+ $self->{writer} = $self->_make_writer($out);
+
+ $self->_write_obj( '---', $obj );
+ $self->_put('...');
+
+ delete $self->{writer};
+}
+
+sub _make_writer {
+ my $self = shift;
+ my $out = shift;
+
+ my $ref = ref $out;
+
+ if ( 'CODE' eq $ref ) {
+ return $out;
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ return sub { push @$out, shift };
+ }
+ elsif ( 'SCALAR' eq $ref ) {
+ return sub { $$out .= shift() . "\n" };
+ }
+ elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
+ return sub { print $out shift(), "\n" };
+ }
+
+ die "Can't write to $out";
+}
+
+sub _put {
+ my $self = shift;
+ $self->{writer}->( join '', @_ );
+}
+
+sub _enc_scalar {
+ my $self = shift;
+ my $val = shift;
+ my $rule = shift;
+
+ return '~' unless defined $val;
+
+ if ( $val =~ /$rule/ ) {
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/"/\\"/g;
+ $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
+ return qq{"$val"};
+ }
+
+ if ( length($val) == 0 or $val =~ /\s/ ) {
+ $val =~ s/'/''/;
+ return "'$val'";
+ }
+
+ return $val;
+}
+
+sub _write_obj {
+ my $self = shift;
+ my $prefix = shift;
+ my $obj = shift;
+ my $indent = shift || 0;
+
+ if ( my $ref = ref $obj ) {
+ my $pad = ' ' x $indent;
+ if ( 'HASH' eq $ref ) {
+ if ( keys %$obj ) {
+ $self->_put($prefix);
+ for my $key ( sort keys %$obj ) {
+ my $value = $obj->{$key};
+ $self->_write_obj(
+ $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
+ $value, $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' {}' );
+ }
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ if (@$obj) {
+ $self->_put($prefix);
+ for my $value (@$obj) {
+ $self->_write_obj(
+ $pad . '-', $value,
+ $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' []' );
+ }
+ }
+ else {
+ die "Don't know how to encode $ref";
+ }
+ }
+ else {
+ $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 3.17
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::YAMLish::Writer;
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+
+ # Write to an array...
+ $yw->write( $data, \@some_array );
+
+ # ...an open file handle...
+ $yw->write( $data, $some_file_handle );
+
+ # ...a string ...
+ $yw->write( $data, \$some_string );
+
+ # ...or a closure
+ $yw->write( $data, sub {
+ my $line = shift;
+ print "$line\n";
+ } );
+
+=head1 DESCRIPTION
+
+Encodes a scalar, hash reference or array reference as YAMLish.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Writer> object.
+
+=head2 Instance Methods
+
+=head3 C<write>
+
+ $writer->write($obj, $output );
+
+Encode a scalar, hash reference or array reference as YAML.
+
+ my $writer = sub {
+ my $line = shift;
+ print SOMEFILE "$line\n";
+ };
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+ $yw->write( $data, $writer );
+
+
+The C< $output > argument may be:
+
+=over
+
+=item * a reference to a scalar to append YAML to
+
+=item * the handle of an open file
+
+=item * a reference to an array into which YAML will be pushed
+
+=item * a code reference
+
+=back
+
+If you supply a code reference the subroutine will be called once for
+each line of output with the line as its only argument. Passed lines
+will have no trailing newline.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
--- /dev/null
+=head1 NAME
+
+Test::Tutorial - A tutorial about writing really basic tests
+
+=head1 DESCRIPTION
+
+
+I<AHHHHHHH!!!! NOT TESTING! Anything but testing!
+Beat me, whip me, send me to Detroit, but don't make
+me write tests!>
+
+I<*sob*>
+
+I<Besides, I don't know how to write the damned things.>
+
+
+Is this you? Is writing tests right up there with writing
+documentation and having your fingernails pulled out? Did you open up
+a test and read
+
+ ######## We start with some black magic
+
+and decide that's quite enough for you?
+
+It's ok. That's all gone now. We've done all the black magic for
+you. And here are the tricks...
+
+
+=head2 Nuts and bolts of testing.
+
+Here's the most basic test program.
+
+ #!/usr/bin/perl -w
+
+ print "1..1\n";
+
+ print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n";
+
+since 1 + 1 is 2, it prints:
+
+ 1..1
+ ok 1
+
+What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1>
+"The first test passed". And that's about all magic there is to
+testing. Your basic unit of testing is the I<ok>. For each thing you
+test, an C<ok> is printed. Simple. B<Test::Harness> interprets your test
+results to determine if you succeeded or failed (more on that later).
+
+Writing all these print statements rapidly gets tedious. Fortunately,
+there's B<Test::Simple>. It has one function, C<ok()>.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 1;
+
+ ok( 1 + 1 == 2 );
+
+and that does the same thing as the code above. C<ok()> is the backbone
+of Perl testing, and we'll be using it instead of roll-your-own from
+here on. If C<ok()> gets a true value, the test passes. False, it
+fails.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 2;
+ ok( 1 + 1 == 2 );
+ ok( 2 + 2 == 5 );
+
+from that comes
+
+ 1..2
+ ok 1
+ not ok 2
+ # Failed test (test.pl at line 5)
+ # Looks like you failed 1 tests of 2.
+
+C<1..2> "I'm going to run two tests." This number is used to ensure
+your test program ran all the way through and didn't die or skip some
+tests. C<ok 1> "The first test passed." C<not ok 2> "The second test
+failed". Test::Simple helpfully prints out some extra commentary about
+your tests.
+
+It's not scary. Come, hold my hand. We're going to give an example
+of testing a module. For our example, we'll be testing a date
+library, B<Date::ICal>. It's on CPAN, so download a copy and follow
+along. [2]
+
+
+=head2 Where to start?
+
+This is the hardest part of testing, where do you start? People often
+get overwhelmed at the apparent enormity of the task of testing a
+whole module. Best place to start is at the beginning. Date::ICal is
+an object-oriented module, and that means you start by making an
+object. So we test C<new()>.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 2;
+
+ use Date::ICal;
+
+ my $ical = Date::ICal->new; # create an object
+ ok( defined $ical ); # check that we got something
+ ok( $ical->isa('Date::ICal') ); # and it's the right class
+
+run that and you should get:
+
+ 1..2
+ ok 1
+ ok 2
+
+congratulations, you've written your first useful test.
+
+
+=head2 Names
+
+That output isn't terribly descriptive, is it? When you have two
+tests you can figure out which one is #2, but what if you have 102?
+
+Each test can be given a little descriptive name as the second
+argument to C<ok()>.
+
+ use Test::Simple tests => 2;
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+
+So now you'd see...
+
+ 1..2
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+
+
+=head2 Test the manual
+
+Simplest way to build up a decent testing suite is to just test what
+the manual says it does. [3] Let's pull something out of the
+L<Date::ICal/SYNOPSIS> and test that all its bits work.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 8;
+
+ use Date::ICal;
+
+ $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
+ hour => 16, min => 12, sec => 47,
+ tz => '0530' );
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+ ok( $ical->sec == 47, ' sec()' );
+ ok( $ical->min == 12, ' min()' );
+ ok( $ical->hour == 16, ' hour()' );
+ ok( $ical->day == 17, ' day()' );
+ ok( $ical->month == 10, ' month()' );
+ ok( $ical->year == 1964, ' year()' );
+
+run that and you get:
+
+ 1..8
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+ ok 3 - sec()
+ ok 4 - min()
+ ok 5 - hour()
+ not ok 6 - day()
+ # Failed test (- at line 16)
+ ok 7 - month()
+ ok 8 - year()
+ # Looks like you failed 1 tests of 8.
+
+Whoops, a failure! [4] Test::Simple helpfully lets us know on what line
+the failure occurred, but not much else. We were supposed to get 17,
+but we didn't. What did we get?? Dunno. We'll have to re-run the
+test in the debugger or throw in some print statements to find out.
+
+Instead, we'll switch from B<Test::Simple> to B<Test::More>. B<Test::More>
+does everything B<Test::Simple> does, and more! In fact, Test::More does
+things I<exactly> the way Test::Simple does. You can literally swap
+Test::Simple out and put Test::More in its place. That's just what
+we're going to do.
+
+Test::More does more than Test::Simple. The most important difference
+at this point is it provides more informative ways to say "ok".
+Although you can write almost any test with a generic C<ok()>, it
+can't tell you what went wrong. Instead, we'll use the C<is()>
+function, which lets us declare that something is supposed to be the
+same as something else:
+
+ #!/usr/bin/perl -w
+
+ use Test::More tests => 8;
+
+ use Date::ICal;
+
+ $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
+ hour => 16, min => 12, sec => 47,
+ tz => '0530' );
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+ is( $ical->sec, 47, ' sec()' );
+ is( $ical->min, 12, ' min()' );
+ is( $ical->hour, 16, ' hour()' );
+ is( $ical->day, 17, ' day()' );
+ is( $ical->month, 10, ' month()' );
+ is( $ical->year, 1964, ' year()' );
+
+"Is C<$ical-E<gt>sec> 47?" "Is C<$ical-E<gt>min> 12?" With C<is()> in place,
+you get some more information
+
+ 1..8
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+ ok 3 - sec()
+ ok 4 - min()
+ ok 5 - hour()
+ not ok 6 - day()
+ # Failed test (- at line 16)
+ # got: '16'
+ # expected: '17'
+ ok 7 - month()
+ ok 8 - year()
+ # Looks like you failed 1 tests of 8.
+
+letting us know that C<$ical-E<gt>day> returned 16, but we expected 17. A
+quick check shows that the code is working fine, we made a mistake
+when writing up the tests. Just change it to:
+
+ is( $ical->day, 16, ' day()' );
+
+and everything works.
+
+So any time you're doing a "this equals that" sort of test, use C<is()>.
+It even works on arrays. The test is always in scalar context, so you
+can test how many elements are in a list this way. [5]
+
+ is( @foo, 5, 'foo has 5 elements' );
+
+
+=head2 Sometimes the tests are wrong
+
+Which brings us to a very important lesson. Code has bugs. Tests are
+code. Ergo, tests have bugs. A failing test could mean a bug in the
+code, but don't discount the possibility that the test is wrong.
+
+On the flip side, don't be tempted to prematurely declare a test
+incorrect just because you're having trouble finding the bug.
+Invalidating a test isn't something to be taken lightly, and don't use
+it as a cop out to avoid work.
+
+
+=head2 Testing lots of values
+
+We're going to be wanting to test a lot of dates here, trying to trick
+the code with lots of different edge cases. Does it work before 1970?
+After 2038? Before 1904? Do years after 10,000 give it trouble?
+Does it get leap years right? We could keep repeating the code above,
+or we could set up a little try/expect loop.
+
+ use Test::More tests => 32;
+ use Date::ICal;
+
+ my %ICal_Dates = (
+ # An ICal string And the year, month, date
+ # hour, minute and second we expect.
+ '19971024T120000' => # from the docs.
+ [ 1997, 10, 24, 12, 0, 0 ],
+ '20390123T232832' => # after the Unix epoch
+ [ 2039, 1, 23, 23, 28, 32 ],
+ '19671225T000000' => # before the Unix epoch
+ [ 1967, 12, 25, 0, 0, 0 ],
+ '18990505T232323' => # before the MacOS epoch
+ [ 1899, 5, 5, 23, 23, 23 ],
+ );
+
+
+ while( my($ical_str, $expect) = each %ICal_Dates ) {
+ my $ical = Date::ICal->new( ical => $ical_str );
+
+ ok( defined $ical, "new(ical => '$ical_str')" );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+
+ is( $ical->year, $expect->[0], ' year()' );
+ is( $ical->month, $expect->[1], ' month()' );
+ is( $ical->day, $expect->[2], ' day()' );
+ is( $ical->hour, $expect->[3], ' hour()' );
+ is( $ical->min, $expect->[4], ' min()' );
+ is( $ical->sec, $expect->[5], ' sec()' );
+ }
+
+So now we can test bunches of dates by just adding them to
+C<%ICal_Dates>. Now that it's less work to test with more dates, you'll
+be inclined to just throw more in as you think of them.
+Only problem is, every time we add to that we have to keep adjusting
+the C<use Test::More tests =E<gt> ##> line. That can rapidly get
+annoying. There's two ways to make this work better.
+
+First, we can calculate the plan dynamically using the C<plan()>
+function.
+
+ use Test::More;
+ use Date::ICal;
+
+ my %ICal_Dates = (
+ ...same as before...
+ );
+
+ # For each key in the hash we're running 8 tests.
+ plan tests => keys %ICal_Dates * 8;
+
+Or to be even more flexible, we use C<no_plan>. This means we're just
+running some tests, don't know how many. [6]
+
+ use Test::More 'no_plan'; # instead of tests => 32
+
+now we can just add tests and not have to do all sorts of math to
+figure out how many we're running.
+
+
+=head2 Informative names
+
+Take a look at this line here
+
+ ok( defined $ical, "new(ical => '$ical_str')" );
+
+we've added more detail about what we're testing and the ICal string
+itself we're trying out to the name. So you get results like:
+
+ ok 25 - new(ical => '19971024T120000')
+ ok 26 - and it's the right class
+ ok 27 - year()
+ ok 28 - month()
+ ok 29 - day()
+ ok 30 - hour()
+ ok 31 - min()
+ ok 32 - sec()
+
+if something in there fails, you'll know which one it was and that
+will make tracking down the problem easier. So try to put a bit of
+debugging information into the test names.
+
+Describe what the tests test, to make debugging a failed test easier
+for you or for the next person who runs your test.
+
+
+=head2 Skipping tests
+
+Poking around in the existing Date::ICal tests, I found this in
+F<t/01sanity.t> [7]
+
+ #!/usr/bin/perl -w
+
+ use Test::More tests => 7;
+ use Date::ICal;
+
+ # Make sure epoch time is being handled sanely.
+ my $t1 = Date::ICal->new( epoch => 0 );
+ is( $t1->epoch, 0, "Epoch time of 0" );
+
+ # XXX This will only work on unix systems.
+ is( $t1->ical, '19700101Z', " epoch to ical" );
+
+ is( $t1->year, 1970, " year()" );
+ is( $t1->month, 1, " month()" );
+ is( $t1->day, 1, " day()" );
+
+ # like the tests above, but starting with ical instead of epoch
+ my $t2 = Date::ICal->new( ical => '19700101Z' );
+ is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
+
+ is( $t2->epoch, 0, " and back to ICal" );
+
+The beginning of the epoch is different on most non-Unix operating
+systems [8]. Even though Perl smooths out the differences for the most
+part, certain ports do it differently. MacPerl is one off the top of
+my head. [9] We I<know> this will never work on MacOS. So rather than
+just putting a comment in the test, we can explicitly say it's never
+going to work and skip the test.
+
+ use Test::More tests => 7;
+ use Date::ICal;
+
+ # Make sure epoch time is being handled sanely.
+ my $t1 = Date::ICal->new( epoch => 0 );
+ is( $t1->epoch, 0, "Epoch time of 0" );
+
+ SKIP: {
+ skip('epoch to ICal not working on MacOS', 6)
+ if $^O eq 'MacOS';
+
+ is( $t1->ical, '19700101Z', " epoch to ical" );
+
+ is( $t1->year, 1970, " year()" );
+ is( $t1->month, 1, " month()" );
+ is( $t1->day, 1, " day()" );
+
+ # like the tests above, but starting with ical instead of epoch
+ my $t2 = Date::ICal->new( ical => '19700101Z' );
+ is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
+
+ is( $t2->epoch, 0, " and back to ICal" );
+ }
+
+A little bit of magic happens here. When running on anything but
+MacOS, all the tests run normally. But when on MacOS, C<skip()> causes
+the entire contents of the SKIP block to be jumped over. It's never
+run. Instead, it prints special output that tells Test::Harness that
+the tests have been skipped.
+
+ 1..7
+ ok 1 - Epoch time of 0
+ ok 2 # skip epoch to ICal not working on MacOS
+ ok 3 # skip epoch to ICal not working on MacOS
+ ok 4 # skip epoch to ICal not working on MacOS
+ ok 5 # skip epoch to ICal not working on MacOS
+ ok 6 # skip epoch to ICal not working on MacOS
+ ok 7 # skip epoch to ICal not working on MacOS
+
+This means your tests won't fail on MacOS. This means less emails
+from MacPerl users telling you about failing tests that you know will
+never work. You've got to be careful with skip tests. These are for
+tests which don't work and I<never will>. It is not for skipping
+genuine bugs (we'll get to that in a moment).
+
+The tests are wholly and completely skipped. [10] This will work.
+
+ SKIP: {
+ skip("I don't wanna die!");
+
+ die, die, die, die, die;
+ }
+
+
+=head2 Todo tests
+
+Thumbing through the Date::ICal man page, I came across this:
+
+ ical
+
+ $ical_string = $ical->ical;
+
+ Retrieves, or sets, the date on the object, using any
+ valid ICal date/time string.
+
+"Retrieves or sets". Hmmm, didn't see a test for using C<ical()> to set
+the date in the Date::ICal test suite. So I'll write one.
+
+ use Test::More tests => 1;
+ use Date::ICal;
+
+ my $ical = Date::ICal->new;
+ $ical->ical('20201231Z');
+ is( $ical->ical, '20201231Z', 'Setting via ical()' );
+
+run that and I get
+
+ 1..1
+ not ok 1 - Setting via ical()
+ # Failed test (- at line 6)
+ # got: '20010814T233649Z'
+ # expected: '20201231Z'
+ # Looks like you failed 1 tests of 1.
+
+Whoops! Looks like it's unimplemented. Let's assume we don't have
+the time to fix this. [11] Normally, you'd just comment out the test
+and put a note in a todo list somewhere. Instead, we're going to
+explicitly state "this test will fail" by wrapping it in a C<TODO> block.
+
+ use Test::More tests => 1;
+
+ TODO: {
+ local $TODO = 'ical($ical) not yet implemented';
+
+ my $ical = Date::ICal->new;
+ $ical->ical('20201231Z');
+
+ is( $ical->ical, '20201231Z', 'Setting via ical()' );
+ }
+
+Now when you run, it's a little different:
+
+ 1..1
+ not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented
+ # got: '20010822T201551Z'
+ # expected: '20201231Z'
+
+Test::More doesn't say "Looks like you failed 1 tests of 1". That '#
+TODO' tells Test::Harness "this is supposed to fail" and it treats a
+failure as a successful test. So you can write tests even before
+you've fixed the underlying code.
+
+If a TODO test passes, Test::Harness will report it "UNEXPECTEDLY
+SUCCEEDED". When that happens, you simply remove the TODO block with
+C<local $TODO> and turn it into a real test.
+
+
+=head2 Testing with taint mode.
+
+Taint mode is a funny thing. It's the globalest of all global
+features. Once you turn it on, it affects I<all> code in your program
+and I<all> modules used (and all the modules they use). If a single
+piece of code isn't taint clean, the whole thing explodes. With that
+in mind, it's very important to ensure your module works under taint
+mode.
+
+It's very simple to have your tests run under taint mode. Just throw
+a C<-T> into the C<#!> line. Test::Harness will read the switches
+in C<#!> and use them to run your tests.
+
+ #!/usr/bin/perl -Tw
+
+ ...test normally here...
+
+So when you say C<make test> it will be run with taint mode and
+warnings on.
+
+
+=head1 FOOTNOTES
+
+=over 4
+
+=item 1
+
+The first number doesn't really mean anything, but it has to be 1.
+It's the second number that's important.
+
+=item 2
+
+For those following along at home, I'm using version 1.31. It has
+some bugs, which is good -- we'll uncover them with our tests.
+
+=item 3
+
+You can actually take this one step further and test the manual
+itself. Have a look at B<Test::Inline> (formerly B<Pod::Tests>).
+
+=item 4
+
+Yes, there's a mistake in the test suite. What! Me, contrived?
+
+=item 5
+
+We'll get to testing the contents of lists later.
+
+=item 6
+
+But what happens if your test program dies halfway through?! Since we
+didn't say how many tests we're going to run, how can we know it
+failed? No problem, Test::More employs some magic to catch that death
+and turn the test into a failure, even if every test passed up to that
+point.
+
+=item 7
+
+I cleaned it up a little.
+
+=item 8
+
+Most Operating Systems record time as the number of seconds since a
+certain date. This date is the beginning of the epoch. Unix's starts
+at midnight January 1st, 1970 GMT.
+
+=item 9
+
+MacOS's epoch is midnight January 1st, 1904. VMS's is midnight,
+November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a
+problem.
+
+=item 10
+
+As long as the code inside the SKIP block at least compiles. Please
+don't ask how. No, it's not a filter.
+
+=item 11
+
+Do NOT be tempted to use TODO tests as a way to avoid fixing simple
+bugs!
+
+=back
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers!
+
+=head1 COPYRIGHT
+
+Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This documentation is free; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+Irrespective of its distribution, all code examples in these files
+are hereby placed into the public domain. You are permitted and
+encouraged to use this code in your own programs for fun
+or for profit as you see fit. A simple comment in the code giving
+credit would be courteous but is not required.
+
+=cut
projects / gitmo/moose-presentations.git / commitdiff