lib/TAP/Parser/Result/Bailout.pm A parser for Test Anything Protocol
lib/TAP/Parser/Result/Comment.pm A parser for Test Anything Protocol
lib/TAP/Parser/Result/Plan.pm A parser for Test Anything Protocol
+lib/TAP/Parser/Result/Pragma.pm A parser for Test Anything Protocol
lib/TAP/Parser/Result/Test.pm A parser for Test Anything Protocol
lib/TAP/Parser/Result/Unknown.pm A parser for Test Anything Protocol
lib/TAP/Parser/Result/Version.pm A parser for Test Anything Protocol
t/lib/sample-tests/skipall_v13 Test data for Test::Harness
t/lib/sample-tests/space_after_plan Test data for Test::Harness
t/lib/sample-tests/stdout_stderr Test data for Test::Harness
+t/lib/sample-tests/strict Test data for Test::Harness
t/lib/sample-tests/switches Test data for Test::Harness
t/lib/sample-tests/taint Test data for Test::Harness
t/lib/sample-tests/taint_warn Test data for Test::Harness
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
my $GOT_TIME_HIRES;
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
use TAP::Parser::Source ();
use TAP::Parser::Source::Perl ();
use TAP::Parser::Iterator ();
-use Carp ();
+
+use Carp qw( confess );
@ISA = qw(TAP::Base);
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
my $DEFAULT_TAP_VERSION = 12;
my $MAX_TAP_VERSION = 13;
1..42
+=item * Pragma
+
+ pragma +strict
+
=item * Test
ok 3 - We should start with some foobar!
If a SKIP directive was included with the plan, this method will return the
explanation, if any.
+=head2 C<pragma> methods
+
+ if ( $result->is_pragma ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<pragmas>
+
+Returns a list of pragmas each of which is a + or - followed by the
+pragma name.
+
=head2 C<commment> methods
if ( $result->is_comment ) { ... }
sub skipped { @{ shift->{skipped} } }
+=head2 Pragmas
+
+=head3 C<pragma>
+
+Get or set a pragma. To get the state of a pragma:
+
+ if ( $p->pragma('strict') ) {
+ # be strict
+ }
+
+To set the state of a pragma:
+
+ $p->pragma('strict', 1); # enable strict mode
+
+=cut
+
+sub pragma {
+ my ( $self, $pragma ) = splice @_, 0, 2;
+
+ return $self->{pragma}->{$pragma} unless @_;
+
+ if ( my $state = shift ) {
+ $self->{pragma}->{$pragma} = 1;
+ }
+ else {
+ delete $self->{pragma}->{$pragma};
+ }
+
+ return;
+}
+
+=head3 C<pragmas>
+
+Get a list of all the currently enabled pragmas:
+
+ my @pragmas_enabled = $p->pragmas;
+
+=cut
+
+sub pragmas { sort keys %{ shift->{pragma} || {} } }
+
=head2 Summary Results
These results are "meta" information about the total results of an individual
my %state_globals = (
comment => {},
bailout => {},
+ yaml => {},
version => {
act => sub {
- my ($version) = @_;
$self->_add_error(
'If TAP version is present it must be the first line of output'
);
},
},
+ unknown => {
+ act => sub {
+ my $unk = shift;
+ if ( $self->pragma('strict') ) {
+ $self->_add_error(
+ 'Unknown TAP token: "' . $unk->raw . '"' );
+ }
+ },
+ },
+ pragma => {
+ act => sub {
+ my ($pragma) = @_;
+ for my $pr ( $pragma->pragmas ) {
+ if ( $pr =~ /^ ([-+])(\w+) $/x ) {
+ $self->pragma( $2, $1 eq '+' );
+ }
+ }
+ },
+ },
);
# Provides default elements for transitions
} => $number;
},
},
- yaml => {
- act => sub { },
- },
+ yaml => { act => sub { }, },
);
# Each state contains a hash the keys of which match a token type. For
);
# Apply globals and defaults to state table
- for my $name ( sort keys %states ) {
+ for my $name ( keys %states ) {
# Merge with globals
my $st = { %state_globals, %{ $states{$name} } };
my $next_state = sub {
my $token = shift;
my $type = $token->type;
- my $count = 1;
TRANS: {
my $state_spec = $state_table->{$state}
or die "Illegal state: $state";
$state = $goto;
}
}
+ else {
+ confess("Unhandled token type: $type\n");
+ }
}
return $token;
};
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
return $self->_make_yaml_token( $pad, $marker );
},
},
+ pragma => {
+ syntax =>
+ qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $pragmas = $1;
+ return $self->_make_pragma_token( $line, $pragmas );
+ },
+ },
);
%language_for = (
ok => $ok,
test_num => $num,
description => _trim($desc),
- directive => uc($dir || ""),
+ directive => uc( defined $dir ? $dir : '' ),
explanation => _trim($explanation),
raw => $line,
type => 'test',
};
}
+sub _make_pragma_token {
+ my ( $self, $line, $pragmas ) = @_;
+ return {
+ type => 'pragma',
+ raw => $line,
+ pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
+ };
+}
+
sub _trim {
my $data = shift;
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 SYNOPSIS
use TAP::Parser::Result::Bailout ();
use TAP::Parser::Result::Comment ();
use TAP::Parser::Result::Plan ();
+use TAP::Parser::Result::Pragma ();
use TAP::Parser::Result::Test ();
use TAP::Parser::Result::Unknown ();
use TAP::Parser::Result::Version ();
use TAP::Parser::Result::YAML ();
+# 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;
+
BEGIN {
+ %class_for = (
+ plan => 'TAP::Parser::Result::Plan',
+ pragma => 'TAP::Parser::Result::Pragma',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+ );
+
no strict 'refs';
- foreach my $token (qw( plan comment test bailout version unknown yaml )) {
+ for my $token ( keys %class_for ) {
my $method = "is_$token";
*$method = sub { return $token eq shift->type };
}
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head2 DESCRIPTION
=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
1..3
+=item * C<is_pragma>
+
+Indicates whether or not this is a pragma line.
+
+ pragma +strict
+
=item * C<is_test>
Indicates whether or not this is a test line.
- is $foo, $bar, $description;
+ ok 1 Is OK!
=item * C<is_comment>
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
--- /dev/null
+package TAP::Parser::Result::Pragma;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Pragma - TAP pragma token.
+
+=head1 VERSION
+
+Version 3.10
+
+=cut
+
+$VERSION = '3.10';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a pragma is encountered.
+
+ TAP version 13
+ pragma +strict, -foo
+
+Pragmas are only supported from TAP version 13 onwards.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<pragmas>
+
+if ( $result->is_pragma ) {
+ @pragmas = $result->pragmas;
+}
+
+=cut
+
+sub pragmas {
+ my @pragmas = @{ shift->{pragmas} };
+ return wantarray ? @pragmas : \@pragmas;
+}
+
+1;
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 NAME
-TAP::Parser::Result::Version - TAP version result token.
+TAP::Parser::Result::Version - TAP syntax version token.
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=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
+ TAP version 13
ok 1
not ok 2
-The first version of TAP to include an explicit version number is 4.
+The first version of TAP to include an explicit version number is 13.
=head1 OVERRIDDEN METHODS
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
=head1 SYNOPSIS
use vars qw{$VERSION};
-$VERSION = '3.09';
+$VERSION = '3.10';
# TODO:
# Handle blessed object syntax
=head1 VERSION
-Version 3.09
+Version 3.10
=head1 SYNOPSIS
use vars qw{$VERSION};
-$VERSION = '3.09';
+$VERSION = '3.10';
my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
=head1 VERSION
-Version 3.09
+Version 3.10
=head1 SYNOPSIS
=head1 VERSION
-Version 3.09
+Version 3.10
=cut
-$VERSION = '3.09';
+$VERSION = '3.10';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
use strict;
use lib 't/lib';
-use Test::More tests => 60;
+use Test::More tests => 62;
BEGIN {
TAP::Parser::Result::Bailout
TAP::Parser::Result::Comment
TAP::Parser::Result::Plan
+ TAP::Parser::Result::Pragma
TAP::Parser::Result::Test
TAP::Parser::Result::Unknown
TAP::Parser::Result::Version
use strict;
use lib 't/lib';
-use Test::More tests => 81;
+use Test::More tests => 94;
use TAP::Parser::Grammar;
use TAP::Parser::Iterator::Array;
# why. We'll still use the instance because that should be forward
# compatible.
-my @V12 = qw(bailout comment plan simple_test test version);
-my @V13 = ( @V12, 'yaml' );
+my @V12 = sort qw(bailout comment plan simple_test test version);
+my @V13 = sort ( @V12, 'pragma', 'yaml' );
can_ok $grammar, 'token_types';
ok my @types = sort( $grammar->token_types ),
is_deeply $token, $expected,
'... and the token should contain the correct data';
+# pragmas
+
+my $pragma = 'pragma +strict';
+like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax';
+
+$stream->put($pragma);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'type' => 'pragma',
+ 'raw' => $pragma,
+ 'pragmas' => ['+strict'],
+};
+
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+$pragma = 'pragma +strict,-foo';
+like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax';
+
+$stream->put($pragma);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'type' => 'pragma',
+ 'raw' => $pragma,
+ 'pragmas' => [ '+strict', '-foo' ],
+};
+
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+$pragma = 'pragma +strict , -foo ';
+like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax';
+
+$stream->put($pragma);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'type' => 'pragma',
+ 'raw' => $pragma,
+ 'pragmas' => [ '+strict', '-foo' ],
+};
+
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
# coverage tests
# set_version
$grammar->set_version('no_such_version');
};
- unless (is @die, 1, 'set_version with bad version') {
+ unless ( is @die, 1, 'set_version with bad version' ) {
diag " >>> $_ <<<\n" for @die;
}
use strict;
BEGIN {
- if( $ENV{PERL_CORE} ) {
+ if ( $ENV{PERL_CORE} ) {
chdir 't';
- @INC = ('../lib', 'lib');
+ @INC = ( '../lib', 'lib' );
}
else {
- use lib 't/lib';
+ use lib 't/lib';
}
}
-use Test::More tests => 260;
+use Test::More tests => 268;
use IO::c55Capture;
use File::Spec;
return @results;
}
-my ( $PARSER, $PLAN, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw(
+my ( $PARSER, $PLAN, $PRAGMA, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw(
TAP::Parser
TAP::Parser::Result::Plan
+ TAP::Parser::Result::Pragma
TAP::Parser::Result::Test
TAP::Parser::Result::Comment
TAP::Parser::Result::Bailout
# coverage test of perl source with switches
my $parser = TAP::Parser->new(
- { source => File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
- 'sample-tests', 'simple' ),
+ { source => File::Spec->catfile(
+ ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+ 'sample-tests', 'simple'
+ ),
}
);
qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/,
'...and the message is as we expect';
}
+
+{
+
+ # Sanity check on state table
+
+ my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
+ my $state_table = $parser->_make_state_table;
+ my @states = sort keys %$state_table;
+ my @expect = sort qw(
+ bailout comment plan pragma test unknown version yaml
+ );
+
+ my %reachable = ( INIT => 1 );
+
+ for my $name (@states) {
+ my $state = $state_table->{$name};
+ my @can_handle = sort keys %$state;
+ is_deeply \@can_handle, \@expect, "token types handled in $name";
+ for my $type (@can_handle) {
+ $reachable{$_}++
+ for grep {defined}
+ map { $state->{$type}->{$_} } qw(goto continue);
+ }
+ }
+
+ is_deeply [ sort keys %reachable ], [@states], "all states reachable";
+}
wait => 0,
version => 13,
},
+ strict => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_plan => TRUE,
+ raw => '1..1',
+ },
+ { is_pragma => TRUE,
+ raw => 'pragma +strict',
+ pragmas => ['+strict'],
+ },
+ { is_unknown => TRUE, raw => 'Nonsense!',
+ },
+ { is_pragma => TRUE,
+ raw => 'pragma -strict',
+ pragmas => ['-strict'],
+ },
+ { is_unknown => TRUE,
+ raw => "Doesn't matter.",
+ },
+ { is_test => TRUE,
+ raw => 'ok 1 All OK',
+ }
+ ],
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => 1,
+ parse_errors => ['Unknown TAP token: "Nonsense!"'],
+ 'exit' => 0, # TODO: Is this right???
+ wait => 0,
+ version => 13,
+ },
skipall_nomsg => {
results => [
{ is_plan => TRUE,
tests_planned => 5,
tests_run => 5,
parse_errors =>
- [ 'Explicit TAP version must be at least 13. Got version 12' ],
+ ['Explicit TAP version must be at least 13. Got version 12'],
'exit' => 0,
wait => 0,
version => 12,
tests_planned => 5,
tests_run => 5,
parse_errors =>
- [ 'If TAP version is present it must be the first line of output' ],
+ ['If TAP version is present it must be the first line of output'],
'exit' => 0,
wait => 0,
version => 12,
"... and $method should return a reasonable value ($test/$count)";
}
elsif ( ref $answer ) {
- is_deeply $result->$method(), $answer,
+ is_deeply scalar( $result->$method() ), $answer,
"... and $method should return the correct structure ($test/$count)";
}
else {
--- /dev/null
+print <<DUMMY_TEST;
+TAP version 13
+1..1
+pragma +strict
+Nonsense!
+pragma -strict
+Doesn't matter.
+ok 1 All OK
+DUMMY_TEST
projects / p5sagit/p5-mst-13.2.git / commitdiff