[tapx-dev] [commit][271] Moved performance experiments to their own branch, rolled trunk back to pristine 0.54
andy at hexten.net
andy at hexten.net
Sat Aug 18 22:33:06 BST 2007
Revision: 271
Author: andy
Date: 2007-08-18 22:33:06 +0100 (Sat, 18 Aug 2007)
Log Message:
-----------
Moved performance experiments to their own branch, rolled trunk back to pristine 0.54
Modified Paths:
--------------
trunk/lib/TAP/Base.pm
trunk/lib/TAP/Parser.pm
Added Paths:
-----------
branches/speedy/
branches/speedy/README
branches/speedy/benchmark/
branches/speedy/benchmark/grammar_only.pl
branches/speedy/benchmark/parser_only.pl
branches/speedy/benchmark/prove_vs_runtests-raw.pl
branches/speedy/benchmark/source_only.pl
branches/speedy/benchmark/st.sh
branches/speedy/benchmark/synthtest.pl
branches/speedy/benchmark/tmassive/
branches/speedy/lib/TAP/Base.pm
branches/speedy/lib/TAP/Harness/Color.pm
branches/speedy/lib/TAP/Harness/Compatible.pm
branches/speedy/lib/TAP/Harness.pm
branches/speedy/lib/TAP/Parser/Aggregator.pm
branches/speedy/lib/TAP/Parser/Grammar.pm
branches/speedy/lib/TAP/Parser/Iterator/Array.pm
branches/speedy/lib/TAP/Parser/Iterator/Process.pm
branches/speedy/lib/TAP/Parser/Iterator/Stream.pm
branches/speedy/lib/TAP/Parser/Iterator.pm
branches/speedy/lib/TAP/Parser/Result/Bailout.pm
branches/speedy/lib/TAP/Parser/Result/Comment.pm
branches/speedy/lib/TAP/Parser/Result/Plan.pm
branches/speedy/lib/TAP/Parser/Result/Test.pm
branches/speedy/lib/TAP/Parser/Result/Unknown.pm
branches/speedy/lib/TAP/Parser/Result/Version.pm
branches/speedy/lib/TAP/Parser/Result/YAML.pm
branches/speedy/lib/TAP/Parser/Result.pm
branches/speedy/lib/TAP/Parser/Source/Perl.pm
branches/speedy/lib/TAP/Parser/Source.pm
branches/speedy/lib/TAP/Parser/YAMLish/Reader.pm
branches/speedy/lib/TAP/Parser/YAMLish/Writer.pm
branches/speedy/lib/TAP/Parser.pm
Removed Paths:
-------------
branches/speedy/README
branches/speedy/benchmark/
branches/speedy/benchmark/grammar_only.pl
branches/speedy/benchmark/parser_only.pl
branches/speedy/benchmark/prove_vs_runtests-raw.pl
branches/speedy/benchmark/source_only.pl
branches/speedy/benchmark/st.sh
branches/speedy/benchmark/synthtest.pl
branches/speedy/benchmark/tmassive/
branches/speedy/lib/TAP/Base.pm
branches/speedy/lib/TAP/Harness/Color.pm
branches/speedy/lib/TAP/Harness/Compatible.pm
branches/speedy/lib/TAP/Harness.pm
branches/speedy/lib/TAP/Parser/Aggregator.pm
branches/speedy/lib/TAP/Parser/Grammar.pm
branches/speedy/lib/TAP/Parser/Iterator/Array.pm
branches/speedy/lib/TAP/Parser/Iterator/Process.pm
branches/speedy/lib/TAP/Parser/Iterator/Stream.pm
branches/speedy/lib/TAP/Parser/Iterator.pm
branches/speedy/lib/TAP/Parser/Result/Bailout.pm
branches/speedy/lib/TAP/Parser/Result/Comment.pm
branches/speedy/lib/TAP/Parser/Result/Plan.pm
branches/speedy/lib/TAP/Parser/Result/Test.pm
branches/speedy/lib/TAP/Parser/Result/Unknown.pm
branches/speedy/lib/TAP/Parser/Result/Version.pm
branches/speedy/lib/TAP/Parser/Result/YAML.pm
branches/speedy/lib/TAP/Parser/Result.pm
branches/speedy/lib/TAP/Parser/Source/Perl.pm
branches/speedy/lib/TAP/Parser/Source.pm
branches/speedy/lib/TAP/Parser/YAMLish/Reader.pm
branches/speedy/lib/TAP/Parser/YAMLish/Writer.pm
branches/speedy/lib/TAP/Parser.pm
Copied: branches/speedy (from rev 267, trunk)
Deleted: branches/speedy/README
===================================================================
--- trunk/README 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/README 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,35 +0,0 @@
-TAP-Parser 0.53
-
-TAP::Parser is designed as a replacement for Test::Harness. It is hoped
-that it will become Test::Harness 3.0.
-
-INSTALLATION
-
-To install TAP::Parser using ExtUtils::MakeMaker do:
-
- perl Makefile.PL
- make
- make test
- make install
-
-To use Module::Build do:
-
- perl Build.PL
- ./Build
- ./Build test
- ./Build install
-
-If you elect to install the "runtests" program (you are prompted during
-perl {Makefile,Build}.PL) you will be able to run your tests against
-TAP::Parser from your modules home directory by running
-
- runtests -rb
-
-See runtests --help for more information.
-
-COPYRIGHT AND LICENCE
-
-Copyright (C) 2006 Curtis "Ovid" Poe
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
Copied: branches/speedy/README (from rev 269, trunk/README)
===================================================================
--- branches/speedy/README (rev 0)
+++ branches/speedy/README 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,35 @@
+TAP-Parser 0.54
+
+TAP::Parser is designed as a replacement for Test::Harness. It is hoped
+that it will become Test::Harness 3.0.
+
+INSTALLATION
+
+To install TAP::Parser using ExtUtils::MakeMaker do:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+To use Module::Build do:
+
+ perl Build.PL
+ ./Build
+ ./Build test
+ ./Build install
+
+If you elect to install the "runtests" program (you are prompted during
+perl {Makefile,Build}.PL) you will be able to run your tests against
+TAP::Parser from your modules home directory by running
+
+ runtests -rb
+
+See runtests --help for more information.
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2006 Curtis "Ovid" Poe
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
Copied: branches/speedy/benchmark (from rev 270, trunk/benchmark)
Deleted: branches/speedy/benchmark/grammar_only.pl
===================================================================
--- trunk/benchmark/grammar_only.pl 2007-08-18 20:28:15 UTC (rev 270)
+++ branches/speedy/benchmark/grammar_only.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,16 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use TAP::Parser::Source;
-use TAP::Parser::Grammar;
-
-my $test = shift || die "No test named";
-
-my $iter = TAP::Parser::Iterator->new( { command => [ $^X, $test ] } );
-my $grammar = TAP::Parser::Grammar->new($iter);
-while ( my $token = $grammar->tokenize ) {
-
- # Do nothing
-}
Copied: branches/speedy/benchmark/grammar_only.pl (from rev 267, trunk/benchmark/grammar_only.pl)
===================================================================
--- branches/speedy/benchmark/grammar_only.pl (rev 0)
+++ branches/speedy/benchmark/grammar_only.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,16 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use TAP::Parser::Source;
+use TAP::Parser::Grammar;
+
+my $test = shift || die "No test named";
+
+my $iter = TAP::Parser::Iterator->new( { command => [ $^X, $test ] } );
+my $grammar = TAP::Parser::Grammar->new($iter);
+while ( my $token = $grammar->tokenize ) {
+
+ # Do nothing
+}
Deleted: branches/speedy/benchmark/parser_only.pl
===================================================================
--- trunk/benchmark/parser_only.pl 2007-08-18 20:28:15 UTC (rev 270)
+++ branches/speedy/benchmark/parser_only.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,13 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use TAP::Parser;
-
-my $test = shift || die "No test named";
-
-my $parser = TAP::Parser->new( { source => $test } );
-while ( my $token = $parser->next ) {
-
- # Do nothing
-}
Copied: branches/speedy/benchmark/parser_only.pl (from rev 267, trunk/benchmark/parser_only.pl)
===================================================================
--- branches/speedy/benchmark/parser_only.pl (rev 0)
+++ branches/speedy/benchmark/parser_only.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use TAP::Parser;
+
+my $test = shift || die "No test named";
+
+my $parser = TAP::Parser->new( { source => $test } );
+while ( my $token = $parser->next ) {
+
+ # Do nothing
+}
Deleted: branches/speedy/benchmark/prove_vs_runtests-raw.pl
===================================================================
--- trunk/benchmark/prove_vs_runtests-raw.pl 2007-08-18 20:28:15 UTC (rev 270)
+++ branches/speedy/benchmark/prove_vs_runtests-raw.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,101 +0,0 @@
-#!/usr/bin/perl
-
-# compare raw throughput speed of prove vs runtests
-
-use warnings;
-use strict;
-
-use Benchmark qw(:hireswallclock);
-use File::Temp ();
-use Cwd ();
-use Config;
-
-my %knobs = (
- num_lines => 1000,
- num_test_files => 10,
- num_runs => 1,
- noisy => 0,
-);
-
-if(1) { # header
- my @mods = qw(
- TAP::Parser
- Test::Harness
- );
- require $_ for(map({(my $m = $_) =~ s#::#/#g; $m.'.pm'} @mods));
-
- print "This is perl $] on $^O ($Config{archname})\n";
- printf(join("\n ", "Using ", ("%s version %s")x at mods) . "\n",
- map({$_, $_->VERSION} @mods)
- );
- print "\n";
-}
-
-my $tmp_dir = File::Temp::tempdir(
- 'tapx-' . 'X'x8,
- TMPDIR => 1,
- CLEANUP => 1,
-) . '/';
-
-my $pwd = Cwd::getcwd();
-chdir($tmp_dir) or die "cannot get into $tmp_dir $!";
-mkdir('t') or die "cannot create t directory $!";
-
-# just checking raw output handling speed
-my $thetest = 'my $n = ' . $knobs{num_lines} . ';' .
- <<'THETEST';
- print "1..$n\n";
- print "ok $_\n" for (1..$n);
- # print "#$0";
-THETEST
-
-for my $num (1..$knobs{num_test_files}) {
- my $testfile = sprintf('t/%02d-test.t', $num);
- open(my $fh, '>', $testfile) or
- die "cannot open '$testfile' for writing $!";
- print $fh $thetest;
-}
-
-my $perl = $^X;
-my @prove = ('prove', 't/');
-my @runtests = ('runtests');
-
-my $catch_out = sub {
- open(my $TO_OUT, "<&STDOUT") or die "ack1\n";
- close(STDOUT) or die "ack2\n";
- my $catch = '';
- open(STDOUT, '>', \$catch);
-
- $_[0]->();
-
- open(STDOUT, ">&", $TO_OUT) or die "ack3\n";
- close($TO_OUT) or die "ack4\n";
-};
-
-# XXX is quite different if STDOUT is a terminal?
-$catch_out = sub {$_[0]->()} if($knobs{noisy});
-
-sub time_this {
- my ($name, $sub) = @_;
-
- my $n = $knobs{num_runs};
- my $t;
- $catch_out->(sub {$t = Benchmark::timeit($n, $sub)});
-
- my $out = Benchmark::timestr($t);
- $out =~ s/\(.*sys \+ */(/;
- print $name, "\n $out\n\n";
-
- return($name, $t);
-}
-
-my $res = {
- time_this(prove => sub {system(@prove) and die;}),
- time_this(runtests => sub {system(@runtests) and die;}),
-};
-
-# Ah, the secret is to use the 'nop' to show children
-Benchmark::cmpthese($res, 'nop');
-
-
-# vim:ts=4:sw=4:et:sta
Copied: branches/speedy/benchmark/prove_vs_runtests-raw.pl (from rev 267, trunk/benchmark/prove_vs_runtests-raw.pl)
===================================================================
--- branches/speedy/benchmark/prove_vs_runtests-raw.pl (rev 0)
+++ branches/speedy/benchmark/prove_vs_runtests-raw.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,101 @@
+#!/usr/bin/perl
+
+# compare raw throughput speed of prove vs runtests
+
+use warnings;
+use strict;
+
+use Benchmark qw(:hireswallclock);
+use File::Temp ();
+use Cwd ();
+use Config;
+
+my %knobs = (
+ num_lines => 1000,
+ num_test_files => 10,
+ num_runs => 1,
+ noisy => 0,
+);
+
+if(1) { # header
+ my @mods = qw(
+ TAP::Parser
+ Test::Harness
+ );
+ require $_ for(map({(my $m = $_) =~ s#::#/#g; $m.'.pm'} @mods));
+
+ print "This is perl $] on $^O ($Config{archname})\n";
+ printf(join("\n ", "Using ", ("%s version %s")x at mods) . "\n",
+ map({$_, $_->VERSION} @mods)
+ );
+ print "\n";
+}
+
+my $tmp_dir = File::Temp::tempdir(
+ 'tapx-' . 'X'x8,
+ TMPDIR => 1,
+ CLEANUP => 1,
+) . '/';
+
+my $pwd = Cwd::getcwd();
+chdir($tmp_dir) or die "cannot get into $tmp_dir $!";
+mkdir('t') or die "cannot create t directory $!";
+
+# just checking raw output handling speed
+my $thetest = 'my $n = ' . $knobs{num_lines} . ';' .
+ <<'THETEST';
+ print "1..$n\n";
+ print "ok $_\n" for (1..$n);
+ # print "#$0";
+THETEST
+
+for my $num (1..$knobs{num_test_files}) {
+ my $testfile = sprintf('t/%02d-test.t', $num);
+ open(my $fh, '>', $testfile) or
+ die "cannot open '$testfile' for writing $!";
+ print $fh $thetest;
+}
+
+my $perl = $^X;
+my @prove = ('prove', 't/');
+my @runtests = ('runtests');
+
+my $catch_out = sub {
+ open(my $TO_OUT, "<&STDOUT") or die "ack1\n";
+ close(STDOUT) or die "ack2\n";
+ my $catch = '';
+ open(STDOUT, '>', \$catch);
+
+ $_[0]->();
+
+ open(STDOUT, ">&", $TO_OUT) or die "ack3\n";
+ close($TO_OUT) or die "ack4\n";
+};
+
+# XXX is quite different if STDOUT is a terminal?
+$catch_out = sub {$_[0]->()} if($knobs{noisy});
+
+sub time_this {
+ my ($name, $sub) = @_;
+
+ my $n = $knobs{num_runs};
+ my $t;
+ $catch_out->(sub {$t = Benchmark::timeit($n, $sub)});
+
+ my $out = Benchmark::timestr($t);
+ $out =~ s/\(.*sys \+ */(/;
+ print $name, "\n $out\n\n";
+
+ return($name, $t);
+}
+
+my $res = {
+ time_this(prove => sub {system(@prove) and die;}),
+ time_this(runtests => sub {system(@runtests) and die;}),
+};
+
+# Ah, the secret is to use the 'nop' to show children
+Benchmark::cmpthese($res, 'nop');
+
+
+# vim:ts=4:sw=4:et:sta
Deleted: branches/speedy/benchmark/source_only.pl
===================================================================
--- trunk/benchmark/source_only.pl 2007-08-18 20:28:15 UTC (rev 270)
+++ branches/speedy/benchmark/source_only.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,13 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use TAP::Parser::Iterator;
-
-my $test = shift || die "No test named";
-
-my $iter = TAP::Parser::Iterator->new( { command => [ $^X, $test ] } );
-while ( defined( my $line = $iter->next ) ) {
-
- # Do nothing
-}
Copied: branches/speedy/benchmark/source_only.pl (from rev 267, trunk/benchmark/source_only.pl)
===================================================================
--- branches/speedy/benchmark/source_only.pl (rev 0)
+++ branches/speedy/benchmark/source_only.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use TAP::Parser::Iterator;
+
+my $test = shift || die "No test named";
+
+my $iter = TAP::Parser::Iterator->new( { command => [ $^X, $test ] } );
+while ( defined( my $line = $iter->next ) ) {
+
+ # Do nothing
+}
Deleted: branches/speedy/benchmark/st.sh
===================================================================
--- trunk/benchmark/st.sh 2007-08-18 20:28:15 UTC (rev 270)
+++ branches/speedy/benchmark/st.sh 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,43 +0,0 @@
-#!/bin/sh
-
-if [ ! -d tmixed ] ; then
- # Mixed tests
- echo Making mixed tests
- mkdir -p tmixed
- for g in a b c d e f g ; do
- for nt in 1 2 5 10 20 50 100 200 500 1000 2000 5000 ; do
- perl synthtest.pl $nt > "tmixed/$g$nt.t"
- done
- done
-fi
-
-if [ ! -d tmany ] ; then
- # Lots of small tests
- echo Making lots of small tests
- mkdir -p tmany
- for i in 0 1 2 3 4 5 6 7 8 9 ; do
- for j in 0 1 2 3 4 5 6 7 8 9 ; do
- for k in 0 1 2 3 4 5 6 7 8 9 ; do
- perl synthtest.pl 1 > "tmany/$i$j$k.t"
- done
- done
- done
-fi
-
-if [ ! -d tmassive ] ; then
- # One huge test
- echo Making one huge test
- mkdir -p tmassive
- perl synthtest.pl 100000 > tmassive/huge.t
-fi
-
-for d in tmixed tmany tmassive ; do
- echo "Testing against $d"
- echo '-----------------------------'
- for tool in prove runtests ; do
- echo "Testing $tool against $d"
- time $tool $d > /dev/null
- echo
- done
- echo '-----------------------------'; echo
-done
Copied: branches/speedy/benchmark/st.sh (from rev 267, trunk/benchmark/st.sh)
===================================================================
--- branches/speedy/benchmark/st.sh (rev 0)
+++ branches/speedy/benchmark/st.sh 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,43 @@
+#!/bin/sh
+
+if [ ! -d tmixed ] ; then
+ # Mixed tests
+ echo Making mixed tests
+ mkdir -p tmixed
+ for g in a b c d e f g ; do
+ for nt in 1 2 5 10 20 50 100 200 500 1000 2000 5000 ; do
+ perl synthtest.pl $nt > "tmixed/$g$nt.t"
+ done
+ done
+fi
+
+if [ ! -d tmany ] ; then
+ # Lots of small tests
+ echo Making lots of small tests
+ mkdir -p tmany
+ for i in 0 1 2 3 4 5 6 7 8 9 ; do
+ for j in 0 1 2 3 4 5 6 7 8 9 ; do
+ for k in 0 1 2 3 4 5 6 7 8 9 ; do
+ perl synthtest.pl 1 > "tmany/$i$j$k.t"
+ done
+ done
+ done
+fi
+
+if [ ! -d tmassive ] ; then
+ # One huge test
+ echo Making one huge test
+ mkdir -p tmassive
+ perl synthtest.pl 100000 > tmassive/huge.t
+fi
+
+for d in tmixed tmany tmassive ; do
+ echo "Testing against $d"
+ echo '-----------------------------'
+ for tool in prove runtests ; do
+ echo "Testing $tool against $d"
+ time $tool $d > /dev/null
+ echo
+ done
+ echo '-----------------------------'; echo
+done
Deleted: branches/speedy/benchmark/synthtest.pl
===================================================================
--- trunk/benchmark/synthtest.pl 2007-08-18 20:28:15 UTC (rev 270)
+++ branches/speedy/benchmark/synthtest.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,10 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-my $count = shift || 1000;
-
-print qq{print "1..$count\\n";\n};
-print qq{print "ok $_ some test or other\\n";\n} for ( 1 .. $count );
-
Copied: branches/speedy/benchmark/synthtest.pl (from rev 267, trunk/benchmark/synthtest.pl)
===================================================================
--- branches/speedy/benchmark/synthtest.pl (rev 0)
+++ branches/speedy/benchmark/synthtest.pl 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,10 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+my $count = shift || 1000;
+
+print qq{print "1..$count\\n";\n};
+print qq{print "ok $_ some test or other\\n";\n} for ( 1 .. $count );
+
Copied: branches/speedy/benchmark/tmassive (from rev 267, trunk/benchmark/tmassive)
Deleted: branches/speedy/lib/TAP/Base.pm
===================================================================
--- trunk/lib/TAP/Base.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Base.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,111 +0,0 @@
-package TAP::Base;
-
-use strict;
-use vars qw($VERSION);
-
-=head1 NAME
-
-TAP::Base - Base class that provides common functionality to L<TAP::Parser> and L<TAP::Harness>
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head1 SYNOPSIS
-
- package TAP::Whatever;
-
- use TAP::Base;
-
- use vars qw($VERSION @ISA);
- @ISA = qw(TAP::Base);
-
- # ... later ...
-
- my $thing = TAP::Whatever->new();
-
- $thing->callback( event => sub {
- # do something interesting
- } );
-
-=head1 DESCRIPTION
-
-C<TAP::Base> provides callback management.
-
-=head1 METHODS
-
-=head2 Class Methods
-
-=head3 C<new>
-
-=cut
-
-sub new {
- my ( $class, $arg_for ) = @_;
-
- my $self = bless {}, $class;
- return $self->_initialize($arg_for);
-}
-
-sub _initialize {
- my ( $self, $arg_for, $ok_callback ) = @_;
-
- my %ok_map = map { $_ => 1 } @$ok_callback;
-
- $self->{ok_callbacks} = \%ok_map;
-
- if ( exists $arg_for->{callbacks} ) {
- while ( my ( $event, $callback ) = each %{ $arg_for->{callbacks} } ) {
- $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};
-
- $self->{code_for}{$event} = $callback;
-}
-
-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 $cb->(@_);
-}
-
-sub _croak {
- my ( $self, $message ) = @_;
- require Carp;
- Carp::croak($message);
-}
-
-1;
Copied: branches/speedy/lib/TAP/Base.pm (from rev 270, trunk/lib/TAP/Base.pm)
===================================================================
--- branches/speedy/lib/TAP/Base.pm (rev 0)
+++ branches/speedy/lib/TAP/Base.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,116 @@
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser> and L<TAP::Harness>
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
+
+ # ... later ...
+
+ my $thing = TAP::Whatever->new();
+
+ $thing->callback( event => sub {
+ # do something interesting
+ } );
+
+=head1 DESCRIPTION
+
+C<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+
+ my $self = bless {}, $class;
+ return $self->_initialize($arg_for);
+}
+
+sub _initialize {
+ my ( $self, $arg_for, $ok_callback ) = @_;
+
+ my %ok_map = map { $_ => 1 } @$ok_callback;
+
+ $self->{ok_callbacks} = \%ok_map;
+
+ if ( exists $arg_for->{callbacks} ) {
+ while ( my ( $event, $callback ) = each %{ $arg_for->{callbacks} } ) {
+ $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};
+
+ $self->{code_for}{$event} = $callback;
+}
+
+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 $cb->(@_);
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ require Carp;
+ Carp::croak($message);
+}
+
+1;
Deleted: branches/speedy/lib/TAP/Harness/Color.pm
===================================================================
--- trunk/lib/TAP/Harness/Color.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Harness/Color.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,205 +0,0 @@
-package TAP::Harness::Color;
-
-use strict;
-
-use TAP::Parser;
-use TAP::Harness;
-
-use vars qw($VERSION @ISA);
- at ISA = 'TAP::Harness';
-
-use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
-
-my $NO_COLOR;
-
-BEGIN {
- $NO_COLOR = 0;
-
- if (IS_WIN32) {
- eval 'use Win32::Console';
- if ($@) {
- $NO_COLOR = $@;
- }
- else {
- my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
-
- # eval here because we might not know about these variables
- my $fg = eval '$FG_LIGHTGRAY';
- my $bg = eval '$BG_BLACK';
-
- *_set_color = sub {
- my $self = shift;
- my $color = shift;
-
- 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 );
- };
-
- # Not sure if we'll have buffering problems using print instead
- # of $console->Write(). Don't want to override output unnecessarily
- # though and it /seems/ to work OK.
- #
- # *output = sub {
- # my $self = shift;
- # $console->Write($_) for @_;
- # #print @_;
- # };
- }
- }
- else {
- eval 'use Term::ANSIColor';
- if ($@) {
- $NO_COLOR = $@;
- }
- else {
- *_set_color = sub {
- my $self = shift;
- my $color = shift;
- $self->output( color($color) );
- };
- }
- }
-
- if ($NO_COLOR) {
- *_set_color = sub { };
- }
-}
-
-=head1 NAME
-
-TAP::Harness::Color - Run Perl test scripts with color
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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::Harness::Color;
- my $harness = TAP::Harness::Color->new( \%args );
- $harness->runtests(@tests);
-
-=head1 METHODS
-
-=head2 Class Methods
-
-=head3 C<new>
-
- my %args = (
- verbose => 1,
- lib => [ 'lib', 'blib/lib' ],
- shuffle => 0,
- )
- my $harness = TAP::Harness::Color->new( \%args );
-
-The constructor returns a new C<TAP::Harness::Color> object. If
-L<Term::ANSIColor> is not installed, returns a L<TAP::Harness> object. See
-L<TAP::Harness> for more details.
-
-=cut
-
-sub new {
- my $class = shift;
- if ($NO_COLOR) {
- warn "Cannot run tests in color: $NO_COLOR";
- return TAP::Harness->new(@_);
- }
- return $class->SUPER::new(@_);
-}
-##############################################################################
-
-=head3 C<can_color>
-
- Test::Harness::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<failure_output>
-
- $harness->failure_output(@list_of_strings_to_output);
-
-Overrides L<TAP::Harness> C<failure_output> to output failure information in
-red.
-
-=cut
-
-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;
-}
-
-# Set terminal color
-sub _set_colors {
- my $self = shift;
- for my $color (@_) {
- $self->_set_color($color);
- }
-}
-
-sub _output_result {
- my ( $self, $parser, $result, $prev_result ) = @_;
- if ( $result->is_test ) {
- if ( !$result->is_ok ) { # even if it's TODO
- $self->_set_colors('red');
- }
- elsif ( $result->has_skip ) {
- $self->_set_colors( 'white', 'on_blue' );
-
- }
- elsif ( $result->has_todo ) {
- $self->_set_colors('white');
- }
- }
- $self->SUPER::_output_result($parser, $result, $prev_result);
- $self->_set_colors('reset');
-}
-
-1;
Copied: branches/speedy/lib/TAP/Harness/Color.pm (from rev 269, trunk/lib/TAP/Harness/Color.pm)
===================================================================
--- branches/speedy/lib/TAP/Harness/Color.pm (rev 0)
+++ branches/speedy/lib/TAP/Harness/Color.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,205 @@
+package TAP::Harness::Color;
+
+use strict;
+
+use TAP::Parser;
+use TAP::Harness;
+
+use vars qw($VERSION @ISA);
+ at ISA = 'TAP::Harness';
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+
+my $NO_COLOR;
+
+BEGIN {
+ $NO_COLOR = 0;
+
+ if (IS_WIN32) {
+ eval 'use Win32::Console';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
+
+ # eval here because we might not know about these variables
+ my $fg = eval '$FG_LIGHTGRAY';
+ my $bg = eval '$BG_BLACK';
+
+ *_set_color = sub {
+ my $self = shift;
+ my $color = shift;
+
+ 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 );
+ };
+
+ # Not sure if we'll have buffering problems using print instead
+ # of $console->Write(). Don't want to override output unnecessarily
+ # though and it /seems/ to work OK.
+ #
+ # *output = sub {
+ # my $self = shift;
+ # $console->Write($_) for @_;
+ # #print @_;
+ # };
+ }
+ }
+ else {
+ eval 'use Term::ANSIColor';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ *_set_color = sub {
+ my $self = shift;
+ my $color = shift;
+ $self->output( color($color) );
+ };
+ }
+ }
+
+ if ($NO_COLOR) {
+ *_set_color = sub { };
+ }
+}
+
+=head1 NAME
+
+TAP::Harness::Color - Run Perl test scripts with color
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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::Harness::Color;
+ my $harness = TAP::Harness::Color->new( \%args );
+ $harness->runtests(@tests);
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbose => 1,
+ lib => [ 'lib', 'blib/lib' ],
+ shuffle => 0,
+ )
+ my $harness = TAP::Harness::Color->new( \%args );
+
+The constructor returns a new C<TAP::Harness::Color> object. If
+L<Term::ANSIColor> is not installed, returns a L<TAP::Harness> object. See
+L<TAP::Harness> for more details.
+
+=cut
+
+sub new {
+ my $class = shift;
+ if ($NO_COLOR) {
+ warn "Cannot run tests in color: $NO_COLOR";
+ return TAP::Harness->new(@_);
+ }
+ return $class->SUPER::new(@_);
+}
+##############################################################################
+
+=head3 C<can_color>
+
+ Test::Harness::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<failure_output>
+
+ $harness->failure_output(@list_of_strings_to_output);
+
+Overrides L<TAP::Harness> C<failure_output> to output failure information in
+red.
+
+=cut
+
+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;
+}
+
+# Set terminal color
+sub _set_colors {
+ my $self = shift;
+ for my $color (@_) {
+ $self->_set_color($color);
+ }
+}
+
+sub _output_result {
+ my ( $self, $parser, $result, $prev_result ) = @_;
+ if ( $result->is_test ) {
+ if ( !$result->is_ok ) { # even if it's TODO
+ $self->_set_colors('red');
+ }
+ elsif ( $result->has_skip ) {
+ $self->_set_colors( 'white', 'on_blue' );
+
+ }
+ elsif ( $result->has_todo ) {
+ $self->_set_colors('white');
+ }
+ }
+ $self->SUPER::_output_result($parser, $result, $prev_result);
+ $self->_set_colors('reset');
+}
+
+1;
Deleted: branches/speedy/lib/TAP/Harness/Compatible.pm
===================================================================
--- trunk/lib/TAP/Harness/Compatible.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Harness/Compatible.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,397 +0,0 @@
-package TAP::Harness::Compatible;
-
-require 5.00405;
-
-use TAP::Harness;
-use TAP::Parser::Aggregator;
-
-#use TAP::Harness::Compatible::Straps;
-use Exporter;
-use Benchmark;
-use Config;
-use strict;
-
-# TODO: Emulate at least some of these
-use vars qw(
- $VERSION
- @ISA @EXPORT @EXPORT_OK
- $Verbose $Switches $Debug
- $verbose $switches $debug
- $Columns
- $Directives
- $Timer
- $ML $Last_ML_Print
- $Strap
- $has_time_hires
-);
-
-BEGIN {
- eval q{use Time::HiRes 'time'};
- $has_time_hires = !$@;
-}
-
-=head1 NAME
-
-TAP::Harness::Compatible - Run Perl standard test scripts with statistics
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-# 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};
-}
-
- at ISA = ('Exporter');
- at EXPORT = qw(&runtests);
- at 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;
-
-=head1 SYNOPSIS
-
- use TAP::Harness::Compatible;
-
- runtests(@test_files);
-
-=head1 DESCRIPTION
-
-This module exists to provide L<TAP::Harness> with an interface that is
-somewhat backwards compatible with L<Test::Harness>. 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 the real L<Test::Harness> supports is
-not reproduced here.
-
-=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 runtests {
- my @tests = @_;
-
- my $harness = _new_harness();
- my $aggregate = TAP::Parser::Aggregator->new();
-
- my $results = $harness->aggregate_tests( $aggregate, @tests );
-
- $harness->summary($results);
-
- my $total = $aggregate->total;
- my $passed = $aggregate->passed;
-
- 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 {
-
- # This is a bit crufty. The switches have all been joined into a
- # single string so we have to try and recover them.
- my ( @lib, @switches );
- for my $opt (split( / \s+ (?=-) /x, $Switches )) {
- if ( $opt =~ /^ -I (.*) $ /x ) {
- push @lib, $1;
- }
- else {
- push @switches, $opt;
- }
- }
-
- my $args = {
- verbose => $Verbose,
- timer => $Timer,
- directives => $Directives,
- lib => \@lib,
- switches => \@switches,
- };
-
- return TAP::Harness->new($args);
-}
-
-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 = @_;
-
- # TODO: Handle out option
-
- my $harness = _new_harness();
- 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}++;
- }
- }
- );
- }
- );
-
- my $results = $harness->aggregate_tests( $aggregate, @{ $args{tests} } );
-
- $tot{bench} = timediff( $results->{end}, $results->{start} );
-
- # TODO: Work out the circumstances under which the files
- # and tests totals can differ.
- $tot{files} = $tot{tests} = @{ $results->{tests} };
-
- my %failedtests = ();
- my %todo_passed = ();
-
- for my $test ( @{ $results->{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<TAP::Harness::Compatible> 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<TAP::Harness::Compatible> 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<TAP::Harness::Compatible>.
-
-=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<TAP::Harness::Compatible> will output the verbose results of running
-its tests. Setting C<$TAP::Harness::Compatible::verbose> will override this,
-or you can use the C<-v> switch in the F<prove> utility.
-
-If true, C<TAP::Harness::Compatible> will output the verbose results of running
-its tests. Setting C<$TAP::Harness::Compatible::verbose> will override this,
-or you can use the C<-v> switch in the F<prove> utility.
-
-=back
-
-=head1 SEE ALSO
-
-L<TAP::Harness>, L<Test::Harness>
-
-=head1 AUTHORS
-
-Andy Armstrong C<< <andy at hexten.net> >>
-
-L<Test::Harness> (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, Andy Armstrong C<< <andy at 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>.
-
Copied: branches/speedy/lib/TAP/Harness/Compatible.pm (from rev 269, trunk/lib/TAP/Harness/Compatible.pm)
===================================================================
--- branches/speedy/lib/TAP/Harness/Compatible.pm (rev 0)
+++ branches/speedy/lib/TAP/Harness/Compatible.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,397 @@
+package TAP::Harness::Compatible;
+
+require 5.00405;
+
+use TAP::Harness;
+use TAP::Parser::Aggregator;
+
+#use TAP::Harness::Compatible::Straps;
+use Exporter;
+use Benchmark;
+use Config;
+use strict;
+
+# TODO: Emulate at least some of these
+use vars qw(
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Directives
+ $Timer
+ $ML $Last_ML_Print
+ $Strap
+ $has_time_hires
+);
+
+BEGIN {
+ eval q{use Time::HiRes 'time'};
+ $has_time_hires = !$@;
+}
+
+=head1 NAME
+
+TAP::Harness::Compatible - Run Perl standard test scripts with statistics
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+# 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};
+}
+
+ at ISA = ('Exporter');
+ at EXPORT = qw(&runtests);
+ at 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;
+
+=head1 SYNOPSIS
+
+ use TAP::Harness::Compatible;
+
+ runtests(@test_files);
+
+=head1 DESCRIPTION
+
+This module exists to provide L<TAP::Harness> with an interface that is
+somewhat backwards compatible with L<Test::Harness>. 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 the real L<Test::Harness> supports is
+not reproduced here.
+
+=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 runtests {
+ my @tests = @_;
+
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ my $results = $harness->aggregate_tests( $aggregate, @tests );
+
+ $harness->summary($results);
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+
+ 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 {
+
+ # This is a bit crufty. The switches have all been joined into a
+ # single string so we have to try and recover them.
+ my ( @lib, @switches );
+ for my $opt (split( / \s+ (?=-) /x, $Switches )) {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, $1;
+ }
+ else {
+ push @switches, $opt;
+ }
+ }
+
+ my $args = {
+ verbose => $Verbose,
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ };
+
+ return TAP::Harness->new($args);
+}
+
+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 = @_;
+
+ # TODO: Handle out option
+
+ my $harness = _new_harness();
+ 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}++;
+ }
+ }
+ );
+ }
+ );
+
+ my $results = $harness->aggregate_tests( $aggregate, @{ $args{tests} } );
+
+ $tot{bench} = timediff( $results->{end}, $results->{start} );
+
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = @{ $results->{tests} };
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test ( @{ $results->{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<TAP::Harness::Compatible> 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<TAP::Harness::Compatible> 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<TAP::Harness::Compatible>.
+
+=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<TAP::Harness::Compatible> will output the verbose results of running
+its tests. Setting C<$TAP::Harness::Compatible::verbose> will override this,
+or you can use the C<-v> switch in the F<prove> utility.
+
+If true, C<TAP::Harness::Compatible> will output the verbose results of running
+its tests. Setting C<$TAP::Harness::Compatible::verbose> will override this,
+or you can use the C<-v> switch in the F<prove> utility.
+
+=back
+
+=head1 SEE ALSO
+
+L<TAP::Harness>, L<Test::Harness>
+
+=head1 AUTHORS
+
+Andy Armstrong C<< <andy at hexten.net> >>
+
+L<Test::Harness> (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, Andy Armstrong C<< <andy at 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>.
+
Deleted: branches/speedy/lib/TAP/Harness.pm
===================================================================
--- trunk/lib/TAP/Harness.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Harness.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,924 +0,0 @@
-package TAP::Harness;
-
-use strict;
-use Benchmark;
-use File::Spec;
-use File::Path;
-
-use TAP::Base;
-use TAP::Parser;
-use TAP::Parser::Aggregator;
-
-use vars qw($VERSION @ISA);
-
- at ISA = qw(TAP::Base);
-
-=head1 NAME
-
-TAP::Harness - Run Perl test scripts with statistics
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-$ENV{HARNESS_ACTIVE} = 1;
-$ENV{HARNESS_VERSION} = $VERSION;
-
-END {
-
- # For VMS.
- delete $ENV{HARNESS_ACTIVE};
- delete $ENV{HARNESS_VERSION};
-}
-
-my $TIME_HIRES;
-my $MAX_ERRORS = 5;
-
-BEGIN {
- eval 'use Time::HiRes qw(time)';
- $TIME_HIRES = !$@;
-
-}
-
-=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;
-
-sub _error {
- my $self = shift;
- return $self->{error} unless @_;
- $self->{error} = shift;
-}
-
-BEGIN {
- %VALIDATION_FOR = (
- lib => sub {
- my ( $self, $libs ) = @_;
- $libs = [$libs] unless 'ARRAY' eq ref $libs;
- my @bad_libs;
- foreach my $lib (@$libs) {
- unless ( -d $lib ) {
- push @bad_libs, $lib;
- }
- }
- if (@bad_libs) {
- my $dirs = 'lib';
- $dirs .= 's' if @bad_libs > 1;
- $self->_error("No such $dirs (@bad_libs)");
- }
- return [ map { '-I' . File::Spec->rel2abs($_) } @$libs ];
- },
- switches => sub {
- my ( $self, $switches ) = @_;
- $switches = [$switches] unless 'ARRAY' eq ref $switches;
- my @switches = map { /^-/ ? $_ : "-$_" } @$switches;
- my %found = map { $_ => 0 } @switches;
- @switches = grep { !$found{$_}++ } @switches;
- return \@switches;
- },
- directives => sub { shift; shift },
- verbose => sub { shift; shift },
- timer => sub { shift; shift },
- failures => sub { shift; shift },
- errors => sub { shift; shift },
- quiet => sub { shift; shift },
- really_quiet => sub { shift; shift },
- exec => sub { shift; shift },
- merge => sub { shift; shift },
- formatter => sub { shift; shift },
- stdout => sub {
- my ( $self, $ref ) = @_;
- ((ref($ref) || '') eq 'SCALAR') or
- die "catch_output needs a scalar reference";
- return($ref);
- },
- );
- my @getter_setters = qw/
- _curr_parser
- _curr_test
- _longest
- _newline_printed
- _printed_summary_header
- /;
-
- foreach my $method ( @getter_setters, 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")
- 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;
- };
- }
- }
-}
-
-##############################################################################
-
-=head1 METHODS
-
-=head2 Class Methods
-
-=head3 C<new>
-
- my %args = (
- verbose => 1,
- lib => [ 'lib', 'blib/lib' ],
- )
- my $harness = TAP::Harness->new( \%args );
-
-The constructor returns a new C<TAP::Harness> object. It accepts an optional
-hashref whose allowed keys are:
-
-=over 4
-
-=item * C<verbose>
-
-Print individual test results to STDOUT.
-
-=item * C<timer>
-
-Append run time for each test to output. Uses L<Time::HiRes> if available.
-
-=item * C<failures>
-
-Only show test failures (this is a no-op if C<verbose> is selected).
-
-=item * C<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<quiet>
-
-Suppress some test output (mostly failures while tests are running).
-
-=item * C<really_quiet>
-
-Suppress everything but the tests summary.
-
-=item * C<exec>
-
-Typically, Perl tests are run through this. However, anything which spits out
-TAP is fine. You can use this argument to specify the name of the program
-(and optional switches) to run your tests with:
-
- exec => '/usr/bin/ruby -w'
-
-=item * C<merge>
-
-If C<merge> is true the harness will create parsers that merge STDOUT
-and STDERR together for any processes they start.
-
-=item * C<formatter>
-
-If set C<formatter> must be an object that is capable of formatting
-individual items from the TAP stream. For each type of item it is
-capable of formatting it must expose a method called format_I<type>.
-
-For example:
-
- sub format_yaml {
- my ($self, $harness, $result, $prev_result) = @_;
- # Format the item and return a string
- return _format_yaml_line( $result, $prev_result );
- }
-
-The formatting method is called with three arguments in addition to $self:
-
-=over
-
-=item C<$harness>
-
-The test harness.
-
-=item C<$result>
-
-The result which we should format.
-
-=item C<$prev_result>
-
-The previous result. This is necessary in the case of, for example,
-C<format_yaml> which will want to know whether the preceding test passed
-or failed.
-
-=back
-
-=item * C<errors>
-
-If parse errors are found in the TAP output, a note of this will be made
-in the summary report. To see all of the parse errors, set this argument to
-true:
-
- errors => 1
-
-=item * C<directives>
-
-If set to a true value, only test results with directives will be displayed.
-This overrides other settings such as C<verbose> or C<failures>.
-
-=item * C<stdout>
-
-A scalar reference (experimental) for catching standard output. Maybe
-should be a filehandle.
-
-=back
-
-=cut
-
-# new supplied by TAP::Base
-
-{
- my @legal_callback = qw(
- made_parser
- );
-
- sub _initialize {
- my ( $self, $arg_for ) = @_;
- $arg_for ||= {};
- $self->SUPER::_initialize( $arg_for, \@legal_callback );
- my %arg_for = %$arg_for; # force a shallow copy
-
- foreach my $name ( 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);
- }
- }
- if ( my @props = keys %arg_for ) {
- $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
- }
- $self->quiet(0) unless $self->quiet; # suppress unit warnings
- $self->really_quiet(0) unless $self->really_quiet;
- 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.
-
-Tests will be run in the order found.
-
-If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
-should name a directory into which a copy of the raw TAP for each test
-will be written. TAP is written to files named for each test.
-Subdirectories will be created as needed.
-
-Returns a L<TAP::Parser::Aggregator> containing the test results.
-
-=cut
-
-sub runtests {
- my ( $self, @tests ) = @_;
-
- my $aggregate = TAP::Parser::Aggregator->new;
-
- my $results = $self->aggregate_tests( $aggregate, @tests );
-
- $self->summary($results);
-
- return $aggregate;
-}
-
-=head3 C<aggregate_tests>
-
- $harness->aggregate_tests( $aggregate, @tests );
-
-Tests will be run in the order found.
-
-=cut
-
-sub aggregate_tests {
- my ( $self, $aggregate, @tests ) = @_;
-
- my $longest = 0;
-
- my $tests_without_extensions = 0;
- foreach my $test (@tests) {
- $longest = length $test if length $test > $longest;
- if ( $test !~ /\.\w+$/ ) {
- $tests_without_extensions = 1;
- }
- }
- $self->_longest($longest);
-
- my $start_time = Benchmark->new;
-
- my $really_quiet = $self->really_quiet;
- foreach my $test (@tests) {
- my $extra = 0;
- my $name = $test;
- unless ($tests_without_extensions) {
- if ( $name =~ s/(\.\w+)$// ) { # strip the .t or .pm
- $extra = length $1;
- }
- }
- my $periods = '.' x ( $longest + $extra + 4 - length $test );
-
- my $parser = $self->_runtest( "$name$periods", $test );
- $aggregate->add( $test, $parser );
- }
-
- return {
- start => $start_time,
- end => Benchmark->new,
- aggregate => $aggregate,
- tests => \@tests
- };
-}
-
-##############################################################################
-
-=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
-
-The following methods are one's 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};
-
- foreach 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 summary {
- my ( $self, $arg_for ) = @_;
- my ( $start_time, $aggregate, $tests )
- = @$arg_for{qw< start aggregate tests >};
-
- my $end_time = $arg_for->{end} || Benchmark->new;
-
- my $runtime = timestr( timediff( $end_time, $start_time ), 'nop' );
-
- my $total = $aggregate->total;
- my $passed = $aggregate->passed;
-
- # TODO: Check this condition still works when all subtests pass but
- # the exit status is nonzero
-
- if ( $total && $total == $passed && !$aggregate->has_problems ) {
- $self->output("All tests successful.\n");
- }
- if ( $total != $passed
- or $aggregate->has_problems
- or $aggregate->skipped )
- {
- $self->output("\nTest Summary Report");
- $self->output("\n-------------------\n");
- foreach my $test (@$tests) {
- $self->_printed_summary_header(0);
- my ($parser) = $aggregate->parsers($test);
- $self->_curr_test($test);
- $self->_curr_parser($parser);
- $self->_output_summary_failure( 'failed', " Failed tests: " );
- $self->_output_summary_failure(
- 'todo_passed',
- " TODO passed: "
- );
- $self->_output_summary_failure( 'skipped', " Tests skipped: " );
-
- if ( my $exit = $parser->exit ) {
- $self->_summary_test_header( $test, $parser );
- $self->failure_output(" Non-zero exit status: $exit\n");
- }
-
- if ( my @errors = $parser->parse_errors ) {
- my $explain;
- if ( @errors > $MAX_ERRORS && !$self->errors ) {
- $explain = "Displayed the first $MAX_ERRORS of "
- . scalar(@errors)
- . " TAP syntax errors.\n"
- . "Re-run runtests 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");
-}
-
-sub _output_summary_failure {
- my ( $self, $method, $name ) = @_;
-
- # ugly hack. Must rethink this :(
- my $output = $method eq 'failed' ? 'failure_output' : 'output';
- my $test = $self->_curr_test;
- my $parser = $self->_curr_parser;
- if ( $parser->$method() ) {
- $self->_summary_test_header( $test, $parser );
- $self->$output($name);
- my @results = $self->balanced_range( 40, $parser->$method() );
- $self->$output( sprintf "%s\n" => shift @results );
- my $spaces = ' ' x 16;
- while (@results) {
- $self->$output( sprintf "$spaces%s\n" => shift @results );
- }
- }
-}
-
-sub _summary_test_header {
- my ( $self, $test, $parser ) = @_;
- return if $self->_printed_summary_header;
- my $spaces = ' ' x ( $self->_longest - length $test );
- $spaces = ' ' unless $spaces;
- my $output = $self->_get_output_method($parser);
- $self->$output(
- sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
- $parser->wait, $parser->tests_run, scalar $parser->failed
- );
- $self->_printed_summary_header(1);
-}
-
-##############################################################################
-
-=head3 C<output>
-
- $harness->output(@list_of_strings_to_output);
-
-All output from C<TAP::Harness> is driven through this method. If you would
-like to redirect output somewhere else, just override this method.
-
-=cut
-
-sub output {
- my $self = shift;
- if(my $out = $self->stdout) {
- $$out .= $_ for(@_); # XXX what's $\ here?
- }
- else {
- print @_;
- }
-}
-
-##############################################################################
-
-=head3 C<failure_output>
-
- $harness->failure_output(@list_of_strings_to_output);
-
-Identical to C<output>, this method is called for any output which represents
-a failure.
-
-=cut
-
-sub failure_output {
- shift->output(@_);
-}
-
-##############################################################################
-
-=head3 C<balanced_range>
-
- my @ranges = $harness->balanced_range( $limit, @numbers );
-
-Given a limit in the number of characters and a list of numbers, this method
-first creates a range of numbers with C<range> and then groups them into
-individual strings which are roughly the length of C<$limit>. Returns an
-array of strings.
-
-=cut
-
-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;
-}
-
-##############################################################################
-
-=head3 C<range>
-
- my @range = $harness->range(@list_of_numbers);
-
-Taks a list of numbers, sorts them, and returns a list of ranged strings:
-
- print join ', ' $harness->range( 2, 7, 1, 3, 10, 9 );
- # 1-3, 7, 9-10
-
-=cut
-
-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;
-}
-
-##############################################################################
-
-=head3 C<output_test_failure>
-
- $harness->output_test_failure($parser);
-
-As individual test programs are run, if a test program fails, this method is
-called to spit out the list of failed tests.
-
-=cut
-
-sub output_test_failure {
- my ( $self, $parser ) = @_;
- return if $self->really_quiet;
-
- my $tests_run = $parser->tests_run;
- my $tests_planned = $parser->tests_planned;
-
- my $total =
- defined $tests_planned
- ? $tests_planned
- : $tests_run;
-
- my $passed = $parser->passed;
-
- # The total number of fails includes any tests that were planned but
- # didn't run
- my $failed = $parser->failed + $total - $tests_run;
- my $exit = $parser->exit;
-
- # TODO: $flist isn't used anywhere
- # my $flist = join ", " => $self->range( $parser->failed );
-
- if ( my $exit = $parser->exit ) {
- my $wstat = $parser->wait;
- my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
- $self->failure_output(" Dubious, test returned $status\n");
- }
-
- if ( $failed == 0 ) {
- $self->failure_output(" All $total subtests passed ");
- }
- else {
- $self->failure_output(" Failed $failed/$total subtests ");
- if ( !$total ) {
- $self->failure_output("\nNo tests run!");
- }
- }
-
- if ( my $skipped = $parser->skipped ) {
- $passed -= $skipped;
- my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
- $self->output("\n\t(less $skipped skipped $test: $passed okay)");
- }
-
- if ( my $failed = $parser->todo_passed ) {
- my $test = $failed > 1 ? 'tests' : 'test';
- $self->output("\n\t($failed TODO $test unexpectedly succeeded)");
- }
-
- $self->output("\n");
-}
-
-sub _get_parser_args {
- my ( $self, $test ) = @_;
- my %args = ();
- my @switches = $self->lib if $self->lib;
- push @switches => $self->switches if $self->switches;
- $args{switches} = \@switches;
- $args{spool} = $self->_open_spool( $test );
- $args{merge} = $self->merge;
- $args{exec} = $self->exec;
- if ( my $exec = $self->exec ) {
- $args{exec} = [ @$exec, $test ];
- }
- else {
- $args{source} = $test;
- }
- return \%args;
-}
-
-sub _runtest {
- my ( $self, $leader, $test ) = @_;
-
- my $really_quiet = $self->really_quiet;
- my $show_count = $self->_should_show_count;
- $self->output($leader) unless $really_quiet;
-
- my $parser = TAP::Parser->new( $self->_get_parser_args($test) );
-
- $self->_make_callback( 'made_parser', $parser );
-
- my $plan = '';
-
- $self->_newline_printed(0);
-
- my $start_time = time();
- my $output = 'output';
- my $prev_result = undef;
-
- while ( defined( my $result = $parser->next ) ) {
- $output = $self->_get_output_method($parser);
- if ( $result->is_bailout ) {
- $self->failure_output(
- "Bailout called. Further testing stopped: "
- . $result->explanation
- . "\n" );
- exit 1;
- }
- unless ($plan) {
- $plan = '/' . ( $parser->tests_planned || 0 ) . ' ';
- }
- if ( $show_count && $result->is_test ) {
- $self->$output( "\r$leader" . $result->number . $plan )
- unless $really_quiet;
- $self->_newline_printed(0);
- }
- $self->_process( $parser, $result, $prev_result );
- $prev_result = $result;
- }
-
- $self->_close_spool;
-
- if ($show_count) {
- my $spaces = ' ' x (
- 1 + length($leader) + length($plan) + length( $parser->tests_run )
- );
- $self->$output("\r$spaces\r$leader") unless $really_quiet;
- }
- if ( !$parser->has_problems ) {
- unless ($really_quiet) {
- my $time_report = '';
- if ( $self->timer ) {
- my $elapsed = time - $start_time;
- $time_report = $TIME_HIRES
- ? sprintf( ' %8d ms', $elapsed * 1000 )
- : sprintf( ' %8s s', $elapsed || '<1' );
- }
-
- $self->output("ok$time_report\n");
- }
- }
- else {
- $self->output_test_failure($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 $@;
-
- open( my $spool_handle, ">$spool" )
- or $self->_croak(" Can't write $spool ( $! ) ");
- return $self->{spool} = $spool_handle;
- }
-
- return;
-}
-
-sub _close_spool {
- my $self = shift;
-
- if ( my $spool_handle = delete $self->{spool} ) {
- close($spool_handle)
- or $self->_croak(" Error closing TAP spool file( $! ) \n ");
- }
-}
-
-sub _format_result {
- my ( $self, $result, $prev_result ) = @_;
- my $sig = 'format_' . $result->type;
- if ( my $formatter = $self->formatter ) {
- if ( my $method = $formatter->can($sig) ) {
- return $formatter->$method( $self, $result, $prev_result );
- }
- }
- return $result->as_string;
-}
-
-sub _output_result {
- my ( $self, $parser, $result, $prev_result ) = @_;
- $self->output( $self->_format_result( $result, $prev_result ) );
-}
-
-sub _process {
- my ( $self, $parser, $result, $prev_result ) = @_;
- return if $self->really_quiet;
- if ( $self->_should_display( $parser, $result, $prev_result ) ) {
- unless ( $self->_newline_printed ) {
- $self->output("\n") unless $self->quiet;
- $self->_newline_printed(1);
- }
-
- # TODO: quiet gets tested here /and/ in _should_display
- unless ( $self->quiet ) {
- $self->_output_result( $parser, $result, $prev_result );
- $self->output("\n");
- }
- }
-}
-
-sub _get_output_method {
- my ( $self, $parser ) = @_;
- return $parser->has_problems ? 'failure_output' : 'output';
-}
-
-sub _should_display {
- my ( $self, $parser, $result, $prev_result ) = @_;
-
- # Always output directives
- return $result->has_directive if $self->directives;
-
- # Nothing else if really quiet
- return 0 if $self->really_quiet;
-
- return 1
- if $self->_should_show_failure($result)
- || ( $self->verbose && !$self->failures );
-
- # TODO: Work out what to do with is_yaml results
- return 1
- if ( $result->is_comment || $result->is_yaml )
- && !$self->quiet
- && !$parser->in_todo;
-
- # Old line. Makes no sense. Can't be is_test /and/ is_comment.
- # && ( !$parser->in_todo || $result->is_test );
-
- return 0;
-}
-
-sub _should_show_count {
-
- # we need this because if someone tries to redirect the output, it can get
- # very garbled from the carriage returns (\r) in the count line.
- return !shift->verbose && -t STDOUT;
-}
-
-sub _should_show_failure {
- my ( $self, $result ) = @_;
- return if !$result->is_test;
- return $self->failures && !$result->is_ok;
-}
-
-sub _croak {
- my ( $self, $message ) = @_;
- unless ($message) {
- $message = $self->_error;
- }
- $self->SUPER::_croak($message);
-}
-
-=head1 REPLACING
-
-If you like the C<runtests> 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<runtests> utility like so:
-
- runtests --harness My::Test::Harness
-
-Note that while C<runtests> 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;
Copied: branches/speedy/lib/TAP/Harness.pm (from rev 269, trunk/lib/TAP/Harness.pm)
===================================================================
--- branches/speedy/lib/TAP/Harness.pm (rev 0)
+++ branches/speedy/lib/TAP/Harness.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,924 @@
+package TAP::Harness;
+
+use strict;
+use Benchmark;
+use File::Spec;
+use File::Path;
+
+use TAP::Base;
+use TAP::Parser;
+use TAP::Parser::Aggregator;
+
+use vars qw($VERSION @ISA);
+
+ at ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run Perl test scripts with statistics
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+my $TIME_HIRES;
+my $MAX_ERRORS = 5;
+
+BEGIN {
+ eval 'use Time::HiRes qw(time)';
+ $TIME_HIRES = !$@;
+
+}
+
+=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;
+
+sub _error {
+ my $self = shift;
+ return $self->{error} unless @_;
+ $self->{error} = shift;
+}
+
+BEGIN {
+ %VALIDATION_FOR = (
+ lib => sub {
+ my ( $self, $libs ) = @_;
+ $libs = [$libs] unless 'ARRAY' eq ref $libs;
+ my @bad_libs;
+ foreach my $lib (@$libs) {
+ unless ( -d $lib ) {
+ push @bad_libs, $lib;
+ }
+ }
+ if (@bad_libs) {
+ my $dirs = 'lib';
+ $dirs .= 's' if @bad_libs > 1;
+ $self->_error("No such $dirs (@bad_libs)");
+ }
+ return [ map { '-I' . File::Spec->rel2abs($_) } @$libs ];
+ },
+ switches => sub {
+ my ( $self, $switches ) = @_;
+ $switches = [$switches] unless 'ARRAY' eq ref $switches;
+ my @switches = map { /^-/ ? $_ : "-$_" } @$switches;
+ my %found = map { $_ => 0 } @switches;
+ @switches = grep { !$found{$_}++ } @switches;
+ return \@switches;
+ },
+ directives => sub { shift; shift },
+ verbose => sub { shift; shift },
+ timer => sub { shift; shift },
+ failures => sub { shift; shift },
+ errors => sub { shift; shift },
+ quiet => sub { shift; shift },
+ really_quiet => sub { shift; shift },
+ exec => sub { shift; shift },
+ merge => sub { shift; shift },
+ formatter => sub { shift; shift },
+ stdout => sub {
+ my ( $self, $ref ) = @_;
+ ((ref($ref) || '') eq 'SCALAR') or
+ die "catch_output needs a scalar reference";
+ return($ref);
+ },
+ );
+ my @getter_setters = qw/
+ _curr_parser
+ _curr_test
+ _longest
+ _newline_printed
+ _printed_summary_header
+ /;
+
+ foreach my $method ( @getter_setters, 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")
+ 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;
+ };
+ }
+ }
+}
+
+##############################################################################
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbose => 1,
+ lib => [ 'lib', 'blib/lib' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an optional
+hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbose>
+
+Print individual test results to STDOUT.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<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<quiet>
+
+Suppress some test output (mostly failures while tests are running).
+
+=item * C<really_quiet>
+
+Suppress everything but the tests summary.
+
+=item * C<exec>
+
+Typically, Perl tests are run through this. However, anything which spits out
+TAP is fine. You can use this argument to specify the name of the program
+(and optional switches) to run your tests with:
+
+ exec => '/usr/bin/ruby -w'
+
+=item * C<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting
+individual items from the TAP stream. For each type of item it is
+capable of formatting it must expose a method called format_I<type>.
+
+For example:
+
+ sub format_yaml {
+ my ($self, $harness, $result, $prev_result) = @_;
+ # Format the item and return a string
+ return _format_yaml_line( $result, $prev_result );
+ }
+
+The formatting method is called with three arguments in addition to $self:
+
+=over
+
+=item C<$harness>
+
+The test harness.
+
+=item C<$result>
+
+The result which we should format.
+
+=item C<$prev_result>
+
+The previous result. This is necessary in the case of, for example,
+C<format_yaml> which will want to know whether the preceding test passed
+or failed.
+
+=back
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be made
+in the summary report. To see all of the parse errors, set this argument to
+true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose> or C<failures>.
+
+=item * C<stdout>
+
+A scalar reference (experimental) for catching standard output. Maybe
+should be a filehandle.
+
+=back
+
+=cut
+
+# new supplied by TAP::Base
+
+{
+ my @legal_callback = qw(
+ made_parser
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ foreach my $name ( 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);
+ }
+ }
+ if ( my @props = keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+ $self->quiet(0) unless $self->quiet; # suppress unit warnings
+ $self->really_quiet(0) unless $self->really_quiet;
+ 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.
+
+Tests will be run in the order found.
+
+If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
+should name a directory into which a copy of the raw TAP for each test
+will be written. TAP is written to files named for each test.
+Subdirectories will be created as needed.
+
+Returns a L<TAP::Parser::Aggregator> containing the test results.
+
+=cut
+
+sub runtests {
+ my ( $self, @tests ) = @_;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+ my $results = $self->aggregate_tests( $aggregate, @tests );
+
+ $self->summary($results);
+
+ return $aggregate;
+}
+
+=head3 C<aggregate_tests>
+
+ $harness->aggregate_tests( $aggregate, @tests );
+
+Tests will be run in the order found.
+
+=cut
+
+sub aggregate_tests {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $longest = 0;
+
+ my $tests_without_extensions = 0;
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ if ( $test !~ /\.\w+$/ ) {
+ $tests_without_extensions = 1;
+ }
+ }
+ $self->_longest($longest);
+
+ my $start_time = Benchmark->new;
+
+ my $really_quiet = $self->really_quiet;
+ foreach my $test (@tests) {
+ my $extra = 0;
+ my $name = $test;
+ unless ($tests_without_extensions) {
+ if ( $name =~ s/(\.\w+)$// ) { # strip the .t or .pm
+ $extra = length $1;
+ }
+ }
+ my $periods = '.' x ( $longest + $extra + 4 - length $test );
+
+ my $parser = $self->_runtest( "$name$periods", $test );
+ $aggregate->add( $test, $parser );
+ }
+
+ return {
+ start => $start_time,
+ end => Benchmark->new,
+ aggregate => $aggregate,
+ tests => \@tests
+ };
+}
+
+##############################################################################
+
+=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
+
+The following methods are one's 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};
+
+ foreach 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 summary {
+ my ( $self, $arg_for ) = @_;
+ my ( $start_time, $aggregate, $tests )
+ = @$arg_for{qw< start aggregate tests >};
+
+ my $end_time = $arg_for->{end} || Benchmark->new;
+
+ my $runtime = timestr( timediff( $end_time, $start_time ), 'nop' );
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+
+ # TODO: Check this condition still works when all subtests pass but
+ # the exit status is nonzero
+
+ if ( $total && $total == $passed && !$aggregate->has_problems ) {
+ $self->output("All tests successful.\n");
+ }
+ if ( $total != $passed
+ or $aggregate->has_problems
+ or $aggregate->skipped )
+ {
+ $self->output("\nTest Summary Report");
+ $self->output("\n-------------------\n");
+ foreach my $test (@$tests) {
+ $self->_printed_summary_header(0);
+ my ($parser) = $aggregate->parsers($test);
+ $self->_curr_test($test);
+ $self->_curr_parser($parser);
+ $self->_output_summary_failure( 'failed', " Failed tests: " );
+ $self->_output_summary_failure(
+ 'todo_passed',
+ " TODO passed: "
+ );
+ $self->_output_summary_failure( 'skipped', " Tests skipped: " );
+
+ if ( my $exit = $parser->exit ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->failure_output(" Non-zero exit status: $exit\n");
+ }
+
+ if ( my @errors = $parser->parse_errors ) {
+ my $explain;
+ if ( @errors > $MAX_ERRORS && !$self->errors ) {
+ $explain = "Displayed the first $MAX_ERRORS of "
+ . scalar(@errors)
+ . " TAP syntax errors.\n"
+ . "Re-run runtests 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");
+}
+
+sub _output_summary_failure {
+ my ( $self, $method, $name ) = @_;
+
+ # ugly hack. Must rethink this :(
+ my $output = $method eq 'failed' ? 'failure_output' : 'output';
+ my $test = $self->_curr_test;
+ my $parser = $self->_curr_parser;
+ if ( $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->$output($name);
+ my @results = $self->balanced_range( 40, $parser->$method() );
+ $self->$output( sprintf "%s\n" => shift @results );
+ my $spaces = ' ' x 16;
+ while (@results) {
+ $self->$output( sprintf "$spaces%s\n" => shift @results );
+ }
+ }
+}
+
+sub _summary_test_header {
+ my ( $self, $test, $parser ) = @_;
+ return if $self->_printed_summary_header;
+ my $spaces = ' ' x ( $self->_longest - length $test );
+ $spaces = ' ' unless $spaces;
+ my $output = $self->_get_output_method($parser);
+ $self->$output(
+ sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
+ $parser->wait, $parser->tests_run, scalar $parser->failed
+ );
+ $self->_printed_summary_header(1);
+}
+
+##############################################################################
+
+=head3 C<output>
+
+ $harness->output(@list_of_strings_to_output);
+
+All output from C<TAP::Harness> is driven through this method. If you would
+like to redirect output somewhere else, just override this method.
+
+=cut
+
+sub output {
+ my $self = shift;
+ if(my $out = $self->stdout) {
+ $$out .= $_ for(@_); # XXX what's $\ here?
+ }
+ else {
+ print @_;
+ }
+}
+
+##############################################################################
+
+=head3 C<failure_output>
+
+ $harness->failure_output(@list_of_strings_to_output);
+
+Identical to C<output>, this method is called for any output which represents
+a failure.
+
+=cut
+
+sub failure_output {
+ shift->output(@_);
+}
+
+##############################################################################
+
+=head3 C<balanced_range>
+
+ my @ranges = $harness->balanced_range( $limit, @numbers );
+
+Given a limit in the number of characters and a list of numbers, this method
+first creates a range of numbers with C<range> and then groups them into
+individual strings which are roughly the length of C<$limit>. Returns an
+array of strings.
+
+=cut
+
+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;
+}
+
+##############################################################################
+
+=head3 C<range>
+
+ my @range = $harness->range(@list_of_numbers);
+
+Taks a list of numbers, sorts them, and returns a list of ranged strings:
+
+ print join ', ' $harness->range( 2, 7, 1, 3, 10, 9 );
+ # 1-3, 7, 9-10
+
+=cut
+
+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;
+}
+
+##############################################################################
+
+=head3 C<output_test_failure>
+
+ $harness->output_test_failure($parser);
+
+As individual test programs are run, if a test program fails, this method is
+called to spit out the list of failed tests.
+
+=cut
+
+sub output_test_failure {
+ my ( $self, $parser ) = @_;
+ return if $self->really_quiet;
+
+ my $tests_run = $parser->tests_run;
+ my $tests_planned = $parser->tests_planned;
+
+ my $total =
+ defined $tests_planned
+ ? $tests_planned
+ : $tests_run;
+
+ my $passed = $parser->passed;
+
+ # The total number of fails includes any tests that were planned but
+ # didn't run
+ my $failed = $parser->failed + $total - $tests_run;
+ my $exit = $parser->exit;
+
+ # TODO: $flist isn't used anywhere
+ # my $flist = join ", " => $self->range( $parser->failed );
+
+ if ( my $exit = $parser->exit ) {
+ my $wstat = $parser->wait;
+ my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
+ $self->failure_output(" Dubious, test returned $status\n");
+ }
+
+ if ( $failed == 0 ) {
+ $self->failure_output(" All $total subtests passed ");
+ }
+ else {
+ $self->failure_output(" Failed $failed/$total subtests ");
+ if ( !$total ) {
+ $self->failure_output("\nNo tests run!");
+ }
+ }
+
+ if ( my $skipped = $parser->skipped ) {
+ $passed -= $skipped;
+ my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
+ $self->output("\n\t(less $skipped skipped $test: $passed okay)");
+ }
+
+ if ( my $failed = $parser->todo_passed ) {
+ my $test = $failed > 1 ? 'tests' : 'test';
+ $self->output("\n\t($failed TODO $test unexpectedly succeeded)");
+ }
+
+ $self->output("\n");
+}
+
+sub _get_parser_args {
+ my ( $self, $test ) = @_;
+ my %args = ();
+ my @switches = $self->lib if $self->lib;
+ push @switches => $self->switches if $self->switches;
+ $args{switches} = \@switches;
+ $args{spool} = $self->_open_spool( $test );
+ $args{merge} = $self->merge;
+ $args{exec} = $self->exec;
+ if ( my $exec = $self->exec ) {
+ $args{exec} = [ @$exec, $test ];
+ }
+ else {
+ $args{source} = $test;
+ }
+ return \%args;
+}
+
+sub _runtest {
+ my ( $self, $leader, $test ) = @_;
+
+ my $really_quiet = $self->really_quiet;
+ my $show_count = $self->_should_show_count;
+ $self->output($leader) unless $really_quiet;
+
+ my $parser = TAP::Parser->new( $self->_get_parser_args($test) );
+
+ $self->_make_callback( 'made_parser', $parser );
+
+ my $plan = '';
+
+ $self->_newline_printed(0);
+
+ my $start_time = time();
+ my $output = 'output';
+ my $prev_result = undef;
+
+ while ( defined( my $result = $parser->next ) ) {
+ $output = $self->_get_output_method($parser);
+ if ( $result->is_bailout ) {
+ $self->failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ exit 1;
+ }
+ unless ($plan) {
+ $plan = '/' . ( $parser->tests_planned || 0 ) . ' ';
+ }
+ if ( $show_count && $result->is_test ) {
+ $self->$output( "\r$leader" . $result->number . $plan )
+ unless $really_quiet;
+ $self->_newline_printed(0);
+ }
+ $self->_process( $parser, $result, $prev_result );
+ $prev_result = $result;
+ }
+
+ $self->_close_spool;
+
+ if ($show_count) {
+ my $spaces = ' ' x (
+ 1 + length($leader) + length($plan) + length( $parser->tests_run )
+ );
+ $self->$output("\r$spaces\r$leader") unless $really_quiet;
+ }
+ if ( !$parser->has_problems ) {
+ unless ($really_quiet) {
+ my $time_report = '';
+ if ( $self->timer ) {
+ my $elapsed = time - $start_time;
+ $time_report = $TIME_HIRES
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+
+ $self->output("ok$time_report\n");
+ }
+ }
+ else {
+ $self->output_test_failure($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 $@;
+
+ open( my $spool_handle, ">$spool" )
+ or $self->_croak(" Can't write $spool ( $! ) ");
+ return $self->{spool} = $spool_handle;
+ }
+
+ return;
+}
+
+sub _close_spool {
+ my $self = shift;
+
+ if ( my $spool_handle = delete $self->{spool} ) {
+ close($spool_handle)
+ or $self->_croak(" Error closing TAP spool file( $! ) \n ");
+ }
+}
+
+sub _format_result {
+ my ( $self, $result, $prev_result ) = @_;
+ my $sig = 'format_' . $result->type;
+ if ( my $formatter = $self->formatter ) {
+ if ( my $method = $formatter->can($sig) ) {
+ return $formatter->$method( $self, $result, $prev_result );
+ }
+ }
+ return $result->as_string;
+}
+
+sub _output_result {
+ my ( $self, $parser, $result, $prev_result ) = @_;
+ $self->output( $self->_format_result( $result, $prev_result ) );
+}
+
+sub _process {
+ my ( $self, $parser, $result, $prev_result ) = @_;
+ return if $self->really_quiet;
+ if ( $self->_should_display( $parser, $result, $prev_result ) ) {
+ unless ( $self->_newline_printed ) {
+ $self->output("\n") unless $self->quiet;
+ $self->_newline_printed(1);
+ }
+
+ # TODO: quiet gets tested here /and/ in _should_display
+ unless ( $self->quiet ) {
+ $self->_output_result( $parser, $result, $prev_result );
+ $self->output("\n");
+ }
+ }
+}
+
+sub _get_output_method {
+ my ( $self, $parser ) = @_;
+ return $parser->has_problems ? 'failure_output' : 'output';
+}
+
+sub _should_display {
+ my ( $self, $parser, $result, $prev_result ) = @_;
+
+ # Always output directives
+ return $result->has_directive if $self->directives;
+
+ # Nothing else if really quiet
+ return 0 if $self->really_quiet;
+
+ return 1
+ if $self->_should_show_failure($result)
+ || ( $self->verbose && !$self->failures );
+
+ # TODO: Work out what to do with is_yaml results
+ return 1
+ if ( $result->is_comment || $result->is_yaml )
+ && !$self->quiet
+ && !$parser->in_todo;
+
+ # Old line. Makes no sense. Can't be is_test /and/ is_comment.
+ # && ( !$parser->in_todo || $result->is_test );
+
+ return 0;
+}
+
+sub _should_show_count {
+
+ # we need this because if someone tries to redirect the output, it can get
+ # very garbled from the carriage returns (\r) in the count line.
+ return !shift->verbose && -t STDOUT;
+}
+
+sub _should_show_failure {
+ my ( $self, $result ) = @_;
+ return if !$result->is_test;
+ return $self->failures && !$result->is_ok;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ unless ($message) {
+ $message = $self->_error;
+ }
+ $self->SUPER::_croak($message);
+}
+
+=head1 REPLACING
+
+If you like the C<runtests> 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<runtests> utility like so:
+
+ runtests --harness My::Test::Harness
+
+Note that while C<runtests> 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;
Deleted: branches/speedy/lib/TAP/Parser/Aggregator.pm
===================================================================
--- trunk/lib/TAP/Parser/Aggregator.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Aggregator.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,274 +0,0 @@
-package TAP::Parser::Aggregator;
-
-use strict;
-use vars qw($VERSION);
-
-=head1 NAME
-
-TAP::Parser::Aggregator - Aggregate TAP::Parser results.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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> is a simple class which takes parser objects and
-allows reporting of aggregate results.
-
-=head1 METHODS
-
-=head2 Class Methods
-
-=head3 C<new>
-
- my $aggregate = TAP::Parser::Aggregator->new;
-
-Returns a new C<TAP::Parser::Aggregator> object.
-
-=cut
-
-my %SUMMARY_METHOD_FOR;
-
-BEGIN {
- %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
- failed
- parse_errors
- passed
- skipped
- todo
- todo_passed
- total
- wait
- exit
- );
- $SUMMARY_METHOD_FOR{total} = 'tests_run';
-
- foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
- next if 'total' eq $method;
- no strict 'refs';
- *$method = sub {
- my $self = shift;
- return wantarray
- ? @{ $self->{"descriptions_for_$method"} }
- : $self->{$method};
- };
- }
-}
-
-sub new {
- my ($class) = @_;
- my $self = bless {}, $class;
- $self->_initialize;
- return $self;
-}
-
-sub _initialize {
- my ($self) = @_;
- $self->{parser_for} = {};
- $self->{parse_order} = [];
- foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
- $self->{$summary} = 0;
- next if 'total' eq $summary;
- $self->{"descriptions_for_$summary"} = [];
- }
- return $self;
-}
-
-##############################################################################
-
-=head2 Instance Methods
-
-=head3 C<add>
-
- $aggregate->add( $description, $parser );
-
-Takes two arguments, the description of the TAP source (usually a test file
-name, but it doesn't have to be) and a L<TAP::Parser> object.
-
-Trying to reuse a description is a fatal error.
-
-=cut
-
-sub add {
- my ( $self, $description, $parser ) = @_;
- if ( exists $self->{parser_for}{$description} ) {
- $self->_croak("You already have a parser for ($description)");
- }
- push @{ $self->{parse_order} } => $description;
- $self->{parser_for}{$description} = $parser;
-
- while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
- if ( my $count = $parser->$method() ) {
- $self->{$summary} += $count;
- push @{ $self->{"descriptions_for_$summary"} } => $description;
- }
- }
-
- return $self;
-}
-
-##############################################################################
-
-=head3 C<parsers>
-
- my $count = $aggregate->parsers;
- my @parsers = $aggregate->parsers;
- my @parsers = $aggregate->parsers(@descriptions);
-
-In scalar context without arguments, this method returns the number of parsers
-aggregated. In list context without arguments, returns the parsers in the
-order they were added.
-
-If arguments are used, these should be a list of descriptions used with the
-C<add> method. Returns an array in list context or an array reference in
-scalar context. The array contents will the requested parsers in the order
-they were listed in the argument list.
-
-Passing in an unknown description 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;
-}
-
-##############################################################################
-
-=head2 Summary methods
-
-Each of the following methods will return the total number of corresponding
-tests if called in scalar context. If called in list context, returns the
-descriptions of the parsers which contain the corresponding tests (see C<add>
-for an explanation of description.
-
-=over 4
-
-=item * failed
-
-=item * parse_errors
-
-=item * passed
-
-=item * skipped
-
-=item * todo
-
-=item * todo_passed
-
-=item * wait
-
-=item * exit
-
-=back
-
-For example, to find out how many tests unexpectedly succeeded (TODO tests
-which passed when they shouldn't):
-
- my $count = $aggregate->todo_passed;
- my @descriptions = $aggregate->todo_passed;
-
-Note that C<wait> and C<exit> are the totals of the wait and exit
-statuses of each of the tests. These values are totalled only to provide
-a true value if any of them are non-zero.
-
-=cut
-
-##############################################################################
-
-=head3 C<total>
-
- my $tests_run = $aggregate->total;
-
-Returns the total number of tests run.
-
-=cut
-
-sub total { shift->{total} }
-
-##############################################################################
-
-=head3 C<has_problems>
-
- if ( $parser->has_problems ) {
- ...
- }
-
-This is a 'catch-all' method which returns true if any tests have currently
-failed, any TODO tests unexpectedly succeeded, or any parse errors.
-
-=cut
-
-sub has_problems {
- my $self = shift;
- return $self->failed
- || $self->todo_passed
- || $self->parse_errors
- || $self->exit
- || $self->wait;
-}
-
-##############################################################################
-
-=head3 C<todo_failed>
-
- # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
-
-This was a badly misnamed method. It indicates which TODO tests unexpectedly
-succeeded. Will now issue a warning and call C<todo_passed>.
-
-=cut
-
-sub todo_failed {
- warn
- '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
- goto &todo_passed;
-}
-
-sub _croak {
- my $proto = shift;
- require Carp;
- Carp::croak(@_);
-}
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Aggregator.pm (from rev 269, trunk/lib/TAP/Parser/Aggregator.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Aggregator.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Aggregator.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,274 @@
+package TAP::Parser::Aggregator;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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> is a simple class which takes parser objects and
+allows reporting of aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN {
+ %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+ failed
+ parse_errors
+ passed
+ skipped
+ todo
+ todo_passed
+ total
+ wait
+ exit
+ );
+ $SUMMARY_METHOD_FOR{total} = 'tests_run';
+
+ foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
+ next if 'total' eq $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return wantarray
+ ? @{ $self->{"descriptions_for_$method"} }
+ : $self->{$method};
+ };
+ }
+}
+
+sub new {
+ my ($class) = @_;
+ my $self = bless {}, $class;
+ $self->_initialize;
+ return $self;
+}
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description, $parser );
+
+Takes two arguments, the description of the TAP source (usually a test file
+name, but it doesn't have to be) and a L<TAP::Parser> object.
+
+Trying to reuse a description is a fatal error.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak("You already have a parser for ($description)");
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If arguments are used, these should be a list of descriptions used with the
+C<add> method. Returns an array in list context or an array reference in
+scalar context. The array contents will the requested parsers in the order
+they were listed in the argument list.
+
+Passing in an unknown description 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;
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+This is a 'catch-all' method which returns true if any tests have currently
+failed, any TODO tests unexpectedly succeeded, or any parse errors.
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->failed
+ || $self->todo_passed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+}
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/Grammar.pm
===================================================================
--- trunk/lib/TAP/Parser/Grammar.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Grammar.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,436 +0,0 @@
-package TAP::Parser::Grammar;
-
-use strict;
-use vars qw($VERSION);
-use Carp;
-
-use TAP::Parser::Result;
-use TAP::Parser::YAMLish::Reader;
-
-=head1 NAME
-
-TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head1 DESCRIPTION
-
-C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
-L<TAP::Parser::Result> subclasses to represent the tokens.
-
-Do not attempt to use this class directly. It won't make sense. It's mainly
-here to ensure that we will be able to have pluggable grammars when TAP is
-expanded at some future date (plus, this stuff was really cluttering the
-parser).
-
-=cut
-
-##############################################################################
-
-=head2 Class Methods
-
-
-=head3 C<new>
-
- my $grammar = TAP::Grammar->new($stream);
-
-Returns TAP grammar object that will parse the specified stream.
-
-=cut
-
-sub new {
- my ( $class, $stream ) = @_;
- my $self = bless { stream => $stream }, $class;
- $self->set_version( 12 );
- return $self;
-}
-
-# 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 ) = @_;
- local *__ANON__ = '__ANON__version_token_handler';
- my $version = $1;
- return $self->_make_version_token( $line, $version, );
- }
- },
- plan => {
- syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
- handler => sub {
- my ( $self, $line ) = @_;
- local *__ANON__ = '__ANON__plan_token_handler';
- my $tests_planned = $1;
- my $explanation = $2;
- my $skip
- = ( 0 == $tests_planned || defined $explanation )
- ? 'SKIP'
- : '';
- $explanation = '' unless defined $explanation;
- return $self->_make_plan_token( $line, $tests_planned, $skip,
- _trim( $explanation ),
- );
- },
- },
- test => {
- syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
- handler => sub {
- my ( $self, $line ) = @_;
- local *__ANON__ = '__ANON__test_token_handler';
- 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, _trim( $desc ),
- uc $dir, $explanation );
- },
- },
- comment => {
- syntax => qr/^#(.*)/,
- handler => sub {
- my ( $self, $line ) = @_;
- local *__ANON__ = '__ANON__comment_token_handler';
- my $comment = $1;
- return $self->_make_comment_token( $line, $comment );
- },
- },
- bailout => {
- syntax => qr/^Bail out!\s*(.*)/,
- handler => sub {
- my ( $self, $line ) = @_;
- local *__ANON__ = '__ANON__bailout_token_handler';
- my $explanation = $1;
- return $self->_make_bailout_token( $line, _trim( $explanation ) );
- },
- },
-);
-
-my %v13 = (
- %v12,
- yaml => {
- syntax => qr/^ (\s+) (---.*) $/x,
- handler => sub {
- my ( $self, $line ) = @_;
- local *__ANON__ = '__ANON__yaml_token_handler';
- my ( $pad, $marker ) = ( $1, $2 );
- return $self->_make_yaml_token( $pad, $marker );
- },
- },
-);
-
-my %token_for = (
- '12' => \%v12,
- '13' => \%v13,
-);
-
-##############################################################################
-
-=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 $tokens = $token_for{$version} ) {
- $self->{tokens} = $tokens;
- }
- else {
- croak "Unsupported syntax version: $version";
- }
-}
-
-##############################################################################
-
-=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 $stream = $self->{stream};
- my $line = $stream->next;
- return unless defined $line;
-
- my $token;
-
- foreach my $token_data ( values %{ $self->{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 TAP::Parser::Result->new( $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, $skip, $explanation ) = @_;
-
- if ( $skip && 0 != $tests_planned ) {
- warn "Specified SKIP directive in plan but more than 0 tests ($line)\n";
- }
- return {
- type => 'plan',
- raw => $line,
- tests_planned => $tests_planned,
- directive => $skip,
- explanation => $explanation,
- };
-}
-
-sub _make_test_token {
- my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
- my %test = (
- ok => $ok,
- test_num => $num,
- description => _trim( $desc ),
- directive => uc( $dir ),
- explanation => _trim( $explanation ),
- raw => $line,
- type => 'test',
- );
- return \%test;
-}
-
-sub _make_unknown_token {
- my ( $self, $line ) = @_;
- return {
- raw => $line,
- type => 'unknown',
- };
-}
-
-sub _make_comment_token {
- my ( $self, $line, $comment ) = @_;
- return {
- type => 'comment',
- raw => $line,
- comment => _trim( $1 )
- };
-}
-
-sub _make_bailout_token {
- my ( $self, $line, $explanation ) = @_;
- return {
- type => 'bailout',
- raw => $line,
- bailout => _trim( $1 )
- };
-}
-
-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 );
-
- return {
- type => 'yaml',
- raw => $yaml->get_raw,
- data => $data
- };
-}
-
-sub _trim {
- my $data = shift || '';
- $data =~ s/^\s+//;
- $data =~ s/\s+$//;
- return $data;
-}
-
-=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}
-
-
-=cut
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Grammar.pm (from rev 269, trunk/lib/TAP/Parser/Grammar.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Grammar.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Grammar.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,436 @@
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+use TAP::Parser::Result;
+use TAP::Parser::YAMLish::Reader;
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=cut
+
+##############################################################################
+
+=head2 Class Methods
+
+
+=head3 C<new>
+
+ my $grammar = TAP::Grammar->new($stream);
+
+Returns TAP grammar object that will parse the specified stream.
+
+=cut
+
+sub new {
+ my ( $class, $stream ) = @_;
+ my $self = bless { stream => $stream }, $class;
+ $self->set_version( 12 );
+ return $self;
+}
+
+# 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 ) = @_;
+ local *__ANON__ = '__ANON__version_token_handler';
+ my $version = $1;
+ return $self->_make_version_token( $line, $version, );
+ }
+ },
+ plan => {
+ syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ local *__ANON__ = '__ANON__plan_token_handler';
+ my $tests_planned = $1;
+ my $explanation = $2;
+ my $skip
+ = ( 0 == $tests_planned || defined $explanation )
+ ? 'SKIP'
+ : '';
+ $explanation = '' unless defined $explanation;
+ return $self->_make_plan_token( $line, $tests_planned, $skip,
+ _trim( $explanation ),
+ );
+ },
+ },
+ test => {
+ syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ local *__ANON__ = '__ANON__test_token_handler';
+ 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, _trim( $desc ),
+ uc $dir, $explanation );
+ },
+ },
+ comment => {
+ syntax => qr/^#(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ local *__ANON__ = '__ANON__comment_token_handler';
+ my $comment = $1;
+ return $self->_make_comment_token( $line, $comment );
+ },
+ },
+ bailout => {
+ syntax => qr/^Bail out!\s*(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ local *__ANON__ = '__ANON__bailout_token_handler';
+ my $explanation = $1;
+ return $self->_make_bailout_token( $line, _trim( $explanation ) );
+ },
+ },
+);
+
+my %v13 = (
+ %v12,
+ yaml => {
+ syntax => qr/^ (\s+) (---.*) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ local *__ANON__ = '__ANON__yaml_token_handler';
+ my ( $pad, $marker ) = ( $1, $2 );
+ return $self->_make_yaml_token( $pad, $marker );
+ },
+ },
+);
+
+my %token_for = (
+ '12' => \%v12,
+ '13' => \%v13,
+);
+
+##############################################################################
+
+=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 $tokens = $token_for{$version} ) {
+ $self->{tokens} = $tokens;
+ }
+ else {
+ croak "Unsupported syntax version: $version";
+ }
+}
+
+##############################################################################
+
+=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 $stream = $self->{stream};
+ my $line = $stream->next;
+ return unless defined $line;
+
+ my $token;
+
+ foreach my $token_data ( values %{ $self->{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 TAP::Parser::Result->new( $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, $skip, $explanation ) = @_;
+
+ if ( $skip && 0 != $tests_planned ) {
+ warn "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+ }
+ return {
+ type => 'plan',
+ raw => $line,
+ tests_planned => $tests_planned,
+ directive => $skip,
+ explanation => $explanation,
+ };
+}
+
+sub _make_test_token {
+ my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+ my %test = (
+ ok => $ok,
+ test_num => $num,
+ description => _trim( $desc ),
+ directive => uc( $dir ),
+ explanation => _trim( $explanation ),
+ raw => $line,
+ type => 'test',
+ );
+ return \%test;
+}
+
+sub _make_unknown_token {
+ my ( $self, $line ) = @_;
+ return {
+ raw => $line,
+ type => 'unknown',
+ };
+}
+
+sub _make_comment_token {
+ my ( $self, $line, $comment ) = @_;
+ return {
+ type => 'comment',
+ raw => $line,
+ comment => _trim( $1 )
+ };
+}
+
+sub _make_bailout_token {
+ my ( $self, $line, $explanation ) = @_;
+ return {
+ type => 'bailout',
+ raw => $line,
+ bailout => _trim( $1 )
+ };
+}
+
+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 );
+
+ return {
+ type => 'yaml',
+ raw => $yaml->get_raw,
+ data => $data
+ };
+}
+
+sub _trim {
+ my $data = shift || '';
+ $data =~ s/^\s+//;
+ $data =~ s/\s+$//;
+ return $data;
+}
+
+=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}
+
+
+=cut
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/Iterator/Array.pm
===================================================================
--- trunk/lib/TAP/Parser/Iterator/Array.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Iterator/Array.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,86 +0,0 @@
-package TAP::Parser::Iterator::Array;
-
-use strict;
-use TAP::Parser::Iterator;
-use vars qw($VERSION @ISA);
- at ISA = 'TAP::Parser::Iterator';
-
-=head1 NAME
-
-TAP::Parser::Iterator::Array - Internal TAP::Parser Iterator
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head1 SYNOPSIS
-
- use TAP::Parser::Iterator::Array;
- my $it = TAP::Parser::Iterator->new(\@array);
-
- my $line = $it->next;
-
-Originally ripped off from L<Test::Harness>.
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY!>
-
-This is a simple iterator wrapper for arrays.
-
-=head2 Class Methods
-
-=head3 C<new>
-
-Create an iterator.
-
-=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
-
-sub new {
- my ( $class, $thing ) = @_;
- chomp @$thing;
- bless {
- idx => 0,
- array => $thing,
- exit => undef,
- }, $class;
-}
-
-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;
Copied: branches/speedy/lib/TAP/Parser/Iterator/Array.pm (from rev 269, trunk/lib/TAP/Parser/Iterator/Array.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Iterator/Array.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Iterator/Array.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,86 @@
+package TAP::Parser::Iterator::Array;
+
+use strict;
+use TAP::Parser::Iterator;
+use vars qw($VERSION @ISA);
+ at ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Array - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator::Array;
+ my $it = TAP::Parser::Iterator->new(\@array);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for arrays.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.
+
+=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
+
+sub new {
+ my ( $class, $thing ) = @_;
+ chomp @$thing;
+ bless {
+ idx => 0,
+ array => $thing,
+ exit => undef,
+ }, $class;
+}
+
+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;
Deleted: branches/speedy/lib/TAP/Parser/Iterator/Process.pm
===================================================================
--- trunk/lib/TAP/Parser/Iterator/Process.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Iterator/Process.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,221 +0,0 @@
-package TAP::Parser::Iterator::Process;
-
-use strict;
-
-use TAP::Parser::Iterator;
-
-use vars qw($VERSION @ISA);
-
- at ISA = 'TAP::Parser::Iterator';
-
-use IPC::Open3;
-use IO::Select;
-use IO::Handle;
-
-my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
-my $IS_MACOS = ( $^O eq 'MacOS' );
-my $IS_VMS = ( $^O eq 'VMS' );
-
-=head1 NAME
-
-TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head1 SYNOPSIS
-
- use TAP::Parser::Iterator;
- my $it = TAP::Parser::Iterator::Process->new(@args);
-
- my $line = $it->next;
-
-Originally ripped off from L<Test::Harness>.
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY!>
-
-This is a simple iterator wrapper for processes.
-
-=head2 Class Methods
-
-=head3 C<new>
-
-Create an iterator.
-
-=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'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 new {
- my $class = shift;
- my $args = shift;
-
- local *DUMMY;
-
- my @command = @{ delete $args->{command} || [] }
- or die "Must supply a command to execute";
-
- my $merge = delete $args->{merge};
- my ( $pid, $err, $sel );
-
- if ( my $setup = delete $args->{setup} ) {
- $setup->(@command);
- }
-
- my $out = IO::Handle->new;
-
- if ($IS_WIN32) {
- $err = $merge ? '' : '>&STDERR';
- eval {
- $pid = open3(
- \*DUMMY, $out,
- $merge ? '' : $err, @command
- );
- };
- die "Could not execute (@command): $@" if $@;
- if ( $] >= 5.006 ) {
-
- # Kludge to avoid warning under 5.0.5
- eval 'binmode($out, ":crlf")';
- }
- }
- else {
- $err = $merge ? '' : IO::Handle->new;
- eval { $pid = open3( \*DUMMY, $out, $err, @command ); };
- die "Could not execute (@command): $@" if $@;
- $sel = $merge ? undef : IO::Select->new( $out, $err );
- }
-
- my $self = bless {
- out => $out,
- err => $err,
- sel => $sel,
- pid => $pid,
- exit => undef,
- }, $class;
-
- if ( my $teardown = delete $args->{teardown} ) {
- $self->{teardown} = sub {
- $teardown->(@command);
- };
- }
-
- return $self;
-}
-
-##############################################################################
-
-sub wait { $_[0]->{wait} }
-sub exit { $_[0]->{exit} }
-
-sub next_raw {
- my $self = shift;
-
- if ( my $out = $self->{out} ) {
-
- # If we have an IO::Select we need to poll it.
- if ( my $sel = $self->{sel} ) {
- my $err = $self->{err};
- my $flip = 0;
-
- # Loops forever while we're reading from STDERR
- while ( my @ready = $sel->can_read ) {
-
- # Load balancing :)
- @ready = reverse @ready if $flip;
- $flip = !$flip;
-
- for my $fh (@ready) {
- if ( defined( my $line = <$fh> ) ) {
- if ( $fh == $err ) {
- warn $line;
- }
- else {
- chomp $line;
- return $line;
- }
- }
- else {
- $sel->remove($fh);
- }
- }
- }
- }
- else {
-
- # Only one handle: just a simple read
- if ( defined( my $line = <$out> ) ) {
- chomp $line;
- return $line;
- }
- }
- }
-
- # We only get here when the stream(s) is/are exhausted
- $self->_finish;
-
- return;
-}
-
-sub _finish {
- my $self = shift;
-
- my $status = $?;
-
- # If we have a subprocess we need to wait for it to terminate
- if ( defined $self->{pid} ) {
- if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
- $status = $?;
- }
- }
-
- ( delete $self->{out} )->close if $self->{out};
-
- # If we have an IO::Select we also have an error handle to close.
- if ( $self->{sel} ) {
- ( delete $self->{err} )->close;
- delete $self->{sel};
- }
-
- $self->{wait} = $status;
- $self->{exit} = $self->_wait2exit($status);
-
- if ( my $teardown = $self->{teardown} ) {
- $teardown->();
- }
-
- return $self;
-}
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Iterator/Process.pm (from rev 269, trunk/lib/TAP/Parser/Iterator/Process.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Iterator/Process.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Iterator/Process.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,221 @@
+package TAP::Parser::Iterator::Process;
+
+use strict;
+
+use TAP::Parser::Iterator;
+
+use vars qw($VERSION @ISA);
+
+ at ISA = 'TAP::Parser::Iterator';
+
+use IPC::Open3;
+use IO::Select;
+use IO::Handle;
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+my $IS_MACOS = ( $^O eq 'MacOS' );
+my $IS_VMS = ( $^O eq 'VMS' );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator;
+ my $it = TAP::Parser::Iterator::Process->new(@args);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for processes.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.
+
+=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'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 new {
+ my $class = shift;
+ my $args = shift;
+
+ local *DUMMY;
+
+ my @command = @{ delete $args->{command} || [] }
+ or die "Must supply a command to execute";
+
+ my $merge = delete $args->{merge};
+ my ( $pid, $err, $sel );
+
+ if ( my $setup = delete $args->{setup} ) {
+ $setup->(@command);
+ }
+
+ my $out = IO::Handle->new;
+
+ if ($IS_WIN32) {
+ $err = $merge ? '' : '>&STDERR';
+ eval {
+ $pid = open3(
+ \*DUMMY, $out,
+ $merge ? '' : $err, @command
+ );
+ };
+ die "Could not execute (@command): $@" if $@;
+ if ( $] >= 5.006 ) {
+
+ # Kludge to avoid warning under 5.0.5
+ eval 'binmode($out, ":crlf")';
+ }
+ }
+ else {
+ $err = $merge ? '' : IO::Handle->new;
+ eval { $pid = open3( \*DUMMY, $out, $err, @command ); };
+ die "Could not execute (@command): $@" if $@;
+ $sel = $merge ? undef : IO::Select->new( $out, $err );
+ }
+
+ my $self = bless {
+ out => $out,
+ err => $err,
+ sel => $sel,
+ pid => $pid,
+ exit => undef,
+ }, $class;
+
+ if ( my $teardown = delete $args->{teardown} ) {
+ $self->{teardown} = sub {
+ $teardown->(@command);
+ };
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+sub wait { $_[0]->{wait} }
+sub exit { $_[0]->{exit} }
+
+sub next_raw {
+ my $self = shift;
+
+ if ( my $out = $self->{out} ) {
+
+ # If we have an IO::Select we need to poll it.
+ if ( my $sel = $self->{sel} ) {
+ my $err = $self->{err};
+ my $flip = 0;
+
+ # Loops forever while we're reading from STDERR
+ while ( my @ready = $sel->can_read ) {
+
+ # Load balancing :)
+ @ready = reverse @ready if $flip;
+ $flip = !$flip;
+
+ for my $fh (@ready) {
+ if ( defined( my $line = <$fh> ) ) {
+ if ( $fh == $err ) {
+ warn $line;
+ }
+ else {
+ chomp $line;
+ return $line;
+ }
+ }
+ else {
+ $sel->remove($fh);
+ }
+ }
+ }
+ }
+ else {
+
+ # Only one handle: just a simple read
+ if ( defined( my $line = <$out> ) ) {
+ chomp $line;
+ return $line;
+ }
+ }
+ }
+
+ # We only get here when the stream(s) is/are exhausted
+ $self->_finish;
+
+ return;
+}
+
+sub _finish {
+ my $self = shift;
+
+ my $status = $?;
+
+ # If we have a subprocess we need to wait for it to terminate
+ if ( defined $self->{pid} ) {
+ if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+ $status = $?;
+ }
+ }
+
+ ( delete $self->{out} )->close if $self->{out};
+
+ # If we have an IO::Select we also have an error handle to close.
+ if ( $self->{sel} ) {
+ ( delete $self->{err} )->close;
+ delete $self->{sel};
+ }
+
+ $self->{wait} = $status;
+ $self->{exit} = $self->_wait2exit($status);
+
+ if ( my $teardown = $self->{teardown} ) {
+ $teardown->();
+ }
+
+ return $self;
+}
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/Iterator/Stream.pm
===================================================================
--- trunk/lib/TAP/Parser/Iterator/Stream.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Iterator/Stream.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,92 +0,0 @@
-package TAP::Parser::Iterator::Stream;
-
-use strict;
-use TAP::Parser::Iterator;
-use vars qw($VERSION @ISA);
- at ISA = 'TAP::Parser::Iterator';
-
-=head1 NAME
-
-TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head1 SYNOPSIS
-
- use TAP::Parser::Iterator;
- my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
-
- my $line = $it->next;
-
-Originally ripped off from L<Test::Harness>.
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY!>
-
-This is a simple iterator wrapper for filehandles.
-
-=head2 Class Methods
-
-=head3 C<new>
-
-Create an iterator.
-
-=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 new {
- my ( $class, $thing ) = @_;
- bless {
- fh => $thing,
- }, $class;
-}
-
-##############################################################################
-
-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;
Copied: branches/speedy/lib/TAP/Parser/Iterator/Stream.pm (from rev 269, trunk/lib/TAP/Parser/Iterator/Stream.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Iterator/Stream.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Iterator/Stream.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,92 @@
+package TAP::Parser::Iterator::Stream;
+
+use strict;
+use TAP::Parser::Iterator;
+use vars qw($VERSION @ISA);
+ at ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator;
+ my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for filehandles.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.
+
+=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 new {
+ my ( $class, $thing ) = @_;
+ bless {
+ fh => $thing,
+ }, $class;
+}
+
+##############################################################################
+
+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;
Deleted: branches/speedy/lib/TAP/Parser/Iterator.pm
===================================================================
--- trunk/lib/TAP/Parser/Iterator.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Iterator.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,95 +0,0 @@
-package TAP::Parser::Iterator;
-
-use strict;
-use vars qw($VERSION);
-
-use TAP::Parser::Iterator::Array;
-use TAP::Parser::Iterator::Stream;
-use TAP::Parser::Iterator::Process;
-
-=head1 NAME
-
-TAP::Parser::Iterator - Internal TAP::Parser Iterator
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head1 SYNOPSIS
-
- use TAP::Parser::Iterator;
- my $it = TAP::Parser::Iterator->new(\*TEST);
- my $it = TAP::Parser::Iterator->new(\@array);
-
- my $line = $it->next;
-
-Originally ripped off from L<Test::Harness>.
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY!>
-
-This is a simple iterator wrapper for arrays and filehandles.
-
-=head2 Class Methods
-
-=head3 C<new>
-
- my $iter = TAP::Parser::Iterator->new( $array_reference );
- my $iter = TAP::Parser::Iterator->new( $filehandle );
-
-Create an iterator.
-
-=head2 Instance Methods
-
-=head3 C<next>
-
- while ( my $item = $iter->next ) { ... }
-
-Iterate through it, of course.
-
-=head3 C<next_raw>
-
- while ( my $item = $iter->next_raw ) { ... }
-
-Iterate raw input without applying any fixes for quirky input syntax.
-
-=cut
-
-sub new {
- my ( $proto, $thing ) = @_;
-
- my $ref = ref $thing;
- if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
- return TAP::Parser::Iterator::Stream->new($thing);
- }
- elsif ( $ref eq 'ARRAY' ) {
- return TAP::Parser::Iterator::Array->new($thing);
- }
- elsif ( $ref eq 'HASH' ) {
- return TAP::Parser::Iterator::Process->new($thing);
- }
- else {
- die "Can't iterate with a $ref";
- }
-}
-
-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 && $line =~ /^\s*not\s*$/ ) {
- $line .= ( $self->next_raw || '' );
- }
- return $line;
-}
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Iterator.pm (from rev 269, trunk/lib/TAP/Parser/Iterator.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Iterator.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Iterator.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,95 @@
+package TAP::Parser::Iterator;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Iterator::Array;
+use TAP::Parser::Iterator::Stream;
+use TAP::Parser::Iterator::Process;
+
+=head1 NAME
+
+TAP::Parser::Iterator - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator;
+ my $it = TAP::Parser::Iterator->new(\*TEST);
+ my $it = TAP::Parser::Iterator->new(\@array);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for arrays and filehandles.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $iter = TAP::Parser::Iterator->new( $array_reference );
+ my $iter = TAP::Parser::Iterator->new( $filehandle );
+
+Create an iterator.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub new {
+ my ( $proto, $thing ) = @_;
+
+ my $ref = ref $thing;
+ if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+ return TAP::Parser::Iterator::Stream->new($thing);
+ }
+ elsif ( $ref eq 'ARRAY' ) {
+ return TAP::Parser::Iterator::Array->new($thing);
+ }
+ elsif ( $ref eq 'HASH' ) {
+ return TAP::Parser::Iterator::Process->new($thing);
+ }
+ else {
+ die "Can't iterate with a $ref";
+ }
+}
+
+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 && $line =~ /^\s*not\s*$/ ) {
+ $line .= ( $self->next_raw || '' );
+ }
+ return $line;
+}
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/Result/Bailout.pm
===================================================================
--- trunk/lib/TAP/Parser/Result/Bailout.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result/Bailout.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,63 +0,0 @@
-package TAP::Parser::Result::Bailout;
-
-use strict;
-
-use vars qw($VERSION @ISA);
-use TAP::Parser::Result;
- at ISA = 'TAP::Parser::Result';
-
-=head1 NAME
-
-TAP::Parser::Result::Bailout - Bailout result token.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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;
Copied: branches/speedy/lib/TAP/Parser/Result/Bailout.pm (from rev 269, trunk/lib/TAP/Parser/Result/Bailout.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result/Bailout.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result/Bailout.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Bailout;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+ at ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Bailout - Bailout result token.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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;
Deleted: branches/speedy/lib/TAP/Parser/Result/Comment.pm
===================================================================
--- trunk/lib/TAP/Parser/Result/Comment.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result/Comment.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,61 +0,0 @@
-package TAP::Parser::Result::Comment;
-
-use strict;
-
-use vars qw($VERSION @ISA);
-use TAP::Parser::Result;
- at ISA = 'TAP::Parser::Result';
-
-=head1 NAME
-
-TAP::Parser::Result::Comment - Comment result token.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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;
Copied: branches/speedy/lib/TAP/Parser/Result/Comment.pm (from rev 269, trunk/lib/TAP/Parser/Result/Comment.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result/Comment.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result/Comment.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,61 @@
+package TAP::Parser::Result::Comment;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+ at ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Comment - Comment result token.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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;
Deleted: branches/speedy/lib/TAP/Parser/Result/Plan.pm
===================================================================
--- trunk/lib/TAP/Parser/Result/Plan.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result/Plan.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,109 +0,0 @@
-package TAP::Parser::Result::Plan;
-
-use strict;
-
-use vars qw($VERSION @ISA);
-use TAP::Parser::Result;
- at ISA = 'TAP::Parser::Result';
-
-=head1 NAME
-
-TAP::Parser::Result::Plan - Plan result token.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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} }
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Result/Plan.pm (from rev 269, trunk/lib/TAP/Parser/Result/Plan.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result/Plan.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result/Plan.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,109 @@
+package TAP::Parser::Result::Plan;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+ at ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Plan - Plan result token.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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} }
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/Result/Test.pm
===================================================================
--- trunk/lib/TAP/Parser/Result/Test.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result/Test.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,274 +0,0 @@
-package TAP::Parser::Result::Test;
-
-use strict;
-
-use vars qw($VERSION @ISA);
-use TAP::Parser::Result;
- at ISA = 'TAP::Parser::Result';
-
-use vars qw($VERSION);
-
-=head1 NAME
-
-TAP::Parser::Result::Test - Test result token.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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;
Copied: branches/speedy/lib/TAP/Parser/Result/Test.pm (from rev 269, trunk/lib/TAP/Parser/Result/Test.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result/Test.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result/Test.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,274 @@
+package TAP::Parser::Result::Test;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+ at ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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;
Deleted: branches/speedy/lib/TAP/Parser/Result/Unknown.pm
===================================================================
--- trunk/lib/TAP/Parser/Result/Unknown.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result/Unknown.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,51 +0,0 @@
-package TAP::Parser::Result::Unknown;
-
-use strict;
-
-use vars qw($VERSION @ISA);
-use TAP::Parser::Result;
- at ISA = 'TAP::Parser::Result';
-
-use vars qw($VERSION);
-
-=head1 NAME
-
-TAP::Parser::Result::Unknown - Unknown result token.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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;
Copied: branches/speedy/lib/TAP/Parser/Result/Unknown.pm (from rev 269, trunk/lib/TAP/Parser/Result/Unknown.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result/Unknown.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result/Unknown.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,51 @@
+package TAP::Parser::Result::Unknown;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+ at ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Unknown - Unknown result token.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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;
Deleted: branches/speedy/lib/TAP/Parser/Result/Version.pm
===================================================================
--- trunk/lib/TAP/Parser/Result/Version.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result/Version.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,63 +0,0 @@
-package TAP::Parser::Result::Version;
-
-use strict;
-
-use vars qw($VERSION @ISA);
-use TAP::Parser::Result;
- at ISA = 'TAP::Parser::Result';
-
-=head1 NAME
-
-TAP::Parser::Result::Version - TAP version result token.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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 4
- ok 1
- not ok 2
-
-The first version of TAP to include an explicit version number is 4.
-
-=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;
Copied: branches/speedy/lib/TAP/Parser/Result/Version.pm (from rev 269, trunk/lib/TAP/Parser/Result/Version.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result/Version.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result/Version.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Version;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+ at ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Version - TAP version result token.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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 4
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 4.
+
+=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;
Deleted: branches/speedy/lib/TAP/Parser/Result/YAML.pm
===================================================================
--- trunk/lib/TAP/Parser/Result/YAML.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result/YAML.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,62 +0,0 @@
-package TAP::Parser::Result::YAML;
-
-use strict;
-
-use vars qw($VERSION @ISA);
-use TAP::Parser::Result;
- at ISA = 'TAP::Parser::Result';
-
-=head1 NAME
-
-TAP::Parser::Result::YAML - YAML result token.
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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;
Copied: branches/speedy/lib/TAP/Parser/Result/YAML.pm (from rev 269, trunk/lib/TAP/Parser/Result/YAML.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result/YAML.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result/YAML.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,62 @@
+package TAP::Parser::Result::YAML;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+ at ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::YAML - YAML result token.
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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;
Deleted: branches/speedy/lib/TAP/Parser/Result.pm
===================================================================
--- trunk/lib/TAP/Parser/Result.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Result.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,240 +0,0 @@
-package TAP::Parser::Result;
-
-use strict;
-use vars qw($VERSION);
-
-use TAP::Parser::Result::Bailout;
-use TAP::Parser::Result::Comment;
-use TAP::Parser::Result::Plan;
-use TAP::Parser::Result::Test;
-use TAP::Parser::Result::Unknown;
-use TAP::Parser::Result::Version;
-use TAP::Parser::Result::YAML;
-
-BEGIN {
- no strict 'refs';
- foreach my $token (qw<plan comment test bailout version unknown yaml>) {
- my $method = "is_$token";
- *$method = sub { return $token eq shift->type };
- }
-}
-
-##############################################################################
-
-=head1 NAME
-
-TAP::Parser::Result - TAP::Parser output
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head2 DESCRIPTION
-
-This is merely a factory class which returns an object representing the
-current bit of test data from TAP (usually a line). It's for internal use
-only and should not be relied upon.
-
-=cut
-
-# note that this is bad. Makes it very difficult to subclass, but then, it
-# would be a lot of work to subclass this system.
-my %class_for = (
- plan => 'TAP::Parser::Result::Plan',
- 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',
-);
-
-##############################################################################
-
-=head2 METHODS
-
-=head3 C<new>
-
- my $result = TAP::Parser::Result->new($token);
-
-Returns an instance the appropriate class for the test token passed in.
-
-=cut
-
-sub new {
- my ( $class, $token ) = @_;
- my $type = $token->{type};
- return bless $token => $class_for{$type}
- if exists $class_for{$type};
- require Carp;
-
- # this should never happen!
- Carp::croak("Could not determine class for\n$token->{type}");
-}
-
-=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_test>
-
-Indicates whether or not this is a test line.
-
- is $foo, $bar, $description;
-
-=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} || '' ) }
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Result.pm (from rev 269, trunk/lib/TAP/Parser/Result.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Result.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Result.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,240 @@
+package TAP::Parser::Result;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Result::Bailout;
+use TAP::Parser::Result::Comment;
+use TAP::Parser::Result::Plan;
+use TAP::Parser::Result::Test;
+use TAP::Parser::Result::Unknown;
+use TAP::Parser::Result::Version;
+use TAP::Parser::Result::YAML;
+
+BEGIN {
+ no strict 'refs';
+ foreach my $token (qw<plan comment test bailout version unknown yaml>) {
+ my $method = "is_$token";
+ *$method = sub { return $token eq shift->type };
+ }
+}
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::Result - TAP::Parser output
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head2 DESCRIPTION
+
+This is merely a factory class which returns an object representing the
+current bit of test data from TAP (usually a line). It's for internal use
+only and should not be relied upon.
+
+=cut
+
+# note that this is bad. Makes it very difficult to subclass, but then, it
+# would be a lot of work to subclass this system.
+my %class_for = (
+ plan => 'TAP::Parser::Result::Plan',
+ 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',
+);
+
+##############################################################################
+
+=head2 METHODS
+
+=head3 C<new>
+
+ my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+sub new {
+ my ( $class, $token ) = @_;
+ my $type = $token->{type};
+ return bless $token => $class_for{$type}
+ if exists $class_for{$type};
+ require Carp;
+
+ # this should never happen!
+ Carp::croak("Could not determine class for\n$token->{type}");
+}
+
+=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_test>
+
+Indicates whether or not this is a test line.
+
+ is $foo, $bar, $description;
+
+=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} || '' ) }
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/Source/Perl.pm
===================================================================
--- trunk/lib/TAP/Parser/Source/Perl.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Source/Perl.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,256 +0,0 @@
-package TAP::Parser::Source::Perl;
-
-use strict;
-use vars qw($VERSION @ISA);
-
-use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
-use constant IS_MACOS => ( $^O eq 'MacOS' );
-use constant IS_VMS => ( $^O eq 'VMS' );
-
-use TAP::Parser::Source;
- at ISA = 'TAP::Parser::Source';
-
-=head1 NAME
-
-TAP::Parser::Source::Perl - Stream Perl output
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=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 SYNOPSIS
-
- use TAP::Parser::Source::Perl;
- my $perl = TAP::Parser::Source::Perl->new;
- my $stream = $perl->source_file($filename)->get_stream;
-
-=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_file>
-
- my $perl = $source->source;
- $perl->source_file($filename);
-
-Getter/setter for the source filename. Will C<croak> if the C<$filename> does
-not appear to be a file.
-
-=cut
-
-sub source_file {
- my $self = shift;
- return $self->{source_file} unless @_;
- my $filename = shift;
- unless ( -f $filename ) {
- $self->_croak("Cannot find ($filename)");
- }
- $self->{source_file} = $filename;
- return $self;
-}
-
-=head3 C<switches>
-
- my $switches = $perl->switches;
- my @switches = $perl->switches;
- $perl->switches(\@switches);
-
-Getter/setter for the additional switches to pass to the perl executable. One
-common switch would be to set an include directory:
-
- $perl->switches('-Ilib');
-
-=cut
-
-sub switches {
- my $self = shift;
- unless (@_) {
- return wantarray ? @{ $self->{switches} } : $self->{switches};
- }
- my $switches = shift;
- $self->{switches} = [@$switches]; # force a copy
- return $self;
-}
-
-##############################################################################
-
-=head3 C<get_stream>
-
- my $stream = $source->get_stream;
-
-Returns a stream of the output generated by executing C<source_file>.
-
-=cut
-
-sub get_stream {
- my $self = shift;
- my @switches = $self->_switches;
-
- my @command = $self->_get_command_for_switches(@switches)
- or $self->_croak("No command found!");
-
- # Nasty kludge. It might be nicer if we got the libs separately
- # although at least this way we find any -I switches that were
- # supplied other then as explicit libs.
- # We filter out any names containing colons because they will break
- # PERL5LIB
- my @libs;
- for ( grep { $_ !~ /:/ } @switches ) {
- push @libs, $1 if / ^ -I (.*) $ /x;
- }
-
- my $previous = $ENV{PERL5LIB};
- if ($previous) {
- push @libs, split( /:/, $previous );
- }
-
- my $setup = sub {
- if (@libs) {
- $ENV{PERL5LIB} = join( ':', @libs );
- }
- };
-
- # Cargo culted from comments seen elsewhere about VMS / environment
- # variables. I don't know if this is actually necessary.
- my $teardown = sub {
- if ($previous) {
- $ENV{PERL5LIB} = $previous;
- }
- else {
- delete $ENV{PERL5LIB};
- }
- };
-
- return TAP::Parser::Iterator->new(
- { command => \@command,
- merge => $self->merge,
- setup => $setup,
- teardown => $teardown,
- }
- );
-}
-
-sub _get_command_for_switches {
- my $self = shift;
- my @switches = @_;
- my $file = $self->source_file;
- my $command = $self->_get_perl;
-
- $file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
- my @command = ( $command, @switches, $file );
- return @command;
-}
-
-sub _get_command {
- my $self = shift;
- return $self->_get_command_for_switches( $self->_switches );
-}
-
-sub _switches {
- my $self = shift;
- my $file = $self->source_file;
- my @switches = (
- $self->switches,
- );
-
- local *TEST;
- open( TEST, $file ) or print "can't open $file. $!\n";
- my $shebang = <TEST>;
- close(TEST) or print "can't close $file. $!\n";
-
- my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
- push( @switches, "-$1" ) if $taint;
-
- # When taint mode is on, PERL5LIB is ignored. So we need to put
- # all that on the command line as -Is.
- # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
- if ( $taint || IS_MACOS ) {
- my @inc = $self->_filtered_inc;
- push @switches, map {"-I$_"} @inc;
- }
-
- # Quote the argument if there's any whitespace in it, or if
- # we're VMS, since VMS requires all parms quoted. Also, don't quote
- # it if it's already quoted.
- for (@switches) {
- $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
- }
-
- my %found_switch = map { $_ => 0 } @switches;
-
- # remove duplicate switches
- @switches
- = grep { defined $_ && $_ ne '' && !$found_switch{$_}++ } @switches;
- return @switches;
-}
-
-sub _filtered_inc {
- my $self = shift;
- my @inc = @_;
- @inc = @INC unless @inc;
-
- 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 %seen;
- $seen{$_}++ foreach $self->_default_inc;
- @inc = grep !$seen{$_}++, @inc;
-
- return @inc;
-}
-
-{
-
- # cache this to avoid repeatedly shelling out to Perl. This really speeds
- # up TAP::Parser.
- my @inc;
-
- sub _default_inc {
- return @inc if @inc;
- my $proto = shift;
- local $ENV{PERL5LIB};
- local $ENV{PERLLIB}; # [12030] fix untested
- my $perl = $proto->_get_perl;
- chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` );
- return @inc;
- }
-}
-
-sub _get_perl {
- my $proto = shift;
- return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
- return Win32::GetShortPathName($^X) if IS_WIN32;
- return $^X;
-}
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Source/Perl.pm (from rev 269, trunk/lib/TAP/Parser/Source/Perl.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Source/Perl.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Source/Perl.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,256 @@
+package TAP::Parser::Source::Perl;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_MACOS => ( $^O eq 'MacOS' );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::Source;
+ at ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=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 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new;
+ my $stream = $perl->source_file($filename)->get_stream;
+
+=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_file>
+
+ my $perl = $source->source;
+ $perl->source_file($filename);
+
+Getter/setter for the source filename. Will C<croak> if the C<$filename> does
+not appear to be a file.
+
+=cut
+
+sub source_file {
+ my $self = shift;
+ return $self->{source_file} unless @_;
+ my $filename = shift;
+ unless ( -f $filename ) {
+ $self->_croak("Cannot find ($filename)");
+ }
+ $self->{source_file} = $filename;
+ return $self;
+}
+
+=head3 C<switches>
+
+ my $switches = $perl->switches;
+ my @switches = $perl->switches;
+ $perl->switches(\@switches);
+
+Getter/setter for the additional switches to pass to the perl executable. One
+common switch would be to set an include directory:
+
+ $perl->switches('-Ilib');
+
+=cut
+
+sub switches {
+ my $self = shift;
+ unless (@_) {
+ return wantarray ? @{ $self->{switches} } : $self->{switches};
+ }
+ my $switches = shift;
+ $self->{switches} = [@$switches]; # force a copy
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream;
+
+Returns a stream of the output generated by executing C<source_file>.
+
+=cut
+
+sub get_stream {
+ my $self = shift;
+ my @switches = $self->_switches;
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ for ( grep { $_ !~ /:/ } @switches ) {
+ push @libs, $1 if / ^ -I (.*) $ /x;
+ }
+
+ my $previous = $ENV{PERL5LIB};
+ if ($previous) {
+ push @libs, split( /:/, $previous );
+ }
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB} = join( ':', @libs );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $teardown = sub {
+ if ($previous) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ return TAP::Parser::Iterator->new(
+ { command => \@command,
+ merge => $self->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my $self = shift;
+ my @switches = @_;
+ my $file = $self->source_file;
+ my $command = $self->_get_perl;
+
+ $file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file );
+ return @command;
+}
+
+sub _get_command {
+ my $self = shift;
+ return $self->_get_command_for_switches( $self->_switches );
+}
+
+sub _switches {
+ my $self = shift;
+ my $file = $self->source_file;
+ my @switches = (
+ $self->switches,
+ );
+
+ local *TEST;
+ open( TEST, $file ) or print "can't open $file. $!\n";
+ my $shebang = <TEST>;
+ close(TEST) or print "can't close $file. $!\n";
+
+ my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
+ push( @switches, "-$1" ) if $taint;
+
+ # When taint mode is on, PERL5LIB is ignored. So we need to put
+ # all that on the command line as -Is.
+ # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
+ if ( $taint || IS_MACOS ) {
+ my @inc = $self->_filtered_inc;
+ push @switches, map {"-I$_"} @inc;
+ }
+
+ # Quote the argument if there's any whitespace in it, or if
+ # we're VMS, since VMS requires all parms quoted. Also, don't quote
+ # it if it's already quoted.
+ for (@switches) {
+ $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
+ }
+
+ my %found_switch = map { $_ => 0 } @switches;
+
+ # remove duplicate switches
+ @switches
+ = grep { defined $_ && $_ ne '' && !$found_switch{$_}++ } @switches;
+ return @switches;
+}
+
+sub _filtered_inc {
+ my $self = shift;
+ my @inc = @_;
+ @inc = @INC unless @inc;
+
+ 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 %seen;
+ $seen{$_}++ foreach $self->_default_inc;
+ @inc = grep !$seen{$_}++, @inc;
+
+ return @inc;
+}
+
+{
+
+ # cache this to avoid repeatedly shelling out to Perl. This really speeds
+ # up TAP::Parser.
+ my @inc;
+
+ sub _default_inc {
+ return @inc if @inc;
+ my $proto = shift;
+ local $ENV{PERL5LIB};
+ local $ENV{PERLLIB}; # [12030] fix untested
+ my $perl = $proto->_get_perl;
+ chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` );
+ return @inc;
+ }
+}
+
+sub _get_perl {
+ my $proto = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/Source.pm
===================================================================
--- trunk/lib/TAP/Parser/Source.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/Source.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,172 +0,0 @@
-package TAP::Parser::Source;
-
-use strict;
-use vars qw($VERSION);
-
-use TAP::Parser::Iterator;
-
-# 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 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-=head1 DESCRIPTION
-
-Takes a command and hopefully returns a stream from it.
-
-=head1 SYNOPSIS
-
- use TAP::Parser::Source;
- my $source = TAP::Parser::Source->new;
- my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
-
-=head1 METHODS
-
-=head2 Class Methods
-
-=head3 C<new>
-
- my $source = TAP::Parser::Source->new;
-
-Returns a new C<TAP::Parser::Source> object.
-
-=cut
-
-sub new {
- my $class = shift;
- _autoflush( \*STDOUT );
- _autoflush( \*STDERR );
- bless { switches => [] }, $class;
-}
-
-##############################################################################
-
-=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.
-
-=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 stream of the output generated by executing C<source>.
-
-=cut
-
-sub get_stream {
- my ($self) = @_;
- my @command = $self->_get_command
- or $self->_croak("No command found!");
-
- return TAP::Parser::Iterator->new(
- { command => \@command,
- merge => $self->merge
- }
- );
-}
-
-sub _get_command { return @{ shift->source || [] } }
-
-##############################################################################
-
-=head3 C<error>
-
- unless ( my $stream = $source->get_stream ) {
- die $source->error;
- }
-
-If a stream cannot be created, this method will return the error.
-
-=cut
-
-sub error {
- my $self = shift;
- return $self->{error} unless @_;
- $self->{error} = shift;
- return $self;
-}
-
-##############################################################################
-
-=head3 C<exit>
-
- my $exit = $source->exit;
-
-Returns the exit status of the process I<if and only if> an error occurs in
-opening the file.
-
-=cut
-
-sub exit {
- my $self = shift;
- return $self->{exit} unless @_;
- $self->{exit} = shift;
- return $self;
-}
-
-##############################################################################
-
-=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;
-}
-
-sub _croak {
- my $self = shift;
- require Carp;
- Carp::croak(@_);
-}
-
-1;
Copied: branches/speedy/lib/TAP/Parser/Source.pm (from rev 269, trunk/lib/TAP/Parser/Source.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/Source.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/Source.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,172 @@
+package TAP::Parser::Source;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Iterator;
+
+# 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 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+=head1 DESCRIPTION
+
+Takes a command and hopefully returns a stream from it.
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new;
+ my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ _autoflush( \*STDOUT );
+ _autoflush( \*STDERR );
+ bless { switches => [] }, $class;
+}
+
+##############################################################################
+
+=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.
+
+=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 stream of the output generated by executing C<source>.
+
+=cut
+
+sub get_stream {
+ my ($self) = @_;
+ my @command = $self->_get_command
+ or $self->_croak("No command found!");
+
+ return TAP::Parser::Iterator->new(
+ { command => \@command,
+ merge => $self->merge
+ }
+ );
+}
+
+sub _get_command { return @{ shift->source || [] } }
+
+##############################################################################
+
+=head3 C<error>
+
+ unless ( my $stream = $source->get_stream ) {
+ die $source->error;
+ }
+
+If a stream cannot be created, this method will return the error.
+
+=cut
+
+sub error {
+ my $self = shift;
+ return $self->{error} unless @_;
+ $self->{error} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<exit>
+
+ my $exit = $source->exit;
+
+Returns the exit status of the process I<if and only if> an error occurs in
+opening the file.
+
+=cut
+
+sub exit {
+ my $self = shift;
+ return $self->{exit} unless @_;
+ $self->{exit} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=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;
+}
+
+sub _croak {
+ my $self = shift;
+ require Carp;
+ Carp::croak(@_);
+}
+
+1;
Deleted: branches/speedy/lib/TAP/Parser/YAMLish/Reader.pm
===================================================================
--- trunk/lib/TAP/Parser/YAMLish/Reader.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/YAMLish/Reader.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,331 +0,0 @@
-package TAP::Parser::YAMLish::Reader;
-
-use strict;
-
-use vars qw{$VERSION};
-
-$VERSION = '0.53';
-
-# 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;
-
-# Create an empty TAP::Parser::YAMLish::Reader object
-sub new {
- my $class = shift;
- bless {}, $class;
-}
-
-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;
-
- 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 {
- my $self = shift;
-
- if ( defined( my $capture = $self->{capture} ) ) {
- return join( "\n", @$capture ) . "\n";
- }
-
- return '';
-}
-
-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 '~';
-
- 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;
- push @multiline, $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 0.53
-
-=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 at 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 Andy Armstrong.
-
-Portions copyright 2006-2007 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
-
Copied: branches/speedy/lib/TAP/Parser/YAMLish/Reader.pm (from rev 269, trunk/lib/TAP/Parser/YAMLish/Reader.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/YAMLish/Reader.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/YAMLish/Reader.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,331 @@
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+
+use vars qw{$VERSION};
+
+$VERSION = '0.54';
+
+# 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;
+
+# Create an empty TAP::Parser::YAMLish::Reader object
+sub new {
+ my $class = shift;
+ bless {}, $class;
+}
+
+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;
+
+ 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 {
+ my $self = shift;
+
+ if ( defined( my $capture = $self->{capture} ) ) {
+ return join( "\n", @$capture ) . "\n";
+ }
+
+ return '';
+}
+
+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 '~';
+
+ 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;
+ push @multiline, $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 0.54
+
+=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 at 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 Andy Armstrong.
+
+Portions copyright 2006-2007 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
+
Deleted: branches/speedy/lib/TAP/Parser/YAMLish/Writer.pm
===================================================================
--- trunk/lib/TAP/Parser/YAMLish/Writer.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser/YAMLish/Writer.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,241 +0,0 @@
-package TAP::Parser::YAMLish::Writer;
-
-use strict;
-
-use vars qw{$VERSION};
-
-$VERSION = '0.53';
-
-my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }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
-);
-
-# Create an empty TAP::Parser::YAMLish::Writer object
-sub new {
- my $class = shift;
- bless {}, $class;
-}
-
-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;
-
- return '~' unless defined $val;
-
- if ( $val =~ /$ESCAPE_CHAR/ ) {
- $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;
- $self->_put($prefix);
- if ( 'HASH' eq $ref ) {
- for my $key ( sort keys %$obj ) {
- my $value = $obj->{$key};
- $self->_write_obj(
- $pad . $self->_enc_scalar($key) . ':',
- $value, $indent + 1
- );
- }
- }
- elsif ( 'ARRAY' eq $ref ) {
- for my $value (@$obj) {
- $self->_write_obj( $pad . '-', $value, $indent + 1 );
- }
- }
- else {
- die "Don't know how to enocde $ref";
- }
- }
- else {
- $self->_put( $prefix, ' ', $self->_enc_scalar($obj) );
- }
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-TAP::Parser::YAMLish::Writer - Write YAMLish data
-
-=head1 VERSION
-
-Version 0.53
-
-=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 at 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 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
-
Copied: branches/speedy/lib/TAP/Parser/YAMLish/Writer.pm (from rev 269, trunk/lib/TAP/Parser/YAMLish/Writer.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser/YAMLish/Writer.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser/YAMLish/Writer.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,241 @@
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+
+use vars qw{$VERSION};
+
+$VERSION = '0.54';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }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
+);
+
+# Create an empty TAP::Parser::YAMLish::Writer object
+sub new {
+ my $class = shift;
+ bless {}, $class;
+}
+
+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;
+
+ return '~' unless defined $val;
+
+ if ( $val =~ /$ESCAPE_CHAR/ ) {
+ $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;
+ $self->_put($prefix);
+ if ( 'HASH' eq $ref ) {
+ for my $key ( sort keys %$obj ) {
+ my $value = $obj->{$key};
+ $self->_write_obj(
+ $pad . $self->_enc_scalar($key) . ':',
+ $value, $indent + 1
+ );
+ }
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ for my $value (@$obj) {
+ $self->_write_obj( $pad . '-', $value, $indent + 1 );
+ }
+ }
+ else {
+ die "Don't know how to enocde $ref";
+ }
+ }
+ else {
+ $self->_put( $prefix, ' ', $self->_enc_scalar($obj) );
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 0.54
+
+=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 at 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 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
+
Deleted: branches/speedy/lib/TAP/Parser.pm
===================================================================
--- trunk/lib/TAP/Parser.pm 2007-08-18 19:18:07 UTC (rev 267)
+++ branches/speedy/lib/TAP/Parser.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -1,1474 +0,0 @@
-package TAP::Parser;
-
-use strict;
-use vars qw($VERSION @ISA);
-
-use TAP::Base;
-use TAP::Parser::Grammar;
-use TAP::Parser::Result;
-use TAP::Parser::Source;
-use TAP::Parser::Source::Perl;
-use TAP::Parser::Iterator;
-use Carp;
-
- at ISA = qw(TAP::Base);
-
-=head1 NAME
-
-TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
-
-=head1 VERSION
-
-Version 0.53
-
-=cut
-
-$VERSION = '0.53';
-
-my $DEFAULT_TAP_VERSION = 12;
-my $MAX_TAP_VERSION = 13;
-
-$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
-
-END {
-
- # For VMS.
- delete $ENV{TAP_VERSION};
-}
-
-BEGIN {
- foreach my $method (
- qw<
- _stream
- _spool
- _grammar
- _state
- exec
- exit
- is_good_plan
- plan
- tests_planned
- tests_run
- wait
- version
- in_todo
- >
- )
- {
- no strict 'refs';
-
- # another tiny performance hack
- if ( $method =~ /^_/ ) {
- *$method = sub {
- my $self = shift;
- return $self->{$method} unless @_;
- unless ( ( ref $self ) =~ /^TAP::Parser/ ) { # trusted methods
- Carp::croak("$method() may not be set externally");
- }
- $self->{$method} = shift;
- };
- }
- else {
- *$method = sub {
- my $self = shift;
- return $self->{$method} unless @_;
- $self->{$method} = shift;
- };
- }
- }
-}
-
-=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. It is
-ALPHA code and should be treated as such. The interface is now solid, but it
-is still subject to change.
-
-For an example of how to run tests through this module, see the simple
-harnesses C<examples/>.
-
-=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<spool>
-
-If passed a filehandle will write a copy of all parsed TAP to that handle.
-
-=item * C<merge>
-
-If false, STDERR is not captured (though it is 'relayed' to keep it
-somewhat synchronized with STDOUT.)
-
-If true, STDERR and STDOUT are the same filehandle. This may cause
-breakage if STDERR contains anything resembling TAP format, but does
-allow exact synchronization.
-
-Subtleties of this behavior may be platform-dependent and may change in
-the future.
-
-=back
-
-=cut
-
-# new implementation supplied by TAP::Base
-
-##############################################################################
-
-=head2 Instance Methods
-
-=head3 C<next>
-
- my $parser = TAP::Parser->new( { source => $file } );
- while ( my $result = $parser->next ) {
- print $result->as_string, "\n";
- }
-
-This method returns the results of the parsing, one result at a time. Note
-that it is destructive. You can't rewind and examine previous results.
-
-If callbacks are used, they will be issued before this call returns.
-
-Each result returned is a subclass of L<TAP::Parser::Result>. See that
-module and related classes for more information on how to use them.
-
-=cut
-
-sub next {
- my $self = shift;
- my $result = $self->_next;
-
- if ( defined $result ) {
- my $code;
- if ( $code = $self->_callback_for( $result->type ) ) {
- $code->($result);
- }
- else {
- $self->_make_callback( 'ELSE', $result );
- }
- $self->_make_callback( 'ALL', $result );
-
- # Echo TAP to spool file
- $self->_write_to_spool($result);
- }
- else {
- my $code;
- if ( $code = $self->_callback_for('EOF') ) {
- $code->($self);
- }
- }
-
- return $result;
-}
-
-sub _write_to_spool {
- my ( $self, $result ) = @_;
- my $spool = $self->_spool or return;
- print $spool $result->raw, "\n";
-}
-
-##############################################################################
-
-=head3 C<run>
-
- $parser->run;
-
-This method merely runs the parser and parses all of the TAP.
-
-=cut
-
-sub run {
- my $self = shift;
- while ( defined( my $result = $self->next ) ) {
-
- # do nothing
- }
-}
-
-{
-
- # of the following, anything beginning with an underscore is strictly
- # internal and should not be exposed.
- my %initialize = (
- _state => 'INIT',
- version => $DEFAULT_TAP_VERSION,
- plan => '', # the test plan (e.g., 1..3)
- tap => '', # the TAP
- tests_run => 0, # actual current test numbers
- results => [], # TAP parser results
- skipped => [], #
- todo => [], #
- passed => [], #
- failed => [], #
- actual_failed => [], # how many tests really failed
- actual_passed => [], # how many tests really passed
- todo_passed => [], # tests which unexpectedly succeed
- parse_errors => [], # perfect TAP should have none
- );
-
- # We seem to have this list hanging around all over the place. We could
- # probably get it from somewhere else to avoid the repetition.
- my @legal_callback = qw(
- test
- version
- plan
- comment
- bailout
- unknown
- yaml
- ALL
- ELSE
- EOF
- );
-
- sub _initialize {
- my ( $self, $arg_for ) = @_;
-
- # everything here is basically designed to convert any TAP source to a
- # stream.
- $arg_for ||= {};
-
- $self->SUPER::_initialize( $arg_for, \@legal_callback );
-
- # XXX why delete() ?
- my $stream = delete $arg_for->{stream};
- my $tap = delete $arg_for->{tap};
- my $source = delete $arg_for->{source};
- my $exec = delete $arg_for->{exec};
- my $merge = delete $arg_for->{merge};
- my $spool = delete $arg_for->{spool};
-
- if ( 1 < grep {defined} $stream, $tap, $source ) {
- $self->_croak(
- "You may only choose one of 'stream', 'tap', or 'source'");
- }
- if ( $source && $exec ) {
- $self->_croak(
- '"source" and "exec" are mutually exclusive options');
- }
- if ($tap) {
- $stream = TAP::Parser::Iterator->new( [ split "\n" => $tap ] );
- }
- elsif ($exec) {
- my $source = TAP::Parser::Source->new;
- $source->source($exec);
- $source->merge($merge); # XXX should just be arguments?
- $stream = $source->get_stream;
- if ( defined $stream ) {
- if ( defined $stream->exit ) {
- $self->exit( $stream->exit );
- }
- if ( defined $stream->wait ) {
- $self->wait( $stream->wait );
- }
- }
- }
- elsif ($source) {
- if ( my $ref = ref $source ) {
- $stream = TAP::Parser::Iterator->new($source);
- }
- elsif ( -e $source ) {
-
- my $perl = TAP::Parser::Source::Perl->new;
-
- $perl->switches( $arg_for->{switches} )
- if $arg_for->{switches};
-
- $perl->merge($merge); # XXX args to new()?
-
- $stream = $perl->source_file($source)->get_stream;
- if ( defined $stream ) {
- if ( defined $stream->exit ) {
- $self->exit( $stream->exit );
- }
- if ( defined $stream->wait ) {
- $self->wait( $stream->wait );
- }
- }
- }
- else {
- $self->_croak("Cannot determine source for $source");
- }
- }
-
- unless ($stream) {
- $self->_croak("PANIC: could not determine stream");
- }
-
- while ( my ( $k, $v ) = each %initialize ) {
- $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
- }
-
- $self->_stream($stream);
- my $grammar = TAP::Parser::Grammar->new($stream);
- $grammar->set_version( $self->version );
- $self->_grammar($grammar);
- $self->_spool($spool);
-
- return $self;
- }
-}
-
-=head1 INDIVIDUAL RESULTS
-
-If you've read this far in the docs, you've seen this:
-
- while ( my $result = $parser->next ) {
- print $result->as_string;
- }
-
-Each result returned is a L<TAP::Parser::Result> subclass, referred to as
-I<result types>.
-
-=head2 Result types
-
-Basically, you fetch individual results from the TAP. The six types, with
-examples of each, are as follows:
-
-=over 4
-
-=item * Version
-
- TAP version 12
-
-=item * Plan
-
- 1..42
-
-=item * Test
-
- ok 3 - We should start with some foobar!
-
-=item * Comment
-
- # Hope we don't use up the foobar.
-
-=item * Bailout
-
- Bail out! We ran out of foobar!
-
-=item * Unknown
-
- ... yo, this ain't TAP! ...
-
-=back
-
-Each result fetched is a result object of a different type. There are common
-methods to each result object and different types may have methods unique to
-their type. Sometimes a type method may be overridden in a subclass, but its
-use is guaranteed to be identical.
-
-=head2 Common type methods
-
-=head3 C<type>
-
-Returns the type of result, such as C<comment> or C<test>.
-
-=head3 C<as_string>
-
-Prints a string representation of the token. This might not be the exact
-output, however. Tests will have test numbers added if not present, TODO and
-SKIP directives will be capitalized and, in general, things will be cleaned
-up. If you need the original text for the token, see the C<raw> method.
-
-=head3 C<raw>
-
-Returns the original line of text which was parsed.
-
-=head3 C<is_plan>
-
-Indicates whether or not this is the test plan line.
-
-=head3 C<is_test>
-
-Indicates whether or not this is a test line.
-
-=head3 C<is_comment>
-
-Indicates whether or not this is a comment. Comments will generally only
-appear in the TAP stream if STDERR is merged to STDOUT. See the
-C<merge> option.
-
-=head3 C<is_bailout>
-
-Indicates whether or not this is bailout line.
-
-=head3 C<is_yaml>
-
-Indicates whether or not the current item is a YAML block.
-
-=head3 C<is_unknown>
-
-Indicates whether or not the current line could be parsed.
-
-=head3 C<is_ok>
-
- if ( $result->is_ok ) { ... }
-
-Reports whether or not a given result has passed. Anything which is B<not> a
-test result returns true. This is merely provided as a convenient shortcut
-which allows you to do this:
-
- my $parser = TAP::Parser->new( { source => $source } );
- while ( my $result = $parser->next ) {
- # only print failing results
- print $result->as_string unless $result->is_ok;
- }
-
-=head2 C<plan> methods
-
- if ( $result->is_plan ) { ... }
-
-If the above evaluates as true, the following methods will be available on the
-C<$result> object.
-
-=head3 C<plan>
-
- if ( $result->is_plan ) {
- print $result->plan;
- }
-
-This is merely a synonym for C<as_string>.
-
-=head3 C<tests_planned>
-
- my $planned = $result->tests_planned;
-
-Returns the number of tests planned. For example, a plan of C<1..17> will
-cause this method to return '17'.
-
-=head3 C<directive>
-
- my $directive = $result->directive;
-
-If a SKIP directive is included with the plan, this method will return it.
-
- 1..0 # SKIP: why bother?
-
-=head3 C<explanation>
-
- my $explanation = $result->explanation;
-
-If a SKIP directive was included with the plan, this method will return the
-explanation, if any.
-
-=head2 C<commment> methods
-
- if ( $result->is_comment ) { ... }
-
-If the above evaluates as true, the following methods will be available on the
-C<$result> object.
-
-=head3 C<comment>
-
- if ( $result->is_comment ) {
- my $comment = $result->comment;
- print "I have something to say: $comment";
- }
-
-=head2 C<bailout> methods
-
- if ( $result->is_bailout ) { ... }
-
-If the above evaluates as true, the following methods will be available on the
-C<$result> object.
-
-=head3 C<explanation>
-
- if ( $result->is_bailout ) {
- my $explanation = $result->explanation;
- print "We bailed out because ($explanation)";
- }
-
-If, and only if, a token is a bailout token, you can get an "explanation" via
-this method. The explanation is the text after the mystical "Bail out!" words
-which appear in the tap output.
-
-=head2 C<unknown> methods
-
- if ( $result->is_unknown ) { ... }
-
-There are no unique methods for unknown results.
-
-=head2 C<test> methods
-
- if ( $result->is_test ) { ... }
-
-If the above evaluates as true, the following methods will be available on the
-C<$result> object.
-
-=head3 C<ok>
-
- my $ok = $result->ok;
-
-Returns the literal text of the C<ok> or C<not ok> status.
-
-=head3 C<number>
-
- my $test_number = $result->number;
-
-Returns the number of the test, even if the original TAP output did not supply
-that number.
-
-=head3 C<description>
-
- my $description = $result->description;
-
-Returns the description of the test, if any. This is the portion after the
-test number but before the directive.
-
-=head3 C<directive>
-
- my $directive = $result->directive;
-
-Returns either C<TODO> or C<SKIP> if either directive was present for a test
-line.
-
-=head3 C<explanation>
-
- my $explanation = $result->explanation;
-
-If a test had either a C<TODO> or C<SKIP> directive, this method will return
-the accompanying explantion, if present.
-
- not ok 17 - 'Pigs can fly' # TODO not enough acid
-
-For the above line, the explanation is I<not enough acid>.
-
-=head3 C<is_ok>
-
- if ( $result->is_ok ) { ... }
-
-Returns a boolean value indicating whether or not the test passed. Remember
-that for TODO tests, the test always passes.
-
-B<Note:> this was formerly C<passed>. The latter method is deprecated and
-will issue a warning.
-
-=head3 C<is_actual_ok>
-
- if ( $result->is_actual_ok ) { ... }
-
-Returns a boolean value indicating whether or not the test passed, regardless
-of its TODO status.
-
-B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
-and will issue a warning.
-
-=head3 C<is_unplanned>
-
- if ( $test->is_unplanned ) { ... }
-
-If a test number is greater than the number of planned tests, this method will
-return true. Unplanned tests will I<always> return false for C<is_ok>,
-regardless of whether or not the test C<has_todo> (see
-L<TAP::Parser::Result::Test> for more information about this).
-
-=head3 C<has_skip>
-
- if ( $result->has_skip ) { ... }
-
-Returns a boolean value indicating whether or not this test had a SKIP
-directive.
-
-=head3 C<has_todo>
-
- if ( $result->has_todo ) { ... }
-
-Returns a boolean value indicating whether or not this test had a TODO
-directive.
-
-Note that TODO tests I<always> pass. If you need to know whether or not
-they really passed, check the C<is_actual_ok> method.
-
-=head3 C<in_todo>
-
- if ( $parser->in_todo ) { ... }
-
-True while the most recent result was a TODO. Becomes true before the
-TODO result is returned and stays true until just before the next non-
-TODO test is returned.
-
-=head1 TOTAL RESULTS
-
-After parsing the TAP, there are many methods available to let you dig through
-the results and determine what is meaningful to you.
-
-=head2 Individual Results
-
-These results refer to individual tests which are run.
-
-=head3 C<passed>
-
- my @passed = $parser->passed; # the test numbers which passed
- my $passed = $parser->passed; # the number of tests which passed
-
-This method lets you know which (or how many) tests passed. If a test failed
-but had a TODO directive, it will be counted as a passed test.
-
-=cut
-
-sub passed { @{ shift->{passed} } }
-
-=head3 C<failed>
-
- my @failed = $parser->failed; # the test numbers which failed
- my $failed = $parser->failed; # the number of tests which failed
-
-This method lets you know which (or how many) tests failed. If a test passed
-but had a TODO directive, it will B<NOT> be counted as a failed test.
-
-=cut
-
-sub failed { @{ shift->{failed} } }
-
-=head3 C<actual_passed>
-
- # the test numbers which actually passed
- my @actual_passed = $parser->actual_passed;
-
- # the number of tests which actually passed
- my $actual_passed = $parser->actual_passed;
-
-This method lets you know which (or how many) tests actually passed,
-regardless of whether or not a TODO directive was found.
-
-=cut
-
-sub actual_passed { @{ shift->{actual_passed} } }
-*actual_ok = \&actual_passed;
-
-=head3 C<actual_ok>
-
-This method is a synonym for C<actual_passed>.
-
-=head3 C<actual_failed>
-
- # the test numbers which actually failed
- my @actual_failed = $parser->actual_failed;
-
- # the number of tests which actually failed
- my $actual_failed = $parser->actual_failed;
-
-This method lets you know which (or how many) tests actually failed,
-regardless of whether or not a TODO directive was found.
-
-=cut
-
-sub actual_failed { @{ shift->{actual_failed} } }
-
-##############################################################################
-
-=head3 C<todo>
-
- my @todo = $parser->todo; # the test numbers with todo directives
- my $todo = $parser->todo; # the number of tests with todo directives
-
-This method lets you know which (or how many) tests had TODO directives.
-
-=cut
-
-sub todo { @{ shift->{todo} } }
-
-=head3 C<todo_passed>
-
- # the test numbers which unexpectedly succeeded
- my @todo_passed = $parser->todo_passed;
-
- # the number of tests which unexpectedly succeeded
- my $todo_passed = $parser->todo_passed;
-
-This method lets you know which (or how many) tests actually passed but were
-declared as "TODO" tests.
-
-=cut
-
-sub todo_passed { @{ shift->{todo_passed} } }
-
-##############################################################################
-
-=head3 C<todo_failed>
-
- # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
-
-This was a badly misnamed method. It indicates which TODO tests unexpectedly
-succeeded. Will now issue a warning and call C<todo_passed>.
-
-=cut
-
-sub todo_failed {
- warn
- '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
- goto &todo_passed;
-}
-
-=head3 C<skipped>
-
- my @skipped = $parser->skipped; # the test numbers with SKIP directives
- my $skipped = $parser->skipped; # the number of tests with SKIP directives
-
-This method lets you know which (or how many) tests had SKIP directives.
-
-=cut
-
-sub skipped { @{ shift->{skipped} } }
-
-=head2 Summary Results
-
-These results are "meta" information about the total results of an individual
-test program.
-
-=head3 C<plan>
-
- my $plan = $parser->plan;
-
-Returns the test plan, if found.
-
-=head3 C<good_plan>
-
-Deprecated. Use C<is_good_plan> instead.
-
-=cut
-
-sub good_plan {
- warn 'good_plan() is deprecated. Please use "is_good_plan()"';
- goto &is_good_plan;
-}
-
-##############################################################################
-
-=head3 C<is_good_plan>
-
- if ( $parser->is_good_plan ) { ... }
-
-Returns a boolean value indicating whether or not the number of tests planned
-matches the number of tests run.
-
-B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
-will issue a warning.
-
-And since we're on that subject ...
-
-=head3 C<tests_planned>
-
- print $parser->tests_planned;
-
-Returns the number of tests planned, according to the plan. For example, a
-plan of '1..17' will mean that 17 tests were planned.
-
-=head3 C<tests_run>
-
- print $parser->tests_run;
-
-Returns the number of tests which actually were run. Hopefully this will
-match the number of C<< $parser->tests_planned >>.
-
-=head3 C<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->todo_passed
- || $self->parse_errors
- || $self->wait
- || $self->exit;
-}
-
-=head3 C<version>
-
- $parser->version;
-
-Once the parser is done, this will return the version number for the
-parsed TAP. Version numbers were introduced with TAP version 13 so if no
-version number is found version 12 is assumed.
-
-=head3 C<exit>
-
- $parser->exit;
-
-Once the parser is done, this will return the exit status. If the parser ran
-an executable, it returns the exit status of the executable.
-
-=head3 C<wait>
-
- $parser->wait;
-
-Once the parser is done, this will return the wait status. If the parser ran
-an executable, it returns the wait status of the executable. Otherwise, this
-mererely returns the C<exit> status.
-
-=head3 C<parse_errors>
-
- my @errors = $parser->parse_errors; # the parser errors
- my $errors = $parser->parse_errors; # the number of parser_errors
-
-Fortunately, all TAP output is perfect. In the event that it is not, this
-method will return parser errors. Note that a junk line which the parser does
-not recognize is C<not> an error. This allows this parser to handle future
-versions of TAP. The following are all TAP errors reported by the parser:
-
-=over 4
-
-=item * Misplaced plan
-
-The plan (for example, '1..5'), must only come at the beginning or end of the
-TAP output.
-
-=item * No plan
-
-Gotta have a plan!
-
-=item * More than one plan
-
- 1..3
- ok 1 - input file opened
- not ok 2 - first line of the input valid # todo some data
- ok 3 read the rest of the file
- 1..3
-
-Right. Very funny. Don't do that.
-
-=item * Test numbers out of sequence
-
- 1..3
- ok 1 - input file opened
- not ok 2 - first line of the input valid # todo some data
- ok 2 read the rest of the file
-
-That last test line above should have the number '3' instead of '2'.
-
-Note that it's perfectly acceptable for some lines to have test numbers and
-others to not have them. However, when a test number is found, it must be in
-sequence. The following is also an error:
-
- 1..3
- ok 1 - input file opened
- not ok - first line of the input valid # todo some data
- ok 2 read the rest of the file
-
-But this is not:
-
- 1..3
- ok - input file opened
- not ok - first line of the input valid # todo some data
- ok 3 read the rest of the file
-
-=back
-
-=cut
-
-sub parse_errors { @{ shift->{parse_errors} } }
-
-sub _add_error {
- my ( $self, $error ) = @_;
- push @{ $self->{parse_errors} } => $error;
- return $self;
-}
-
-sub _aggregate_results {
- my ( $self, $test ) = @_;
-
- my $num = $test->number;
-
- push @{ $self->{todo} } => $num if $test->has_todo;
- push @{ $self->{todo_passed} } => $num if $test->todo_passed;
- push @{ $self->{passed} } => $num if $test->is_ok;
- push @{ $self->{actual_passed} } => $num if $test->is_actual_ok;
- push @{ $self->{skipped} } => $num if $test->has_skip;
-
- push @{ $self->{actual_failed} } => $num if !$test->is_actual_ok;
- push @{ $self->{failed} } => $num if !$test->is_ok;
-}
-
-sub _next {
- my $self = shift;
- my $stream = $self->_stream;
-
- my $result = eval { $self->_grammar->tokenize };
- $self->_add_error($@) if $@;
-
- if ($result) {
- $self->_next_state($result);
- }
- else {
- $self->exit( $stream->exit );
- $self->wait( $stream->wait );
- $self->_finish;
- }
-
- return $result;
-}
-
-my %states;
-
-BEGIN {
-
- # These transitions are defaults for all states
- my %state_globals = (
- comment => {},
- bailout => {},
- version => {
- act => sub {
- my ( $self, $version ) = @_;
- local *__ANON__ = '__ANON__bad_version_handler';
- $self->_add_error(
- "If TAP version is present it must be the first line of output"
- );
- },
- },
- );
-
- # Provides default elements for transitions
- my %state_defaults = (
- plan => {
- act => sub {
- my ( $self, $plan ) = @_;
- local *__ANON__ = '__ANON__plan_handler';
- $self->tests_planned( $plan->tests_planned );
- $self->plan( $plan->plan );
- },
- },
- test => {
- act => sub {
- my ( $self, $test ) = @_;
- local *__ANON__ = '__ANON__test_handler';
-
- $self->in_todo( $test->has_todo );
- $self->tests_run( $self->tests_run + 1 );
- if ( defined( my $tests_planned = $self->tests_planned ) ) {
- if ( $self->tests_run > $tests_planned ) {
- $test->is_unplanned(1);
- }
- }
-
- if ( $test->number ) {
- if ( $test->number != $self->tests_run ) {
- my $number = $test->number;
- my $count = $self->tests_run;
- $self->_add_error(
- "Tests out of sequence. Found ($number) but expected ($count)"
- );
- }
- }
- else {
- $test->_number( $self->tests_run );
- }
- $self->_aggregate_results($test);
- },
- },
- yaml => {
- act => sub {
- my ( $self, $test ) = @_;
- local *__ANON__ = '__ANON__yaml_handler';
- },
- },
- );
-
-# 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 ( $self, $version ) = @_;
- local *__ANON__ = '__ANON__version_handler';
- 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 "
- . "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 ( $self, $version ) = @_;
- local *__ANON__ = '__ANON__multiple_plan_handler';
- $self->_add_error(
- "More than one plan found in TAP output");
- },
- },
- },
- PLANNED_AFTER_TEST => {
- test => { act => sub { }, continue => 'PLANNED' },
- plan => { act => sub { }, continue => 'PLANNED' },
- yaml => { goto => 'PLANNED' },
- },
- GOT_PLAN => {
- test => {
- act => sub {
- my ( $self, $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 => {
- act => sub { },
- 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 ( keys %$st ) {
- if ( my $default = $state_defaults{$next} ) {
- for my $def ( keys %$default ) {
- $st->{$next}->{$def} ||= $default->{$def};
- }
- }
- }
-
- # Stuff back in table
- $states{$name} = $st;
- }
-}
-
-# Advance the state machine
-sub _next_state {
- my $self = shift;
- my $token = shift;
-
- my $state = $states{ $self->_state }
- or die "Illegal state: ", $self->_state;
-
- my $type = $token->type;
-
- if ( my $next = $state->{$type} ) {
- if ( my $act = $next->{act} ) {
- $self->$act($token);
- }
-
- if ( my $cont = $next->{continue} ) {
- $self->_state($cont);
- $self->_next_state($token);
- }
- elsif ( my $goto = $next->{goto} ) {
- $self->_state($goto);
- }
- }
-}
-
-sub _finish {
- my $self = shift;
-
- # 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;
-}
-
-##############################################################################
-
-=head1 CALLBACKS
-
-As mentioned earlier, a "callback" key may be added to the
-C<TAP::Parser> constructor. If present, each callback corresponding to a
-given result type will be called with the result as the argument if the
-C<run> method is used. The callback is expected to be a subroutine
-reference (or anonymous subroutine) which is invoked with the parser
-result as its argument.
-
- my %callbacks = (
- test => \&test_callback,
- plan => \&plan_callback,
- comment => \&comment_callback,
- bailout => \&bailout_callback,
- unknown => \&unknown_callback,
- );
-
- my $aggregator = TAP::Parser::Aggregator->new;
- foreach my $file ( @test_files ) {
- my $parser = TAP::Parser->new(
- {
- source => $file,
- callbacks => \%callbacks,
- }
- );
- $parser->run;
- $aggregator->add( $file, $parser );
- }
-
-Callbacks may also be added like this:
-
- $parser->callback( test => \&test_callback );
- $parser->callback( plan => \&plan_callback );
-
-The following keys allowed for callbacks. These keys are case-sensitive.
-
-=over 4
-
-=item * C<test>
-
-Invoked if C<< $result->is_test >> returns true.
-
-=item * C<version>
-
-Invoked if C<< $result->is_version >> returns true.
-
-=item * C<plan>
-
-Invoked if C<< $result->is_plan >> returns true.
-
-=item * C<comment>
-
-Invoked if C<< $result->is_comment >> returns true.
-
-=item * C<bailout>
-
-Invoked if C<< $result->is_unknown >> returns true.
-
-=item * C<yaml>
-
-Invoked if C<< $result->is_yaml >> returns true.
-
-=item * C<unknown>
-
-Invoked if C<< $result->is_unknown >> returns true.
-
-=item * C<ELSE>
-
-If a result does not have a callback defined for it, this callback will be
-invoked. Thus, if all of the previous result types are specified as callbacks,
-this callback will I<never> be invoked.
-
-=item * C<ALL>
-
-This callback will always be invoked and this will happen for each
-result after one of the above callbacks is invoked. For example, if
-L<Term::ANSIColor> is loaded, you could use the following to color your
-test output:
-
- my %callbacks = (
- test => sub {
- my $test = shift;
- if ( $test->is_ok && not $test->directive ) {
- # normal passing test
- print color 'green';
- }
- elsif ( !$test->is_ok ) { # even if it's TODO
- print color 'white on_red';
- }
- elsif ( $test->has_skip ) {
- print color 'white on_blue';
-
- }
- elsif ( $test->has_todo ) {
- print color 'white';
- }
- },
- ELSE => sub {
- # plan, comment, and so on (anything which isn't a test line)
- print color 'black on_white';
- },
- ALL => sub {
- # now print them
- print shift->as_string;
- print color 'reset';
- print "\n";
- },
- );
-
-=item * C<EOF>
-
-Invoked when there are no more lines to be parsed. Since there is
-no accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
-passed instead.
-
-=back
-
-=head1 TAP GRAMMAR
-
-If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
-
-=head1 BACKWARDS COMPATABILITY
-
-The Perl-QA list attempted to ensure backwards compatability with
-L<Test::Harness>. However, there are some minor differences.
-
-=head2 Differences
-
-=over 4
-
-=item * TODO plans
-
-A little-known feature of L<Test::Harness> is that it supported TODO lists in
-the plan:
-
- 1..2 todo 2
- ok 1 - We have liftoff
- not ok 2 - Anti-gravity device activated
-
-Under L<Test::Harness>, test number 2 would I<pass> because it was listed as a
-TODO test on the plan line. However, we are not aware of anyone actually
-using this feature and hard-coding test numbers is discouraged because it's
-very easy to add a test and break the test number sequence. This makes test
-suites very fragile. Instead, the following should be used:
-
- 1..2
- ok 1 - We have liftoff
- not ok 2 - Anti-gravity device activated # TODO
-
-=item * 'Missing' tests
-
-It rarely happens, but sometimes a harness might encounter 'missing tests:
-
- ok 1
- ok 2
- ok 15
- ok 16
- ok 17
-
-L<Test::Harness> would report tests 3-14 as having failed. For the
-C<TAP::Parser>, these tests are not considered failed because they've never
-run. They're reported as parse failures (tests out of sequence).
-
-=back
-
-=head1 ACKNOWLEDGEMENTS
-
-All of the following have helped. Bug reports, patches, (im)moral support, or
-just words of encouragement have all been forthcoming.
-
-=over 4
-
-=item * Michael Schwern
-
-=item * Andy Lester
-
-=item * chromatic
-
-=item * GEOFFR
-
-=item * Shlomi Fish
-
-=item * Torsten Schoenfeld
-
-=item * Jerry Gay
-
-=item * Aristotle
-
-=item * Adam Kennedy
-
-=item * Yves Orton
-
-=item * Adrian Howard
-
-=item * Sean & Lil
-
-=item * Andreas J. Koenig
-
-=item * Florian Ragwitz
-
-=item * Corion
-
-=item * Mark Stosberg
-
-=item * Matt Kraai
-
-=back
-
-=head1 AUTHORS
-
-Curtis "Ovid" Poe <ovid at cpan.org>
-
-Andy Armstong <andy at hexten.net>
-
-Eric Wilhelm @ <ewilhelm at cpan dot org>
-
-=head1 BUGS
-
-Please report any bugs or feature requests to
-C<bug-tapx-parser at rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
-I will be notified, and then you'll automatically be notified of progress on
-your bug as I 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 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;
Copied: branches/speedy/lib/TAP/Parser.pm (from rev 270, trunk/lib/TAP/Parser.pm)
===================================================================
--- branches/speedy/lib/TAP/Parser.pm (rev 0)
+++ branches/speedy/lib/TAP/Parser.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -0,0 +1,1495 @@
+package TAP::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Base;
+use TAP::Parser::Grammar;
+use TAP::Parser::Result;
+use TAP::Parser::Source;
+use TAP::Parser::Source::Perl;
+use TAP::Parser::Iterator;
+use Carp;
+
+ at ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 0.54
+
+=cut
+
+$VERSION = '0.54';
+
+my $DEFAULT_TAP_VERSION = 12;
+my $MAX_TAP_VERSION = 13;
+
+$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{TAP_VERSION};
+}
+
+BEGIN {
+ foreach my $method (
+ qw<
+ _stream
+ _spool
+ _grammar
+ exec
+ exit
+ is_good_plan
+ plan
+ tests_planned
+ tests_run
+ wait
+ version
+ in_todo
+ >
+ )
+ {
+ no strict 'refs';
+
+ # another tiny performance hack
+ if ( $method =~ /^_/ ) {
+ *$method = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ unless ( ( ref $self ) =~ /^TAP::Parser/ ) { # trusted methods
+ Carp::croak("$method() may not be set externally");
+ }
+ $self->{$method} = shift;
+ };
+ }
+ else {
+ *$method = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+}
+
+=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. It is
+ALPHA code and should be treated as such. The interface is now solid, but it
+is still subject to change.
+
+For an example of how to run tests through this module, see the simple
+harnesses C<examples/>.
+
+=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<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+If false, STDERR is not captured (though it is 'relayed' to keep it
+somewhat synchronized with STDOUT.)
+
+If true, STDERR and STDOUT are the same filehandle. This may cause
+breakage if STDERR contains anything resembling TAP format, but does
+allow exact synchronization.
+
+Subtleties of this behavior may be platform-dependent and may change in
+the future.
+
+=back
+
+=cut
+
+# new implementation supplied by TAP::Base
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ my $parser = TAP::Parser->new( { source => $file } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This method returns the results of the parsing, one result at a time. Note
+that it is destructive. You can't rewind and examine previous results.
+
+If callbacks are used, they will be issued before this call returns.
+
+Each result returned is a subclass of L<TAP::Parser::Result>. See that
+module and related classes for more information on how to use them.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+##############################################################################
+
+=head3 C<run>
+
+ $parser->run;
+
+This method merely runs the parser and parses all of the TAP.
+
+=cut
+
+sub run {
+ my $self = shift;
+ while ( defined( my $result = $self->next ) ) {
+
+ # do nothing
+ }
+}
+
+{
+
+ # of the following, anything beginning with an underscore is strictly
+ # internal and should not be exposed.
+ my %initialize = (
+ version => $DEFAULT_TAP_VERSION,
+ plan => '', # the test plan (e.g., 1..3)
+ tap => '', # the TAP
+ tests_run => 0, # actual current test numbers
+ results => [], # TAP parser results
+ skipped => [], #
+ todo => [], #
+ passed => [], #
+ failed => [], #
+ actual_failed => [], # how many tests really failed
+ actual_passed => [], # how many tests really passed
+ todo_passed => [], # tests which unexpectedly succeed
+ parse_errors => [], # perfect TAP should have none
+ );
+
+ # We seem to have this list hanging around all over the place. We could
+ # probably get it from somewhere else to avoid the repetition.
+ my @legal_callback = qw(
+ test
+ version
+ plan
+ comment
+ bailout
+ unknown
+ yaml
+ ALL
+ ELSE
+ EOF
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ # everything here is basically designed to convert any TAP source to a
+ # stream.
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+
+ # XXX why delete() ?
+ my $stream = delete $arg_for->{stream};
+ my $tap = delete $arg_for->{tap};
+ my $source = delete $arg_for->{source};
+ my $exec = delete $arg_for->{exec};
+ my $merge = delete $arg_for->{merge};
+ my $spool = delete $arg_for->{spool};
+
+ if ( 1 < grep {defined} $stream, $tap, $source ) {
+ $self->_croak(
+ "You may only choose one of 'stream', 'tap', or 'source'");
+ }
+ if ( $source && $exec ) {
+ $self->_croak(
+ '"source" and "exec" are mutually exclusive options');
+ }
+ if ($tap) {
+ $stream = TAP::Parser::Iterator->new( [ split "\n" => $tap ] );
+ }
+ elsif ($exec) {
+ my $source = TAP::Parser::Source->new;
+ $source->source($exec);
+ $source->merge($merge); # XXX should just be arguments?
+ $stream = $source->get_stream;
+ if ( defined $stream ) {
+ if ( defined $stream->exit ) {
+ $self->exit( $stream->exit );
+ }
+ if ( defined $stream->wait ) {
+ $self->wait( $stream->wait );
+ }
+ }
+ }
+ elsif ($source) {
+ if ( my $ref = ref $source ) {
+ $stream = TAP::Parser::Iterator->new($source);
+ }
+ elsif ( -e $source ) {
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+ $perl->switches( $arg_for->{switches} )
+ if $arg_for->{switches};
+
+ $perl->merge($merge); # XXX args to new()?
+
+ $stream = $perl->source_file($source)->get_stream;
+ if ( defined $stream ) {
+ if ( defined $stream->exit ) {
+ $self->exit( $stream->exit );
+ }
+ if ( defined $stream->wait ) {
+ $self->wait( $stream->wait );
+ }
+ }
+ }
+ else {
+ $self->_croak("Cannot determine source for $source");
+ }
+ }
+
+ unless ($stream) {
+ $self->_croak("PANIC: could not determine stream");
+ }
+
+ while ( my ( $k, $v ) = each %initialize ) {
+ $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
+ }
+
+ $self->_stream($stream);
+ my $grammar = TAP::Parser::Grammar->new($stream);
+ $grammar->set_version( $self->version );
+ $self->_grammar($grammar);
+ $self->_spool($spool);
+
+ return $self;
+ }
+}
+
+=head1 INDIVIDUAL RESULTS
+
+If you've read this far in the docs, you've seen this:
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+Each result returned is a L<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=head2 Result types
+
+Basically, you fetch individual results from the TAP. The six types, with
+examples of each, are as follows:
+
+=over 4
+
+=item * Version
+
+ TAP version 12
+
+=item * Plan
+
+ 1..42
+
+=item * Test
+
+ ok 3 - We should start with some foobar!
+
+=item * Comment
+
+ # Hope we don't use up the foobar.
+
+=item * Bailout
+
+ Bail out! We ran out of foobar!
+
+=item * Unknown
+
+ ... yo, this ain't TAP! ...
+
+=back
+
+Each result fetched is a result object of a different type. There are common
+methods to each result object and different types may have methods unique to
+their type. Sometimes a type method may be overridden in a subclass, but its
+use is guaranteed to be identical.
+
+=head2 Common type methods
+
+=head3 C<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+Indicates whether or not this is a comment. Comments will generally only
+appear in the TAP stream if STDERR is merged to STDOUT. See the
+C<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut
+which allows you to do this:
+
+ my $parser = TAP::Parser->new( { source => $source } );
+ while ( my $result = $parser->next ) {
+ # only print failing results
+ print $result->as_string unless $result->is_ok;
+ }
+
+=head2 C<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<tests_planned>
+
+ my $planned = $result->tests_planned;
+
+Returns the number of tests planned. For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=head2 C<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+B<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ if ( $parser->in_todo ) { ... }
+
+True while the most recent result was a TODO. Becomes true before the
+TODO result is returned and stays true until just before the next non-
+TODO test is returned.
+
+=head1 TOTAL RESULTS
+
+After parsing the TAP, there are many methods available to let you dig through
+the results and determine what is meaningful to you.
+
+=head2 Individual Results
+
+These results refer to individual tests which are run.
+
+=head3 C<passed>
+
+ my @passed = $parser->passed; # the test numbers which passed
+ my $passed = $parser->passed; # the number of tests which passed
+
+This method lets you know which (or how many) tests passed. If a test failed
+but had a TODO directive, it will be counted as a passed test.
+
+=cut
+
+sub passed { @{ shift->{passed} } }
+
+=head3 C<failed>
+
+ my @failed = $parser->failed; # the test numbers which failed
+ my $failed = $parser->failed; # the number of tests which failed
+
+This method lets you know which (or how many) tests failed. If a test passed
+but had a TODO directive, it will B<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # the test numbers which actually passed
+ my @actual_passed = $parser->actual_passed;
+
+ # the number of tests which actually passed
+ my $actual_passed = $parser->actual_passed;
+
+This method lets you know which (or how many) tests actually passed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_passed { @{ shift->{actual_passed} } }
+*actual_ok = \&actual_passed;
+
+=head3 C<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # the test numbers which actually failed
+ my @actual_failed = $parser->actual_failed;
+
+ # the number of tests which actually failed
+ my $actual_failed = $parser->actual_failed;
+
+This method lets you know which (or how many) tests actually failed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_failed { @{ shift->{actual_failed} } }
+
+##############################################################################
+
+=head3 C<todo>
+
+ my @todo = $parser->todo; # the test numbers with todo directives
+ my $todo = $parser->todo; # the number of tests with todo directives
+
+This method lets you know which (or how many) tests had TODO directives.
+
+=cut
+
+sub todo { @{ shift->{todo} } }
+
+=head3 C<todo_passed>
+
+ # the test numbers which unexpectedly succeeded
+ my @todo_passed = $parser->todo_passed;
+
+ # the number of tests which unexpectedly succeeded
+ my $todo_passed = $parser->todo_passed;
+
+This method lets you know which (or how many) tests actually passed but were
+declared as "TODO" tests.
+
+=cut
+
+sub todo_passed { @{ shift->{todo_passed} } }
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ my @skipped = $parser->skipped; # the test numbers with SKIP directives
+ my $skipped = $parser->skipped; # the number of tests with SKIP directives
+
+This method lets you know which (or how many) tests had SKIP directives.
+
+=cut
+
+sub skipped { @{ shift->{skipped} } }
+
+=head2 Summary Results
+
+These results are "meta" information about the total results of an individual
+test program.
+
+=head3 C<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ if ( $parser->is_good_plan ) { ... }
+
+Returns a boolean value indicating whether or not the number of tests planned
+matches the number of tests run.
+
+B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ print $parser->tests_planned;
+
+Returns the number of tests planned, according to the plan. For example, a
+plan of '1..17' will mean that 17 tests were planned.
+
+=head3 C<tests_run>
+
+ print $parser->tests_run;
+
+Returns the number of tests which actually were run. Hopefully this will
+match the number of C<< $parser->tests_planned >>.
+
+=head3 C<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->todo_passed
+ || $self->parse_errors
+ || $self->wait
+ || $self->exit;
+}
+
+=head3 C<version>
+
+ $parser->version;
+
+Once the parser is done, this will return the version number for the
+parsed TAP. Version numbers were introduced with TAP version 13 so if no
+version number is found version 12 is assumed.
+
+=head3 C<exit>
+
+ $parser->exit;
+
+Once the parser is done, this will return the exit status. If the parser ran
+an executable, it returns the exit status of the executable.
+
+=head3 C<wait>
+
+ $parser->wait;
+
+Once the parser is done, this will return the wait status. If the parser ran
+an executable, it returns the wait status of the executable. Otherwise, this
+mererely returns the C<exit> status.
+
+=head3 C<parse_errors>
+
+ my @errors = $parser->parse_errors; # the parser errors
+ my $errors = $parser->parse_errors; # the number of parser_errors
+
+Fortunately, all TAP output is perfect. In the event that it is not, this
+method will return parser errors. Note that a junk line which the parser does
+not recognize is C<not> an error. This allows this parser to handle future
+versions of TAP. The following are all TAP errors reported by the parser:
+
+=over 4
+
+=item * Misplaced plan
+
+The plan (for example, '1..5'), must only come at the beginning or end of the
+TAP output.
+
+=item * No plan
+
+Gotta have a plan!
+
+=item * More than one plan
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+ 1..3
+
+Right. Very funny. Don't do that.
+
+=item * Test numbers out of sequence
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+That last test line above should have the number '3' instead of '2'.
+
+Note that it's perfectly acceptable for some lines to have test numbers and
+others to not have them. However, when a test number is found, it must be in
+sequence. The following is also an error:
+
+ 1..3
+ ok 1 - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+But this is not:
+
+ 1..3
+ ok - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+
+=back
+
+=cut
+
+sub parse_errors { @{ shift->{parse_errors} } }
+
+sub _add_error {
+ my ( $self, $error ) = @_;
+ push @{ $self->{parse_errors} } => $error;
+ return $self;
+}
+
+sub _make_state_table {
+ my $self = shift;
+
+ my %states;
+
+ # These transitions are defaults for all states
+ my %state_globals = (
+ comment => {},
+ bailout => {},
+ version => {
+ act => sub {
+ my ($version) = @_;
+ local *__ANON__ = '__ANON__bad_version_handler';
+ $self->_add_error(
+ "If TAP version is present it must be the first line of output"
+ );
+ },
+ },
+ );
+
+ # Provides default elements for transitions
+ my %state_defaults = (
+ plan => {
+ act => sub {
+ my ($plan) = @_;
+ local *__ANON__ = '__ANON__plan_handler';
+ $self->tests_planned( $plan->tests_planned );
+ $self->plan( $plan->plan );
+ },
+ },
+ test => {
+ act => sub {
+ my ($test) = @_;
+ local *__ANON__ = '__ANON__test_handler';
+
+ $self->in_todo( $test->has_todo );
+ $self->{tests_run}++;
+ if ( defined( my $tests_planned = $self->tests_planned ) ) {
+ if ( $self->tests_run > $tests_planned ) {
+ $test->is_unplanned(1);
+ }
+ }
+
+ if ( $test->number ) {
+ if ( $test->number != $self->tests_run ) {
+ my $number = $test->number;
+ my $count = $self->tests_run;
+ $self->_add_error(
+ "Tests out of sequence. Found ($number) but expected ($count)"
+ );
+ }
+ }
+ else {
+ $test->_number( $self->tests_run );
+ }
+
+ my $num = $test->number;
+
+ push @{ $self->{todo} } => $num if $test->has_todo;
+ push @{ $self->{todo_passed} } => $num if $test->todo_passed;
+ push @{ $self->{passed} } => $num if $test->is_ok;
+ push @{ $self->{actual_passed} } => $num
+ if $test->is_actual_ok;
+ push @{ $self->{skipped} } => $num if $test->has_skip;
+
+ push @{ $self->{actual_failed} } => $num
+ if !$test->is_actual_ok;
+ push @{ $self->{failed} } => $num if !$test->is_ok;
+ },
+ },
+ yaml => {
+ act => sub {
+ my ($test) = @_;
+ local *__ANON__ = '__ANON__yaml_handler';
+ },
+ },
+ );
+
+# 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) = @_;
+ local *__ANON__ = '__ANON__version_handler';
+ 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 "
+ . "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) = @_;
+ local *__ANON__ = '__ANON__multiple_plan_handler';
+ $self->_add_error(
+ "More than one plan found in TAP output");
+ },
+ },
+ },
+ PLANNED_AFTER_TEST => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+
+ # test => { act => sub { }, continue => 'PLANNED' },
+ 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 => {
+ act => sub { },
+ 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 ( keys %$st ) {
+ if ( my $default = $state_defaults{$next} ) {
+ for my $def ( keys %$default ) {
+ $st->{$next}->{$def} ||= $default->{$def};
+ }
+ }
+ }
+
+ # Stuff back in table
+ $states{$name} = $st;
+ }
+
+ return \%states;
+}
+
+sub _iter {
+ my $self = shift;
+ my $stream = $self->_stream;
+ my $spool = $self->_spool;
+ my $grammar = $self->_grammar;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ my $count = 1;
+ TRANS: {
+
+ # warn sprintf("%3d %s\n", $count++, $state);
+
+ 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;
+ }
+ }
+ }
+ };
+
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $code->($result);
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print $spool $result->raw, "\n" if $spool;
+ }
+ else {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+
+ if ( my $code = $self->_callback_for('EOF') ) {
+ $code->($self);
+ }
+ }
+
+ return $result;
+ };
+ }
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $next_state->($result);
+
+ # Echo TAP to spool file
+ print $spool $result->raw, "\n" if $spool;
+ }
+ else {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ }
+
+ return $result;
+ };
+ }
+
+}
+
+sub _finish {
+ my $self = shift;
+
+ # 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;
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will be
+invoked. Thus, if all of the previous result types are specified as callbacks,
+this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is
+no accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO lists in
+the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was listed as a
+TODO test on the plan line. However, we are not aware of anyone actually
+using this feature and hard-coding test numbers is discouraged because it's
+very easy to add a test and break the test number sequence. This makes test
+suites very fragile. Instead, the following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter 'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've never
+run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral support, or
+just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid at cpan.org>
+
+Andy Armstong <andy at hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-tapx-parser at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I 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 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;
Modified: trunk/lib/TAP/Base.pm
===================================================================
--- trunk/lib/TAP/Base.pm 2007-08-18 20:28:15 UTC (rev 270)
+++ trunk/lib/TAP/Base.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -88,11 +88,6 @@
$self->{code_for}{$event} = $callback;
}
-sub _has_callbacks {
- my $self = shift;
- return keys %{ $self->{code_for} } != 0;
-}
-
sub _callback_for {
my ( $self, $event ) = @_;
return $self->{code_for}{$event};
Modified: trunk/lib/TAP/Parser.pm
===================================================================
--- trunk/lib/TAP/Parser.pm 2007-08-18 20:28:15 UTC (rev 270)
+++ trunk/lib/TAP/Parser.pm 2007-08-18 21:33:06 UTC (rev 271)
@@ -42,6 +42,7 @@
_stream
_spool
_grammar
+ _state
exec
exit
is_good_plan
@@ -231,10 +232,38 @@
=cut
sub next {
- my $self = shift;
- return ( $self->{_iter} ||= $self->_iter )->();
+ my $self = shift;
+ my $result = $self->_next;
+
+ if ( defined $result ) {
+ my $code;
+ if ( $code = $self->_callback_for( $result->type ) ) {
+ $code->($result);
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ $self->_write_to_spool($result);
+ }
+ else {
+ my $code;
+ if ( $code = $self->_callback_for('EOF') ) {
+ $code->($self);
+ }
+ }
+
+ return $result;
}
+sub _write_to_spool {
+ my ( $self, $result ) = @_;
+ my $spool = $self->_spool or return;
+ print $spool $result->raw, "\n";
+}
+
##############################################################################
=head3 C<run>
@@ -258,6 +287,7 @@
# of the following, anything beginning with an underscore is strictly
# internal and should not be exposed.
my %initialize = (
+ _state => 'INIT',
version => $DEFAULT_TAP_VERSION,
plan => '', # the test plan (e.g., 1..3)
tap => '', # the TAP
@@ -956,6 +986,25 @@
push @{ $self->{failed} } => $num if !$test->is_ok;
}
+sub _next {
+ my $self = shift;
+ my $stream = $self->_stream;
+
+ my $result = eval { $self->_grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ($result) {
+ $self->_next_state($result);
+ }
+ else {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ }
+
+ return $result;
+}
+
my %states;
BEGIN {
@@ -1124,92 +1173,29 @@
}
}
-sub _iter {
- my $self = shift;
- my $stream = $self->_stream;
- my $spool = $self->_spool;
- my $grammar = $self->_grammar;
- my $state = 'INIT';
+# Advance the state machine
+sub _next_state {
+ my $self = shift;
+ my $token = shift;
- # Make next_state closure
- my $next_state = sub {
- my $token = shift;
- my $type = $token->type;
+ my $state = $states{ $self->_state }
+ or die "Illegal state: ", $self->_state;
- TRANS: {
- my $state_spec = $states{$state}
- or die "Illegal state: ", $state;
+ my $type = $token->type;
- if ( my $next = $state_spec->{$type} ) {
- if ( my $act = $next->{act} ) {
- $self->$act($token);
- }
-
- if ( my $cont = $next->{continue} ) {
- $state = $cont;
- redo TRANS;
- }
- elsif ( my $goto = $next->{goto} ) {
- $state = $goto;
- }
- }
+ if ( my $next = $state->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $self->$act($token);
}
- };
- if ( $self->_has_callbacks ) {
- return sub {
- my $result = eval { $grammar->tokenize };
- $self->_add_error($@) if $@;
-
- if ( defined $result ) {
- $next_state->($result);
-
- if ( my $code = $self->_callback_for( $result->type ) ) {
- $code->($result);
- }
- else {
- $self->_make_callback( 'ELSE', $result );
- }
-
- $self->_make_callback( 'ALL', $result );
-
- # Echo TAP to spool file
- print $spool $result->raw, "\n" if $spool;
- }
- else {
- $self->exit( $stream->exit );
- $self->wait( $stream->wait );
- $self->_finish;
-
- if ( my $code = $self->_callback_for('EOF') ) {
- $code->($self);
- }
- }
-
- return $result;
- };
+ if ( my $cont = $next->{continue} ) {
+ $self->_state($cont);
+ $self->_next_state($token);
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $self->_state($goto);
+ }
}
- else {
- return sub {
- my $result = eval { $grammar->tokenize };
- $self->_add_error($@) if $@;
-
- if ( defined $result ) {
- $next_state->($result);
-
- # Echo TAP to spool file
- print $spool $result->raw, "\n" if $spool;
- }
- else {
- $self->exit( $stream->exit );
- $self->wait( $stream->wait );
- $self->_finish;
- }
-
- return $result;
- };
- }
-
}
sub _finish {
More information about the tapx-dev
mailing list