| Current File : /home/mmdealscpanel/yummmdeals.com/TAP.zip |
PK �[-26�� � Base.pmnu �[��� package TAP::Base;
use strict;
use warnings;
use base 'TAP::Object';
=head1 NAME
TAP::Base - Base class that provides common functionality to L<TAP::Parser>
and L<TAP::Harness>
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
use constant GOT_TIME_HIRES => do {
eval 'use Time::HiRes qw(time);';
$@ ? 0 : 1;
};
=head1 SYNOPSIS
package TAP::Whatever;
use base 'TAP::Base';
# ... later ...
my $thing = TAP::Whatever->new();
$thing->callback( event => sub {
# do something interesting
} );
=head1 DESCRIPTION
C<TAP::Base> provides callback management.
=head1 METHODS
=head2 Class Methods
=cut
sub _initialize {
my ( $self, $arg_for, $ok_callback ) = @_;
my %ok_map = map { $_ => 1 } @$ok_callback;
$self->{ok_callbacks} = \%ok_map;
if ( my $cb = delete $arg_for->{callbacks} ) {
while ( my ( $event, $callback ) = each %$cb ) {
$self->callback( $event, $callback );
}
}
return $self;
}
=head3 C<callback>
Install a callback for a named event.
=cut
sub callback {
my ( $self, $event, $callback ) = @_;
my %ok_map = %{ $self->{ok_callbacks} };
$self->_croak('No callbacks may be installed')
unless %ok_map;
$self->_croak( "Callback $event is not supported. Valid callbacks are "
. join( ', ', sort keys %ok_map ) )
unless exists $ok_map{$event};
push @{ $self->{code_for}{$event} }, $callback;
return;
}
sub _has_callbacks {
my $self = shift;
return keys %{ $self->{code_for} } != 0;
}
sub _callback_for {
my ( $self, $event ) = @_;
return $self->{code_for}{$event};
}
sub _make_callback {
my $self = shift;
my $event = shift;
my $cb = $self->_callback_for($event);
return unless defined $cb;
return map { $_->(@_) } @$cb;
}
=head3 C<get_time>
Return the current time using Time::HiRes if available.
=cut
sub get_time { return time() }
=head3 C<time_is_hires>
Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
=cut
sub time_is_hires { return GOT_TIME_HIRES }
=head3 C<get_times>
Return array reference of the four-element list of CPU seconds,
as with L<perlfunc/times>.
=cut
sub get_times { return [ times() ] }
1;
PK �[^Ȳ۱� �� Parser.pmnu �[��� package TAP::Parser;
use strict;
use warnings;
use TAP::Parser::Grammar ();
use TAP::Parser::Result ();
use TAP::Parser::ResultFactory ();
use TAP::Parser::Source ();
use TAP::Parser::Iterator ();
use TAP::Parser::IteratorFactory ();
use TAP::Parser::SourceHandler::Executable ();
use TAP::Parser::SourceHandler::Perl ();
use TAP::Parser::SourceHandler::File ();
use TAP::Parser::SourceHandler::RawTAP ();
use TAP::Parser::SourceHandler::Handle ();
use Carp qw( confess );
use base 'TAP::Base';
=encoding utf8
=head1 NAME
TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
my $DEFAULT_TAP_VERSION = 12;
my $MAX_TAP_VERSION = 13;
$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
END {
# For VMS.
delete $ENV{TAP_VERSION};
}
BEGIN { # making accessors
__PACKAGE__->mk_methods(
qw(
_iterator
_spool
exec
exit
is_good_plan
plan
tests_planned
tests_run
wait
version
in_todo
start_time
end_time
start_times
end_times
skip_all
grammar_class
result_factory_class
iterator_factory_class
)
);
sub _stream { # deprecated
my $self = shift;
$self->_iterator(@_);
}
} # done making accessors
=head1 SYNOPSIS
use TAP::Parser;
my $parser = TAP::Parser->new( { source => $source } );
while ( my $result = $parser->next ) {
print $result->as_string;
}
=head1 DESCRIPTION
C<TAP::Parser> is designed to produce a proper parse of TAP output. For
an example of how to run tests through this module, see the simple
harnesses C<examples/>.
There's a wiki dedicated to the Test Anything Protocol:
L<http://testanything.org>
It includes the TAP::Parser Cookbook:
L<http://testanything.org/testing-with-tap/perl/tap::parser-cookbook.html>
=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>
I<CHANGED in 3.18>
This is the preferred method of passing input to the constructor.
The C<source> is used to create a L<TAP::Parser::Source> that is passed to the
L</iterator_factory_class> which in turn figures out how to handle the source and
creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to
read in the TAP stream.
To configure the I<IteratorFactory> use the C<sources> parameter below.
Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
=item * C<tap>
I<CHANGED in 3.18>
The value should be the complete TAP output.
The I<tap> is used to create a L<TAP::Parser::Source> that is passed to the
L</iterator_factory_class> which in turn figures out how to handle the source and
creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to
read in the TAP stream.
To configure the I<IteratorFactory> use the C<sources> parameter below.
Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
=item * C<exec>
Must be passed an array reference.
The I<exec> array ref is used to create a L<TAP::Parser::Source> that is passed
to the L</iterator_factory_class> which in turn figures out how to handle the
source and creates a <TAP::Parser::Iterator> for it. The iterator is used by
the parser to read in the TAP stream.
By default the L<TAP::Parser::SourceHandler::Executable> class will create a
L<TAP::Parser::Iterator::Process> object to handle the source. This passes the
array reference strings as command arguments to L<IPC::Open3::open3|IPC::Open3>:
exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
If any C<test_args> are given they will be appended to the end of the command
argument list.
To configure the I<IteratorFactory> use the C<sources> parameter below.
Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
=back
The following keys are optional.
=over 4
=item * C<sources>
I<NEW to 3.18>.
If set, C<sources> must be a hashref containing the names of the
L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a
hash of configuration that will be accessible to the source handlers via
L<TAP::Parser::Source/config_for>.
For example:
sources => {
Perl => { exec => '/path/to/custom/perl' },
File => { extensions => [ '.tap', '.txt' ] },
MyCustom => { some => 'config' },
}
This will cause C<TAP::Parser> to pass custom configuration to two of the built-
in source handlers - L<TAP::Parser::SourceHandler::Perl>,
L<TAP::Parser::SourceHandler::File> - and attempt to load the C<MyCustom>
class. See L<TAP::Parser::IteratorFactory/load_handlers> for more detail.
The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters
are handled.
See L<TAP::Parser::IteratorFactory>, L<TAP::Parser::SourceHandler> and subclasses for
more details.
=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;
for my $file ( @test_files ) {
my $parser = TAP::Parser->new(
{
source => $file,
callbacks => \%callbacks,
}
);
$parser->run;
$aggregator->add( $file, $parser );
}
=item * C<switches>
If using a Perl file as a source, optional switches may be passed which will
be used when invoking the perl executable.
my $parser = TAP::Parser->new( {
source => $test_file,
switches => [ '-Ilib' ],
} );
=item * C<test_args>
Used in conjunction with the C<source> and C<exec> option to supply a reference
to an C<@ARGV> style array of arguments to pass to the test program.
=item * C<spool>
If passed a filehandle will write a copy of all parsed TAP to that handle.
=item * C<merge>
If false, STDERR is not captured (though it is 'relayed' to keep it
somewhat synchronized with STDOUT.)
If true, STDERR and STDOUT are the same filehandle. This may cause
breakage if STDERR contains anything resembling TAP format, but does
allow exact synchronization.
Subtleties of this behavior may be platform-dependent and may change in
the future.
=item * C<grammar_class>
This option was introduced to let you easily customize which I<grammar> class
the parser should use. It defaults to L<TAP::Parser::Grammar>.
See also L</make_grammar>.
=item * C<result_factory_class>
This option was introduced to let you easily customize which I<result>
factory class the parser should use. It defaults to
L<TAP::Parser::ResultFactory>.
See also L</make_result>.
=item * C<iterator_factory_class>
I<CHANGED in 3.18>
This option was introduced to let you easily customize which I<iterator>
factory class the parser should use. It defaults to
L<TAP::Parser::IteratorFactory>.
=back
=cut
# new() implementation supplied by TAP::Base
# This should make overriding behaviour of the Parser in subclasses easier:
sub _default_grammar_class {'TAP::Parser::Grammar'}
sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
##############################################################################
=head2 Instance Methods
=head3 C<next>
my $parser = TAP::Parser->new( { source => $file } );
while ( my $result = $parser->next ) {
print $result->as_string, "\n";
}
This method returns the results of the parsing, one result at a time. Note
that it is destructive. You can't rewind and examine previous results.
If callbacks are used, they will be issued before this call returns.
Each result returned is a subclass of L<TAP::Parser::Result>. See that
module and related classes for more information on how to use them.
=cut
sub next {
my $self = shift;
return ( $self->{_iter} ||= $self->_iter )->();
}
##############################################################################
=head3 C<run>
$parser->run;
This method merely runs the parser and parses all of the TAP.
=cut
sub run {
my $self = shift;
while ( defined( my $result = $self->next ) ) {
# do nothing
}
}
##############################################################################
=head3 C<make_grammar>
Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
arguments given.
The C<grammar_class> can be customized, as described in L</new>.
=head3 C<make_result>
Make a new L<TAP::Parser::Result> object using the parser's
L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments
given.
The C<result_factory_class> can be customized, as described in L</new>.
=head3 C<make_iterator_factory>
I<NEW to 3.18>.
Make a new L<TAP::Parser::IteratorFactory> object and return it. Passes through
any arguments given.
C<iterator_factory_class> can be customized, as described in L</new>.
=cut
# This should make overriding behaviour of the Parser in subclasses easier:
sub make_iterator_factory { shift->iterator_factory_class->new(@_); }
sub make_grammar { shift->grammar_class->new(@_); }
sub make_result { shift->result_factory_class->make_result(@_); }
{
# of the following, anything beginning with an underscore is strictly
# internal and should not be exposed.
my %initialize = (
version => $DEFAULT_TAP_VERSION,
plan => '', # the test plan (e.g., 1..3)
tests_run => 0, # actual current test numbers
skipped => [], #
todo => [], #
passed => [], #
failed => [], #
actual_failed => [], # how many tests really failed
actual_passed => [], # how many tests really passed
todo_passed => [], # tests which unexpectedly succeed
parse_errors => [], # perfect TAP should have none
);
# We seem to have this list hanging around all over the place. We could
# probably get it from somewhere else to avoid the repetition.
my @legal_callback = qw(
test
version
plan
comment
bailout
unknown
yaml
ALL
ELSE
EOF
);
my @class_overrides = qw(
grammar_class
result_factory_class
iterator_factory_class
);
sub _initialize {
my ( $self, $arg_for ) = @_;
# everything here is basically designed to convert any TAP source to a
# TAP::Parser::Iterator.
# Shallow copy
my %args = %{ $arg_for || {} };
$self->SUPER::_initialize( \%args, \@legal_callback );
# get any class overrides out first:
for my $key (@class_overrides) {
my $default_method = "_default_$key";
my $val = delete $args{$key} || $self->$default_method();
$self->$key($val);
}
my $iterator = delete $args{iterator};
$iterator ||= delete $args{stream}; # deprecated
my $tap = delete $args{tap};
my $version = delete $args{version};
my $raw_source = delete $args{source};
my $sources = delete $args{sources};
my $exec = delete $args{exec};
my $merge = delete $args{merge};
my $spool = delete $args{spool};
my $switches = delete $args{switches};
my $ignore_exit = delete $args{ignore_exit};
my $test_args = delete $args{test_args} || [];
if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) {
$self->_croak(
"You may only choose one of 'exec', 'tap', 'source' or 'iterator'"
);
}
if ( my @excess = sort keys %args ) {
$self->_croak("Unknown options: @excess");
}
# convert $tap & $exec to $raw_source equiv.
my $type = '';
my $source = TAP::Parser::Source->new;
if ($tap) {
$type = 'raw TAP';
$source->raw( \$tap );
}
elsif ($exec) {
$type = 'exec ' . $exec->[0];
$source->raw( { exec => $exec } );
}
elsif ($raw_source) {
$type = 'source ' . ref($raw_source) || $raw_source;
$source->raw( ref($raw_source) ? $raw_source : \$raw_source );
}
elsif ($iterator) {
$type = 'iterator ' . ref($iterator);
}
if ( $source->raw ) {
my $src_factory = $self->make_iterator_factory($sources);
$source->merge($merge)->switches($switches)
->test_args($test_args);
$iterator = $src_factory->make_iterator($source);
}
unless ($iterator) {
$self->_croak(
"PANIC: could not determine iterator for input $type");
}
while ( my ( $k, $v ) = each %initialize ) {
$self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
}
$self->version($version) if $version;
$self->_iterator($iterator);
$self->_spool($spool);
$self->ignore_exit($ignore_exit);
return $self;
}
}
=head1 INDIVIDUAL RESULTS
If you've read this far in the docs, you've seen this:
while ( my $result = $parser->next ) {
print $result->as_string;
}
Each result returned is a L<TAP::Parser::Result> subclass, referred to as
I<result types>.
=head2 Result types
Basically, you fetch individual results from the TAP. The six types, with
examples of each, are as follows:
=over 4
=item * Version
TAP version 12
=item * Plan
1..42
=item * Pragma
pragma +strict
=item * Test
ok 3 - We should start with some foobar!
=item * Comment
# Hope we don't use up the foobar.
=item * Bailout
Bail out! We ran out of foobar!
=item * Unknown
... yo, this ain't TAP! ...
=back
Each result fetched is a result object of a different type. There are common
methods to each result object and different types may have methods unique to
their type. Sometimes a type method may be overridden in a subclass, but its
use is guaranteed to be identical.
=head2 Common type methods
=head3 C<type>
Returns the type of result, such as C<comment> or C<test>.
=head3 C<as_string>
Prints a string representation of the token. This might not be the exact
output, however. Tests will have test numbers added if not present, TODO and
SKIP directives will be capitalized and, in general, things will be cleaned
up. If you need the original text for the token, see the C<raw> method.
=head3 C<raw>
Returns the original line of text which was parsed.
=head3 C<is_plan>
Indicates whether or not this is the test plan line.
=head3 C<is_test>
Indicates whether or not this is a test line.
=head3 C<is_comment>
Indicates whether or not this is a comment. Comments will generally only
appear in the TAP stream if STDERR is merged to STDOUT. See the
C<merge> option.
=head3 C<is_bailout>
Indicates whether or not this is bailout line.
=head3 C<is_yaml>
Indicates whether or not the current item is a YAML block.
=head3 C<is_unknown>
Indicates whether or not the current line could be parsed.
=head3 C<is_ok>
if ( $result->is_ok ) { ... }
Reports whether or not a given result has passed. Anything which is B<not> a
test result returns true. This is merely provided as a convenient shortcut
which allows you to do this:
my $parser = TAP::Parser->new( { source => $source } );
while ( my $result = $parser->next ) {
# only print failing results
print $result->as_string unless $result->is_ok;
}
=head2 C<plan> methods
if ( $result->is_plan ) { ... }
If the above evaluates as true, the following methods will be available on the
C<$result> object.
=head3 C<plan>
if ( $result->is_plan ) {
print $result->plan;
}
This is merely a synonym for C<as_string>.
=head3 C<directive>
my $directive = $result->directive;
If a SKIP directive is included with the plan, this method will return it.
1..0 # SKIP: why bother?
=head3 C<explanation>
my $explanation = $result->explanation;
If a SKIP directive was included with the plan, this method will return the
explanation, if any.
=head2 C<pragma> methods
if ( $result->is_pragma ) { ... }
If the above evaluates as true, the following methods will be available on the
C<$result> object.
=head3 C<pragmas>
Returns a list of pragmas each of which is a + or - followed by the
pragma name.
=head2 C<comment> 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 explanation, 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 {
return @{ $_[0]->{passed} }
if ref $_[0]->{passed};
return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{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 {
return @{ $_[0]->{actual_passed} }
if ref $_[0]->{actual_passed};
return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed};
}
*actual_ok = \&actual_passed;
=head3 C<actual_ok>
This method is a synonym for C<actual_passed>.
=head3 C<actual_failed>
# the test numbers which actually failed
my @actual_failed = $parser->actual_failed;
# the number of tests which actually failed
my $actual_failed = $parser->actual_failed;
This method lets you know which (or how many) tests actually failed,
regardless of whether or not a TODO directive was found.
=cut
sub actual_failed { @{ shift->{actual_failed} } }
##############################################################################
=head3 C<todo>
my @todo = $parser->todo; # the test numbers with todo directives
my $todo = $parser->todo; # the number of tests with todo directives
This method lets you know which (or how many) tests had TODO directives.
=cut
sub todo { @{ shift->{todo} } }
=head3 C<todo_passed>
# the test numbers which unexpectedly succeeded
my @todo_passed = $parser->todo_passed;
# the number of tests which unexpectedly succeeded
my $todo_passed = $parser->todo_passed;
This method lets you know which (or how many) tests actually passed but were
declared as "TODO" tests.
=cut
sub todo_passed { @{ shift->{todo_passed} } }
##############################################################################
=head3 C<todo_failed>
# deprecated in favor of 'todo_passed'. This method was horribly misnamed.
This was a badly misnamed method. It indicates which TODO tests unexpectedly
succeeded. Will now issue a warning and call C<todo_passed>.
=cut
sub todo_failed {
warn
'"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
goto &todo_passed;
}
=head3 C<skipped>
my @skipped = $parser->skipped; # the test numbers with SKIP directives
my $skipped = $parser->skipped; # the number of tests with SKIP directives
This method lets you know which (or how many) tests had SKIP directives.
=cut
sub skipped { @{ shift->{skipped} } }
=head2 Pragmas
=head3 C<pragma>
Get or set a pragma. To get the state of a pragma:
if ( $p->pragma('strict') ) {
# be strict
}
To set the state of a pragma:
$p->pragma('strict', 1); # enable strict mode
=cut
sub pragma {
my ( $self, $pragma ) = splice @_, 0, 2;
return $self->{pragma}->{$pragma} unless @_;
if ( my $state = shift ) {
$self->{pragma}->{$pragma} = 1;
}
else {
delete $self->{pragma}->{$pragma};
}
return;
}
=head3 C<pragmas>
Get a list of all the currently enabled pragmas:
my @pragmas_enabled = $p->pragmas;
=cut
sub pragmas { sort keys %{ shift->{pragma} || {} } }
=head2 Summary Results
These results are "meta" information about the total results of an individual
test program.
=head3 C<plan>
my $plan = $parser->plan;
Returns the test plan, if found.
=head3 C<good_plan>
Deprecated. Use C<is_good_plan> instead.
=cut
sub good_plan {
warn 'good_plan() is deprecated. Please use "is_good_plan()"';
goto &is_good_plan;
}
##############################################################################
=head3 C<is_good_plan>
if ( $parser->is_good_plan ) { ... }
Returns a boolean value indicating whether or not the number of tests planned
matches the number of tests run.
B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
will issue a warning.
And since we're on that subject ...
=head3 C<tests_planned>
print $parser->tests_planned;
Returns the number of tests planned, according to the plan. For example, a
plan of '1..17' will mean that 17 tests were planned.
=head3 C<tests_run>
print $parser->tests_run;
Returns the number of tests which actually were run. Hopefully this will
match the number of C<< $parser->tests_planned >>.
=head3 C<skip_all>
Returns a true value (actually the reason for skipping) if all tests
were skipped.
=head3 C<start_time>
Returns the wall-clock time when the Parser was created.
=head3 C<end_time>
Returns the wall-clock time when the end of TAP input was seen.
=head3 C<start_times>
Returns the CPU times (like L<perlfunc/times> when the Parser was created.
=head3 C<end_times>
Returns the CPU times (like L<perlfunc/times> when the end of TAP
input was seen.
=head3 C<has_problems>
if ( $parser->has_problems ) {
...
}
This is a 'catch-all' method which returns true if any tests have currently
failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
=cut
sub has_problems {
my $self = shift;
return
$self->failed
|| $self->parse_errors
|| ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
}
=head3 C<version>
$parser->version;
Once the parser is done, this will return the version number for the
parsed TAP. Version numbers were introduced with TAP version 13 so if no
version number is found version 12 is assumed.
=head3 C<exit>
$parser->exit;
Once the parser is done, this will return the exit status. If the parser ran
an executable, it returns the exit status of the executable.
=head3 C<wait>
$parser->wait;
Once the parser is done, this will return the wait status. If the parser ran
an executable, it returns the wait status of the executable. Otherwise, this
merely returns the C<exit> status.
=head2 C<ignore_exit>
$parser->ignore_exit(1);
Tell the parser to ignore the exit status from the test when determining
whether the test passed. Normally tests with non-zero exit status are
considered to have failed even if all individual tests passed. In cases
where it is not possible to control the exit value of the test script
use this option to ignore it.
=cut
sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
=head3 C<parse_errors>
my @errors = $parser->parse_errors; # the parser errors
my $errors = $parser->parse_errors; # the number of parser_errors
Fortunately, all TAP output is perfect. In the event that it is not, this
method will return parser errors. Note that a junk line which the parser does
not recognize is C<not> an error. This allows this parser to handle future
versions of TAP. The following are all TAP errors reported by the parser:
=over 4
=item * Misplaced plan
The plan (for example, '1..5'), must only come at the beginning or end of the
TAP output.
=item * No plan
Gotta have a plan!
=item * More than one plan
1..3
ok 1 - input file opened
not ok 2 - first line of the input valid # todo some data
ok 3 read the rest of the file
1..3
Right. Very funny. Don't do that.
=item * Test numbers out of sequence
1..3
ok 1 - input file opened
not ok 2 - first line of the input valid # todo some data
ok 2 read the rest of the file
That last test line above should have the number '3' instead of '2'.
Note that it's perfectly acceptable for some lines to have test numbers and
others to not have them. However, when a test number is found, it must be in
sequence. The following is also an error:
1..3
ok 1 - input file opened
not ok - first line of the input valid # todo some data
ok 2 read the rest of the file
But this is not:
1..3
ok - input file opened
not ok - first line of the input valid # todo some data
ok 3 read the rest of the file
=back
=cut
sub parse_errors { @{ shift->{parse_errors} } }
sub _add_error {
my ( $self, $error ) = @_;
push @{ $self->{parse_errors} } => $error;
return $self;
}
sub _make_state_table {
my $self = shift;
my %states;
my %planned_todo = ();
# These transitions are defaults for all states
my %state_globals = (
comment => {},
bailout => {},
yaml => {},
version => {
act => sub {
$self->_add_error(
'If TAP version is present it must be the first line of output'
);
},
},
unknown => {
act => sub {
my $unk = shift;
if ( $self->pragma('strict') ) {
$self->_add_error(
'Unknown TAP token: "' . $unk->raw . '"' );
}
},
},
pragma => {
act => sub {
my ($pragma) = @_;
for my $pr ( $pragma->pragmas ) {
if ( $pr =~ /^ ([-+])(\w+) $/x ) {
$self->pragma( $2, $1 eq '+' );
}
}
},
},
);
# Provides default elements for transitions
my %state_defaults = (
plan => {
act => sub {
my ($plan) = @_;
$self->tests_planned( $plan->tests_planned );
$self->plan( $plan->plan );
if ( $plan->has_skip ) {
$self->skip_all( $plan->explanation
|| '(no reason given)' );
}
$planned_todo{$_}++ for @{ $plan->todo_list };
},
},
test => {
act => sub {
my ($test) = @_;
my ( $number, $tests_run )
= ( $test->number, ++$self->{tests_run} );
# Fake TODO state
if ( defined $number && delete $planned_todo{$number} ) {
$test->set_directive('TODO');
}
my $has_todo = $test->has_todo;
$self->in_todo($has_todo);
if ( defined( my $tests_planned = $self->tests_planned ) ) {
if ( $tests_run > $tests_planned ) {
$test->is_unplanned(1);
}
}
if ( defined $number ) {
if ( $number != $tests_run ) {
my $count = $tests_run;
$self->_add_error( "Tests out of sequence. Found "
. "($number) but expected ($count)" );
}
}
else {
$test->_number( $number = $tests_run );
}
push @{ $self->{todo} } => $number if $has_todo;
push @{ $self->{todo_passed} } => $number
if $test->todo_passed;
push @{ $self->{skipped} } => $number
if $test->has_skip;
push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
$number;
push @{
$self->{
$test->is_actual_ok
? 'actual_passed'
: 'actual_failed'
}
} => $number;
},
},
yaml => { act => sub { }, },
);
# Each state contains a hash the keys of which match a token type. For
# each token
# type there may be:
# act A coderef to run
# goto The new state to move to. Stay in this state if
# missing
# continue Goto the new state and run the new state for the
# current token
%states = (
INIT => {
version => {
act => sub {
my ($version) = @_;
my $ver_num = $version->version;
if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
my $ver_min = $DEFAULT_TAP_VERSION + 1;
$self->_add_error(
"Explicit TAP version must be at least "
. "$ver_min. Got version $ver_num" );
$ver_num = $DEFAULT_TAP_VERSION;
}
if ( $ver_num > $MAX_TAP_VERSION ) {
$self->_add_error(
"TAP specified version $ver_num but "
. "we don't know about versions later "
. "than $MAX_TAP_VERSION" );
$ver_num = $MAX_TAP_VERSION;
}
$self->version($ver_num);
$self->_grammar->set_version($ver_num);
},
goto => 'PLAN'
},
plan => { goto => 'PLANNED' },
test => { goto => 'UNPLANNED' },
},
PLAN => {
plan => { goto => 'PLANNED' },
test => { goto => 'UNPLANNED' },
},
PLANNED => {
test => { goto => 'PLANNED_AFTER_TEST' },
plan => {
act => sub {
my ($version) = @_;
$self->_add_error(
'More than one plan found in TAP output');
},
},
},
PLANNED_AFTER_TEST => {
test => { goto => 'PLANNED_AFTER_TEST' },
plan => { act => sub { }, continue => 'PLANNED' },
yaml => { goto => 'PLANNED' },
},
GOT_PLAN => {
test => {
act => sub {
my ($plan) = @_;
my $line = $self->plan;
$self->_add_error(
"Plan ($line) must be at the beginning "
. "or end of the TAP output" );
$self->is_good_plan(0);
},
continue => 'PLANNED'
},
plan => { continue => 'PLANNED' },
},
UNPLANNED => {
test => { goto => 'UNPLANNED_AFTER_TEST' },
plan => { goto => 'GOT_PLAN' },
},
UNPLANNED_AFTER_TEST => {
test => { act => sub { }, continue => 'UNPLANNED' },
plan => { act => sub { }, continue => 'UNPLANNED' },
yaml => { goto => 'UNPLANNED' },
},
);
# Apply globals and defaults to state table
for my $name ( keys %states ) {
# Merge with globals
my $st = { %state_globals, %{ $states{$name} } };
# Add defaults
for my $next ( sort keys %{$st} ) {
if ( my $default = $state_defaults{$next} ) {
for my $def ( sort keys %{$default} ) {
$st->{$next}->{$def} ||= $default->{$def};
}
}
}
# Stuff back in table
$states{$name} = $st;
}
return \%states;
}
=head3 C<get_select_handles>
Get an a list of file handles which can be passed to C<select> to
determine the readiness of this parser.
=cut
sub get_select_handles { shift->_iterator->get_select_handles }
sub _grammar {
my $self = shift;
return $self->{_grammar} = shift if @_;
return $self->{_grammar} ||= $self->make_grammar(
{ iterator => $self->_iterator,
parser => $self,
version => $self->version
}
);
}
sub _iter {
my $self = shift;
my $iterator = $self->_iterator;
my $grammar = $self->_grammar;
my $spool = $self->_spool;
my $state = 'INIT';
my $state_table = $self->_make_state_table;
$self->start_time( $self->get_time );
$self->start_times( $self->get_times );
# Make next_state closure
my $next_state = sub {
my $token = shift;
my $type = $token->type;
TRANS: {
my $state_spec = $state_table->{$state}
or die "Illegal state: $state";
if ( my $next = $state_spec->{$type} ) {
if ( my $act = $next->{act} ) {
$act->($token);
}
if ( my $cont = $next->{continue} ) {
$state = $cont;
redo TRANS;
}
elsif ( my $goto = $next->{goto} ) {
$state = $goto;
}
}
else {
confess("Unhandled token type: $type\n");
}
}
return $token;
};
# Handle end of stream - which means either pop a block or finish
my $end_handler = sub {
$self->exit( $iterator->exit );
$self->wait( $iterator->wait );
$self->_finish;
return;
};
# Finally make the closure that we return. For performance reasons
# there are two versions of the returned function: one that handles
# callbacks and one that does not.
if ( $self->_has_callbacks ) {
return sub {
my $result = eval { $grammar->tokenize };
$self->_add_error($@) if $@;
if ( defined $result ) {
$result = $next_state->($result);
if ( my $code = $self->_callback_for( $result->type ) ) {
$_->($result) for @{$code};
}
else {
$self->_make_callback( 'ELSE', $result );
}
$self->_make_callback( 'ALL', $result );
# Echo TAP to spool file
print {$spool} $result->raw, "\n" if $spool;
}
else {
$result = $end_handler->();
$self->_make_callback( 'EOF', $self )
unless defined $result;
}
return $result;
};
} # _has_callbacks
else {
return sub {
my $result = eval { $grammar->tokenize };
$self->_add_error($@) if $@;
if ( defined $result ) {
$result = $next_state->($result);
# Echo TAP to spool file
print {$spool} $result->raw, "\n" if $spool;
}
else {
$result = $end_handler->();
}
return $result;
};
} # no callbacks
}
sub _finish {
my $self = shift;
$self->end_time( $self->get_time );
$self->end_times( $self->get_times );
# Avoid leaks
$self->_iterator(undef);
$self->_grammar(undef);
# If we just delete the iter we won't get a fault if it's recreated.
# Instead we set it to a sub that returns an infinite
# stream of undef. This segfaults on 5.5.4, presumably because
# we're still executing the closure that gets replaced and it hasn't
# been protected with a refcount.
$self->{_iter} = sub {return}
if $] >= 5.006;
# sanity checks
if ( !$self->plan ) {
$self->_add_error('No plan found in TAP output');
}
else {
$self->is_good_plan(1) unless defined $self->is_good_plan;
}
if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
$self->is_good_plan(0);
if ( defined( my $planned = $self->tests_planned ) ) {
my $ran = $self->tests_run;
$self->_add_error(
"Bad plan. You planned $planned tests but ran $ran.");
}
}
if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
# this should never happen
my $actual = $self->tests_run;
my $passed = $self->passed;
my $failed = $self->failed;
$self->_croak( "Panic: planned test count ($actual) did not equal "
. "sum of passed ($passed) and failed ($failed) tests!" );
}
$self->is_good_plan(0) unless defined $self->is_good_plan;
unless ( $self->parse_errors ) {
# Optimise storage where possible
if ( $self->tests_run == @{$self->{passed}} ) {
$self->{passed} = $self->tests_run;
}
if ( $self->tests_run == @{$self->{actual_passed}} ) {
$self->{actual_passed} = $self->tests_run;
}
}
return $self;
}
=head3 C<delete_spool>
Delete and return the spool.
my $fh = $parser->delete_spool;
=cut
sub delete_spool {
my $self = shift;
return delete $self->{_spool};
}
##############################################################################
=head1 CALLBACKS
As mentioned earlier, a "callback" key may be added to the
C<TAP::Parser> constructor. If present, each callback corresponding to a
given result type will be called with the result as the argument if the
C<run> method is used. The callback is expected to be a subroutine
reference (or anonymous subroutine) which is invoked with the parser
result as its argument.
my %callbacks = (
test => \&test_callback,
plan => \&plan_callback,
comment => \&comment_callback,
bailout => \&bailout_callback,
unknown => \&unknown_callback,
);
my $aggregator = TAP::Parser::Aggregator->new;
for 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 COMPATIBILITY
The Perl-QA list attempted to ensure backwards compatibility with
L<Test::Harness>. However, there are some minor differences.
=head2 Differences
=over 4
=item * TODO plans
A little-known feature of L<Test::Harness> is that it supported TODO
lists in the plan:
1..2 todo 2
ok 1 - We have liftoff
not ok 2 - Anti-gravity device activated
Under L<Test::Harness>, test number 2 would I<pass> because it was
listed as a TODO test on the plan line. However, we are not aware of
anyone actually using this feature and hard-coding test numbers is
discouraged because it's very easy to add a test and break the test
number sequence. This makes test suites very fragile. Instead, the
following should be used:
1..2
ok 1 - We have liftoff
not ok 2 - Anti-gravity device activated # TODO
=item * 'Missing' tests
It rarely happens, but sometimes a harness might encounter
'missing tests:
ok 1
ok 2
ok 15
ok 16
ok 17
L<Test::Harness> would report tests 3-14 as having failed. For the
C<TAP::Parser>, these tests are not considered failed because they've
never run. They're reported as parse failures (tests out of sequence).
=back
=head1 SUBCLASSING
If you find you need to provide custom functionality (as you would have using
L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
designed to be easily plugged-into and/or subclassed.
Before you start, it's important to know a few things:
=over 2
=item 1
All C<TAP::*> objects inherit from L<TAP::Object>.
=item 2
Many C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
=item 3
Note that C<TAP::Parser> is designed to be the central "maker" - ie: it is
responsible for creating most new objects in the C<TAP::Parser::*> namespace.
This makes it possible for you to have a single point of configuring what
subclasses should be used, which means that in many cases you'll find
you only need to sub-class one of the parser's components.
The exception to this rule are I<SourceHandlers> & I<Iterators>, but those are
both created with customizable I<IteratorFactory>.
=item 4
By subclassing, you may end up overriding undocumented methods. That's not
a bad thing per se, but be forewarned that undocumented methods may change
without warning from one release to the next - we cannot guarantee backwards
compatibility. If any I<documented> method needs changing, it will be
deprecated first, and changed in a later release.
=back
=head2 Parser Components
=head3 Sources
A TAP parser consumes input from a single I<raw source> of TAP, which could come
from anywhere (a file, an executable, a database, an IO handle, a URI, etc..).
The source gets bundled up in a L<TAP::Parser::Source> object which gathers some
meta data about it. The parser then uses a L<TAP::Parser::IteratorFactory> to
determine which L<TAP::Parser::SourceHandler> to use to turn the raw source
into a stream of TAP by way of L</Iterators>.
If you simply want C<TAP::Parser> to handle a new source of TAP you probably
don't need to subclass C<TAP::Parser> itself. Rather, you'll need to create a
new L<TAP::Parser::SourceHandler> class, and just plug it into the parser using
the I<sources> param to L</new>. Before you start writing one, read through
L<TAP::Parser::IteratorFactory> to get a feel for how the system works first.
If you find you really need to use your own iterator factory you can still do
so without sub-classing C<TAP::Parser> by setting L</iterator_factory_class>.
If you just need to customize the objects on creation, subclass L<TAP::Parser>
and override L</make_iterator_factory>.
Note that C<make_source> & C<make_perl_source> have been I<DEPRECATED> and
are now removed.
=head3 Iterators
A TAP parser uses I<iterators> to loop through the I<stream> of TAP read in
from the I<source> it was given. There are a few types of Iterators available
by default, all sub-classes of L<TAP::Parser::Iterator>. Choosing which
iterator to use is the responsibility of the I<iterator factory>, though it
simply delegates to the I<Source Handler> it uses.
If you're writing your own L<TAP::Parser::SourceHandler>, you may need to
create your own iterators too. If so you'll need to subclass
L<TAP::Parser::Iterator>.
Note that L</make_iterator> has been I<DEPRECATED> and is now removed.
=head3 Results
A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
input I<stream>. There are quite a few result types available; choosing
which class to use is the responsibility of the I<result factory>.
To create your own result types you have two options:
=over 2
=item option 1
Subclass L<TAP::Parser::Result> and register your new result type/class with
the default L<TAP::Parser::ResultFactory>.
=item option 2
Subclass L<TAP::Parser::ResultFactory> itself and implement your own
L<TAP::Parser::Result> creation logic. Then you'll need to customize the
class used by your parser by setting the C<result_factory_class> parameter.
See L</new> for more details.
=back
If you need to customize the objects on creation, subclass L<TAP::Parser> and
override L</make_result>.
=head3 Grammar
L<TAP::Parser::Grammar> is the heart of the parser. It tokenizes the TAP
input I<stream> and produces results. If you need to customize its behaviour
you should probably familiarize yourself with the source first. Enough
lecturing.
Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
C<grammar_class> parameter. See L</new> for more details.
If you need to customize the objects on creation, subclass L<TAP::Parser> and
override L</make_grammar>
=head1 ACKNOWLEDGMENTS
All of the following have helped. Bug reports, patches, (im)moral
support, or just words of encouragement have all been forthcoming.
=over 4
=item * Michael Schwern
=item * Andy Lester
=item * chromatic
=item * GEOFFR
=item * Shlomi Fish
=item * Torsten Schoenfeld
=item * Jerry Gay
=item * Aristotle
=item * Adam Kennedy
=item * Yves Orton
=item * Adrian Howard
=item * Sean & Lil
=item * Andreas J. Koenig
=item * Florian Ragwitz
=item * Corion
=item * Mark Stosberg
=item * Matt Kraai
=item * David Wheeler
=item * Alex Vandiver
=item * Cosimo Streppone
=item * Ville Skyttä
=back
=head1 AUTHORS
Curtis "Ovid" Poe <ovid@cpan.org>
Andy Armstong <andy@hexten.net>
Eric Wilhelm @ <ewilhelm at cpan dot org>
Michael Peters <mpeters at plusthree dot com>
Leif Eriksen <leif dot eriksen at bigpond dot com>
Steve Purkis <spurkis@cpan.org>
Nicholas Clark <nick@ccl4.org>
Lee Johnson <notfadeaway at btinternet dot com>
Philippe Bruhat <book@cpan.org>
=head1 BUGS
Please report any bugs or feature requests to
C<bug-test-harness@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
We will be notified, and then you'll automatically be notified of
progress on your bug as we make changes.
Obviously, bugs which include patches are best. If you prefer, you can
patch against bleed by via anonymous checkout of the latest version:
git clone git://github.com/Perl-Toolchain-Gang/Test-Harness.git
=head1 COPYRIGHT & LICENSE
Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
PK �[�d}a^. ^. Formatter/Base.pmnu �[��� package TAP::Formatter::Base;
use strict;
use warnings;
use base 'TAP::Base';
use POSIX qw(strftime);
my $MAX_ERRORS = 5;
my %VALIDATION_FOR;
BEGIN {
%VALIDATION_FOR = (
directives => sub { shift; shift },
verbosity => sub { shift; shift },
normalize => sub { shift; shift },
timer => sub { shift; shift },
failures => sub { shift; shift },
comments => sub { shift; shift },
errors => sub { shift; shift },
color => sub { shift; shift },
jobs => sub { shift; shift },
show_count => sub { shift; shift },
stdout => sub {
my ( $self, $ref ) = @_;
$self->_croak("option 'stdout' needs a filehandle")
unless $self->_is_filehandle($ref);
return $ref;
},
);
sub _is_filehandle {
my ( $self, $ref ) = @_;
return 0 if !defined $ref;
return 1 if ref $ref eq 'GLOB'; # lexical filehandle
return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT
return 1 if eval { $ref->can('print') };
return 0;
}
my @getter_setters = qw(
_longest
_printed_summary_header
_colorizer
);
__PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
}
=head1 NAME
TAP::Formatter::Base - Base class for harness output delegates
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This provides console orientated output formatting for TAP::Harness.
=head1 SYNOPSIS
use TAP::Formatter::Console;
my $harness = TAP::Formatter::Console->new( \%args );
=cut
sub _initialize {
my ( $self, $arg_for ) = @_;
$arg_for ||= {};
$self->SUPER::_initialize($arg_for);
my %arg_for = %$arg_for; # force a shallow copy
$self->verbosity(0);
for my $name ( keys %VALIDATION_FOR ) {
my $property = delete $arg_for{$name};
if ( defined $property ) {
my $validate = $VALIDATION_FOR{$name};
$self->$name( $self->$validate($property) );
}
}
if ( my @props = keys %arg_for ) {
$self->_croak(
"Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
}
$self->stdout( \*STDOUT ) unless $self->stdout;
if ( $self->color ) {
require TAP::Formatter::Color;
$self->_colorizer( TAP::Formatter::Color->new );
}
return $self;
}
sub verbose { shift->verbosity >= 1 }
sub quiet { shift->verbosity <= -1 }
sub really_quiet { shift->verbosity <= -2 }
sub silent { shift->verbosity <= -3 }
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my %args = (
verbose => 1,
)
my $harness = TAP::Formatter::Console->new( \%args );
The constructor returns a new C<TAP::Formatter::Console> object. If
a L<TAP::Harness> is created with no C<formatter> a
C<TAP::Formatter::Console> is automatically created. If any of the
following options were given to TAP::Harness->new they well be passed to
this constructor which accepts an optional hashref whose allowed keys are:
=over 4
=item * C<verbosity>
Set the verbosity level.
=item * C<verbose>
Printing individual test results to STDOUT.
=item * C<timer>
Append run time for each test to output. Uses L<Time::HiRes> if available.
=item * C<failures>
Show test failures (this is a no-op if C<verbose> is selected).
=item * C<comments>
Show test comments (this is a no-op if C<verbose> is selected).
=item * C<quiet>
Suppressing some test output (mostly failures while tests are running).
=item * C<really_quiet>
Suppressing everything but the tests summary.
=item * C<silent>
Suppressing all output.
=item * C<errors>
If parse errors are found in the TAP output, a note of this will be made
in the summary report. To see all of the parse errors, set this argument to
true:
errors => 1
=item * C<directives>
If set to a true value, only test results with directives will be displayed.
This overrides other settings such as C<verbose>, C<failures>, or C<comments>.
=item * C<stdout>
A filehandle for catching standard output.
=item * C<color>
If defined specifies whether color output is desired. If C<color> is not
defined it will default to color output if color support is available on
the current platform and output is not being redirected.
=item * C<jobs>
The number of concurrent jobs this formatter will handle.
=item * C<show_count>
Boolean value. If false, disables the C<X/Y> test count which shows up while
tests are running.
=back
Any keys for which the value is C<undef> will be ignored.
=cut
# new supplied by TAP::Base
=head3 C<prepare>
Called by Test::Harness before any test output is generated.
This is an advisory and may not be called in the case where tests are
being supplied to Test::Harness by an iterator.
=cut
sub prepare {
my ( $self, @tests ) = @_;
my $longest = 0;
for my $test (@tests) {
$longest = length $test if length $test > $longest;
}
$self->_longest($longest);
}
sub _format_now { strftime "[%H:%M:%S]", localtime }
sub _format_name {
my ( $self, $test ) = @_;
my $name = $test;
my $periods = '.' x ( $self->_longest + 2 - length $test );
$periods = " $periods ";
if ( $self->timer ) {
my $stamp = $self->_format_now();
return "$stamp $name$periods";
}
else {
return "$name$periods";
}
}
=head3 C<open_test>
Called to create a new test session. A test session looks like this:
my $session = $formatter->open_test( $test, $parser );
while ( defined( my $result = $parser->next ) ) {
$session->result($result);
exit 1 if $result->is_bailout;
}
$session->close_test;
=cut
sub open_test {
die "Unimplemented.";
}
sub _output_success {
my ( $self, $msg ) = @_;
$self->_output($msg);
}
=head3 C<summary>
$harness->summary( $aggregate );
C<summary> prints the summary report after all tests are run. The first
argument is an aggregate to summarise. An optional second argument may
be set to a true value to indicate that the summary is being output as a
result of an interrupted test run.
=cut
sub summary {
my ( $self, $aggregate, $interrupted ) = @_;
return if $self->silent;
my @t = $aggregate->descriptions;
my $tests = \@t;
my $runtime = $aggregate->elapsed_timestr;
my $total = $aggregate->total;
my $passed = $aggregate->passed;
if ( $self->timer ) {
$self->_output( $self->_format_now(), "\n" );
}
$self->_failure_output("Test run interrupted!\n")
if $interrupted;
# TODO: Check this condition still works when all subtests pass but
# the exit status is nonzero
if ( $aggregate->all_passed ) {
$self->_output_success("All tests successful.\n");
}
# ~TODO option where $aggregate->skipped generates reports
if ( $total != $passed or $aggregate->has_problems ) {
$self->_output("\nTest Summary Report");
$self->_output("\n-------------------\n");
for my $test (@$tests) {
$self->_printed_summary_header(0);
my ($parser) = $aggregate->parsers($test);
$self->_output_summary_failure(
'failed',
[ ' Failed test: ', ' Failed tests: ' ],
$test, $parser
);
$self->_output_summary_failure(
'todo_passed',
" TODO passed: ", $test, $parser
);
# ~TODO this cannot be the default
#$self->_output_summary_failure( 'skipped', " Tests skipped: " );
if ( my $exit = $parser->exit ) {
$self->_summary_test_header( $test, $parser );
$self->_failure_output(" Non-zero exit status: $exit\n");
}
elsif ( my $wait = $parser->wait ) {
$self->_summary_test_header( $test, $parser );
$self->_failure_output(" Non-zero wait status: $wait\n");
}
if ( my @errors = $parser->parse_errors ) {
my $explain;
if ( @errors > $MAX_ERRORS && !$self->errors ) {
$explain
= "Displayed the first $MAX_ERRORS of "
. scalar(@errors)
. " TAP syntax errors.\n"
. "Re-run prove with the -p option to see them all.\n";
splice @errors, $MAX_ERRORS;
}
$self->_summary_test_header( $test, $parser );
$self->_failure_output(
sprintf " Parse errors: %s\n",
shift @errors
);
for my $error (@errors) {
my $spaces = ' ' x 16;
$self->_failure_output("$spaces$error\n");
}
$self->_failure_output($explain) if $explain;
}
}
}
my $files = @$tests;
$self->_output("Files=$files, Tests=$total, $runtime\n");
my $status = $aggregate->get_status;
$self->_output("Result: $status\n");
}
sub _output_summary_failure {
my ( $self, $method, $name, $test, $parser ) = @_;
# ugly hack. Must rethink this :(
my $output = $method eq 'failed' ? '_failure_output' : '_output';
if ( my @r = $parser->$method() ) {
$self->_summary_test_header( $test, $parser );
my ( $singular, $plural )
= 'ARRAY' eq ref $name ? @$name : ( $name, $name );
$self->$output( @r == 1 ? $singular : $plural );
my @results = $self->_balanced_range( 40, @r );
$self->$output( sprintf "%s\n" => shift @results );
my $spaces = ' ' x 16;
while (@results) {
$self->$output( sprintf "$spaces%s\n" => shift @results );
}
}
}
sub _summary_test_header {
my ( $self, $test, $parser ) = @_;
return if $self->_printed_summary_header;
my $spaces = ' ' x ( $self->_longest - length $test );
$spaces = ' ' unless $spaces;
my $output = $self->_get_output_method($parser);
my $wait = $parser->wait;
defined $wait or $wait = '(none)';
$self->$output(
sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n",
$wait, $parser->tests_run, scalar $parser->failed
);
$self->_printed_summary_header(1);
}
sub _output {
my $self = shift;
print { $self->stdout } @_;
}
sub _failure_output {
my $self = shift;
$self->_output(@_);
}
sub _balanced_range {
my ( $self, $limit, @range ) = @_;
@range = $self->_range(@range);
my $line = "";
my @lines;
my $curr = 0;
while (@range) {
if ( $curr < $limit ) {
my $range = ( shift @range ) . ", ";
$line .= $range;
$curr += length $range;
}
elsif (@range) {
$line =~ s/, $//;
push @lines => $line;
$line = '';
$curr = 0;
}
}
if ($line) {
$line =~ s/, $//;
push @lines => $line;
}
return @lines;
}
sub _range {
my ( $self, @numbers ) = @_;
# shouldn't be needed, but subclasses might call this
@numbers = sort { $a <=> $b } @numbers;
my ( $min, @range );
for my $i ( 0 .. $#numbers ) {
my $num = $numbers[$i];
my $next = $numbers[ $i + 1 ];
if ( defined $next && $next == $num + 1 ) {
if ( !defined $min ) {
$min = $num;
}
}
elsif ( defined $min ) {
push @range => "$min-$num";
undef $min;
}
else {
push @range => $num;
}
}
return @range;
}
sub _get_output_method {
my ( $self, $parser ) = @_;
return $parser->has_problems ? '_failure_output' : '_output';
}
1;
PK �[�7�R R Formatter/File.pmnu �[��� package TAP::Formatter::File;
use strict;
use warnings;
use TAP::Formatter::File::Session;
use POSIX qw(strftime);
use base 'TAP::Formatter::Base';
=head1 NAME
TAP::Formatter::File - Harness output delegate for file output
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This provides file orientated output formatting for TAP::Harness.
=head1 SYNOPSIS
use TAP::Formatter::File;
my $harness = TAP::Formatter::File->new( \%args );
=head2 C<< open_test >>
See L<TAP::Formatter::Base>
=cut
sub open_test {
my ( $self, $test, $parser ) = @_;
my $session = TAP::Formatter::File::Session->new(
{ name => $test,
formatter => $self,
parser => $parser,
}
);
$session->header;
return $session;
}
sub _should_show_count {
return 0;
}
1;
PK �[�z1�� � Formatter/Console.pmnu �[��� package TAP::Formatter::Console;
use strict;
use warnings;
use base 'TAP::Formatter::Base';
use POSIX qw(strftime);
=head1 NAME
TAP::Formatter::Console - Harness output delegate for default console output
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This provides console orientated output formatting for TAP::Harness.
=head1 SYNOPSIS
use TAP::Formatter::Console;
my $harness = TAP::Formatter::Console->new( \%args );
=head2 C<< open_test >>
See L<TAP::Formatter::Base>
=cut
sub open_test {
my ( $self, $test, $parser ) = @_;
my $class
= $self->jobs > 1
? 'TAP::Formatter::Console::ParallelSession'
: 'TAP::Formatter::Console::Session';
eval "require $class";
$self->_croak($@) if $@;
my $session = $class->new(
{ name => $test,
formatter => $self,
parser => $parser,
show_count => $self->show_count,
}
);
$session->header;
return $session;
}
# Use _colorizer delegate to set output color. NOP if we have no delegate
sub _set_colors {
my ( $self, @colors ) = @_;
if ( my $colorizer = $self->_colorizer ) {
my $output_func = $self->{_output_func} ||= sub {
$self->_output(@_);
};
$colorizer->set_color( $output_func, $_ ) for @colors;
}
}
sub _failure_color {
my ($self) = @_;
return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red';
}
sub _success_color {
my ($self) = @_;
return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green';
}
sub _output_success {
my ( $self, $msg ) = @_;
$self->_set_colors( $self->_success_color() );
$self->_output($msg);
$self->_set_colors('reset');
}
sub _failure_output {
my $self = shift;
$self->_set_colors( $self->_failure_color() );
my $out = join '', @_;
my $has_newline = chomp $out;
$self->_output($out);
$self->_set_colors('reset');
$self->_output($/)
if $has_newline;
}
1;
PK �[���| | Formatter/Session.pmnu �[��� package TAP::Formatter::Session;
use strict;
use warnings;
use base 'TAP::Base';
my @ACCESSOR;
BEGIN {
@ACCESSOR = qw( name formatter parser show_count );
for my $method (@ACCESSOR) {
no strict 'refs';
*$method = sub { shift->{$method} };
}
}
=head1 NAME
TAP::Formatter::Session - Abstract base class for harness output delegate
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my %args = (
formatter => $self,
)
my $harness = TAP::Formatter::Console::Session->new( \%args );
The constructor returns a new C<TAP::Formatter::Console::Session> object.
=over 4
=item * C<formatter>
=item * C<parser>
=item * C<name>
=item * C<show_count>
=back
=cut
sub _initialize {
my ( $self, $arg_for ) = @_;
$arg_for ||= {};
$self->SUPER::_initialize($arg_for);
my %arg_for = %$arg_for; # force a shallow copy
for my $name (@ACCESSOR) {
$self->{$name} = delete $arg_for{$name};
}
if ( !defined $self->show_count ) {
$self->{show_count} = 1; # defaults to true
}
if ( $self->show_count ) { # but may be a damned lie!
$self->{show_count} = $self->_should_show_count;
}
if ( my @props = sort keys %arg_for ) {
$self->_croak(
"Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
}
return $self;
}
=head3 C<header>
Output test preamble
=head3 C<result>
Called by the harness for each line of TAP it receives.
=head3 C<close_test>
Called to close a test session.
=head3 C<clear_for_close>
Called by C<close_test> to clear the line showing test progress, or the parallel
test ruler, prior to printing the final test result.
=head3 C<time_report>
Return a formatted string about the elapsed (wall-clock) time
and about the consumed CPU time.
=cut
sub header { }
sub result { }
sub close_test { }
sub clear_for_close { }
sub _should_show_count {
my $self = shift;
return
!$self->formatter->verbose
&& -t $self->formatter->stdout
&& !$ENV{HARNESS_NOTTY};
}
sub _format_for_output {
my ( $self, $result ) = @_;
return $self->formatter->normalize ? $result->as_string : $result->raw;
}
sub _output_test_failure {
my ( $self, $parser ) = @_;
my $formatter = $self->formatter;
return if $formatter->really_quiet;
my $tests_run = $parser->tests_run;
my $tests_planned = $parser->tests_planned;
my $total
= defined $tests_planned
? $tests_planned
: $tests_run;
my $passed = $parser->passed;
# The total number of fails includes any tests that were planned but
# didn't run
my $failed = $parser->failed + $total - $tests_run;
my $exit = $parser->exit;
if ( my $exit = $parser->exit ) {
my $wstat = $parser->wait;
my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
$formatter->_failure_output("Dubious, test returned $status\n");
}
if ( $failed == 0 ) {
$formatter->_failure_output(
$total
? "All $total subtests passed "
: 'No subtests run '
);
}
else {
$formatter->_failure_output("Failed $failed/$total subtests ");
if ( !$total ) {
$formatter->_failure_output("\nNo tests run!");
}
}
if ( my $skipped = $parser->skipped ) {
$passed -= $skipped;
my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
$formatter->_output(
"\n\t(less $skipped skipped $test: $passed okay)");
}
if ( my $failed = $parser->todo_passed ) {
my $test = $failed > 1 ? 'tests' : 'test';
$formatter->_output(
"\n\t($failed TODO $test unexpectedly succeeded)");
}
$formatter->_output("\n");
}
sub _make_ok_line {
my ( $self, $suffix ) = @_;
return "ok$suffix\n";
}
sub time_report {
my ( $self, $formatter, $parser ) = @_;
my @time_report;
if ( $formatter->timer ) {
my $start_time = $parser->start_time;
my $end_time = $parser->end_time;
if ( defined $start_time and defined $end_time ) {
my $elapsed = $end_time - $start_time;
push @time_report,
$self->time_is_hires
? sprintf( ' %8d ms', $elapsed * 1000 )
: sprintf( ' %8s s', $elapsed || '<1' );
}
my $start_times = $parser->start_times();
my $end_times = $parser->end_times();
my $usr = $end_times->[0] - $start_times->[0];
my $sys = $end_times->[1] - $start_times->[1];
my $cusr = $end_times->[2] - $start_times->[2];
my $csys = $end_times->[3] - $start_times->[3];
push @time_report,
sprintf('(%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)',
$usr, $sys, $cusr, $csys,
$usr + $sys + $cusr + $csys);
}
return "@time_report";
}
1;
PK �[�·�� � Formatter/Console/Session.pmnu �[��� package TAP::Formatter::Console::Session;
use strict;
use warnings;
use base 'TAP::Formatter::Session';
my @ACCESSOR;
BEGIN {
my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
for my $method (@CLOSURE_BINDING) {
no strict 'refs';
*$method = sub {
my $self = shift;
return ( $self->{_closures} ||= $self->_closures )->{$method}
->(@_);
};
}
}
=head1 NAME
TAP::Formatter::Console::Session - Harness output delegate for default console output
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This provides console orientated output formatting for TAP::Harness.
=cut
sub _get_output_result {
my $self = shift;
my @color_map = (
{ test => sub { $_->is_test && !$_->is_ok },
colors => ['red'],
},
{ test => sub { $_->is_test && $_->has_skip },
colors => [
'white',
'on_blue'
],
},
{ test => sub { $_->is_test && $_->has_todo },
colors => ['yellow'],
},
);
my $formatter = $self->formatter;
my $parser = $self->parser;
return $formatter->_colorizer
? sub {
my $result = shift;
for my $col (@color_map) {
local $_ = $result;
if ( $col->{test}->() ) {
$formatter->_set_colors( @{ $col->{colors} } );
last;
}
}
$formatter->_output( $self->_format_for_output($result) );
$formatter->_set_colors('reset');
}
: sub {
$formatter->_output( $self->_format_for_output(shift) );
};
}
sub _closures {
my $self = shift;
my $parser = $self->parser;
my $formatter = $self->formatter;
my $pretty = $formatter->_format_name( $self->name );
my $show_count = $self->show_count;
my $really_quiet = $formatter->really_quiet;
my $quiet = $formatter->quiet;
my $verbose = $formatter->verbose;
my $directives = $formatter->directives;
my $failures = $formatter->failures;
my $comments = $formatter->comments;
my $output_result = $self->_get_output_result;
my $output = '_output';
my $plan = '';
my $newline_printed = 0;
my $last_status_printed = 0;
return {
header => sub {
$formatter->_output($pretty)
unless $really_quiet;
},
result => sub {
my $result = shift;
if ( $result->is_bailout ) {
$formatter->_failure_output(
"Bailout called. Further testing stopped: "
. $result->explanation
. "\n" );
}
return if $really_quiet;
my $is_test = $result->is_test;
# These are used in close_test - but only if $really_quiet
# is false - so it's safe to only set them here unless that
# relationship changes.
if ( !$plan ) {
my $planned = $parser->tests_planned || '?';
$plan = "/$planned ";
}
$output = $formatter->_get_output_method($parser);
if ( $show_count and $is_test ) {
my $number = $result->number;
my $now = CORE::time;
# Print status roughly once per second.
# We will always get the first number as a side effect of
# $last_status_printed starting with the value 0, which $now
# will never be. (Unless someone sets their clock to 1970)
if ( $last_status_printed != $now ) {
$formatter->$output("\r$pretty$number$plan");
$last_status_printed = $now;
}
}
if (!$quiet
&& ( $verbose
|| ( $is_test && $failures && !$result->is_ok )
|| ( $comments && $result->is_comment )
|| ( $directives && $result->has_directive ) )
)
{
unless ($newline_printed) {
$formatter->_output("\n");
$newline_printed = 1;
}
$output_result->($result);
$formatter->_output("\n");
}
},
clear_for_close => sub {
my $spaces
= ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
$formatter->$output("\r$spaces");
},
close_test => sub {
if ( $show_count && !$really_quiet ) {
$self->clear_for_close;
$formatter->$output("\r$pretty");
}
# Avoid circular references
$self->parser(undef);
$self->{_closures} = {};
return if $really_quiet;
if ( my $skip_all = $parser->skip_all ) {
$formatter->_output("skipped: $skip_all\n");
}
elsif ( $parser->has_problems ) {
$self->_output_test_failure($parser);
}
else {
my $time_report = $self->time_report($formatter, $parser);
$formatter->_output( $self->_make_ok_line($time_report) );
}
},
};
}
=head2 C<< clear_for_close >>
=head2 C<< close_test >>
=head2 C<< header >>
=head2 C<< result >>
=cut
1;
PK �[|0s W W $ Formatter/Console/ParallelSession.pmnu �[��� package TAP::Formatter::Console::ParallelSession;
use strict;
use warnings;
use File::Spec;
use File::Path;
use Carp;
use base 'TAP::Formatter::Console::Session';
use constant WIDTH => 72; # Because Eric says
my %shared;
sub _initialize {
my ( $self, $arg_for ) = @_;
$self->SUPER::_initialize($arg_for);
my $formatter = $self->formatter;
# Horrid bodge. This creates our shared context per harness. Maybe
# TAP::Harness should give us this?
my $context = $shared{$formatter} ||= $self->_create_shared_context;
push @{ $context->{active} }, $self;
return $self;
}
sub _create_shared_context {
my $self = shift;
return {
active => [],
tests => 0,
fails => 0,
};
}
=head1 NAME
TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This provides console orientated output formatting for L<TAP::Harness>
when run with multiple L<TAP::Harness/jobs>.
=head1 SYNOPSIS
=cut
=head1 METHODS
=head2 Class Methods
=head3 C<header>
Output test preamble
=cut
sub header {
}
sub _clear_ruler {
my $self = shift;
$self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
}
my $now = 0;
my $start;
my $trailer = '... )===';
my $chop_length = WIDTH - length $trailer;
sub _output_ruler {
my ( $self, $refresh ) = @_;
my $new_now = time;
return if $new_now == $now and !$refresh;
$now = $new_now;
$start ||= $now;
my $formatter = $self->formatter;
return if $formatter->really_quiet;
my $context = $shared{$formatter};
my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start;
for my $active ( @{ $context->{active} } ) {
my $parser = $active->parser;
my $tests = $parser->tests_run;
my $planned = $parser->tests_planned || '?';
$ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests;
}
chop $ruler; # Remove a trailing space
$ruler .= ')===';
if ( length $ruler > WIDTH ) {
$ruler =~ s/(.{$chop_length}).*/$1$trailer/o;
}
else {
$ruler .= '=' x ( WIDTH - length($ruler) );
}
$formatter->_output("\r$ruler");
}
=head3 C<result>
Called by the harness for each line of TAP it receives .
=cut
sub result {
my ( $self, $result ) = @_;
my $formatter = $self->formatter;
# my $really_quiet = $formatter->really_quiet;
# my $show_count = $self->_should_show_count;
if ( $result->is_test ) {
my $context = $shared{$formatter};
$context->{tests}++;
my $active = $context->{active};
if ( @$active == 1 ) {
# There is only one test, so use the serial output format.
return $self->SUPER::result($result);
}
$self->_output_ruler( $self->parser->tests_run == 1 );
}
elsif ( $result->is_bailout ) {
$formatter->_failure_output(
"Bailout called. Further testing stopped: "
. $result->explanation
. "\n" );
}
}
=head3 C<clear_for_close>
=cut
sub clear_for_close {
my $self = shift;
my $formatter = $self->formatter;
return if $formatter->really_quiet;
my $context = $shared{$formatter};
if ( @{ $context->{active} } == 1 ) {
$self->SUPER::clear_for_close;
}
else {
$self->_clear_ruler;
}
}
=head3 C<close_test>
=cut
sub close_test {
my $self = shift;
my $name = $self->name;
my $parser = $self->parser;
my $formatter = $self->formatter;
my $context = $shared{$formatter};
$self->SUPER::close_test;
my $active = $context->{active};
my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
die "Can't find myself" unless @pos;
splice @$active, $pos[0], 1;
if ( @$active > 1 ) {
$self->_output_ruler(1);
}
elsif ( @$active == 1 ) {
# Print out "test/name.t ...."
$active->[0]->SUPER::header;
}
else {
# $self->formatter->_output("\n");
delete $shared{$formatter};
}
}
1;
PK �[E�Tb Formatter/Color.pmnu �[��� package TAP::Formatter::Color;
use strict;
use warnings;
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use base 'TAP::Object';
my $NO_COLOR;
BEGIN {
$NO_COLOR = 0;
eval 'require Term::ANSIColor';
if ($@) {
$NO_COLOR = $@;
};
if (IS_WIN32) {
eval 'use Win32::Console::ANSI';
if ($@) {
$NO_COLOR = $@;
}
};
if ($NO_COLOR) {
*set_color = sub { };
} else {
*set_color = sub {
my ( $self, $output, $color ) = @_;
$output->( Term::ANSIColor::color($color) );
};
}
}
=head1 NAME
TAP::Formatter::Color - Run Perl test scripts with color
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=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 (and L<Win32::Console::ANSI> if running
under Windows) tests will be run without color.
=head1 SYNOPSIS
use TAP::Formatter::Color;
my $harness = TAP::Formatter::Color->new( \%args );
$harness->runtests(@tests);
=head1 METHODS
=head2 Class Methods
=head3 C<new>
The constructor returns a new C<TAP::Formatter::Color> object. If
L<Term::ANSIColor> is not installed, returns undef.
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my $self = shift;
if ($NO_COLOR) {
# shorten that message a bit
( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
warn "Note: Cannot run tests in color: $error\n";
return; # abort object construction
}
return $self;
}
##############################################################################
=head3 C<can_color>
Test::Formatter::Color->can_color()
Returns a boolean indicating whether or not this module can actually
generate colored output. This will be false if it could not load the
modules needed for the current platform.
=cut
sub can_color {
return !$NO_COLOR;
}
=head3 C<set_color>
Set the output color.
=cut
1;
PK �[eSUp� � Formatter/File/Session.pmnu �[��� package TAP::Formatter::File::Session;
use strict;
use warnings;
use base 'TAP::Formatter::Session';
=head1 NAME
TAP::Formatter::File::Session - Harness output delegate for file output
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This provides file orientated output formatting for L<TAP::Harness>.
It is particularly important when running with parallel tests, as it
ensures that test results are not interleaved, even when run
verbosely.
=cut
=head1 METHODS
=head2 result
Stores results for later output, all together.
=cut
sub result {
my $self = shift;
my $result = shift;
my $parser = $self->parser;
my $formatter = $self->formatter;
if ( $result->is_bailout ) {
$formatter->_failure_output(
"Bailout called. Further testing stopped: "
. $result->explanation
. "\n" );
return;
}
if (!$formatter->quiet
&& ( $formatter->verbose
|| ( $result->is_test && $formatter->failures && !$result->is_ok )
|| ( $formatter->comments && $result->is_comment )
|| ( $result->has_directive && $formatter->directives ) )
)
{
$self->{results} .= $self->_format_for_output($result) . "\n";
}
}
=head2 close_test
When the test file finishes, outputs the summary, together.
=cut
sub close_test {
my $self = shift;
# Avoid circular references
$self->parser(undef);
my $parser = $self->parser;
my $formatter = $self->formatter;
my $pretty = $formatter->_format_name( $self->name );
return if $formatter->really_quiet;
if ( my $skip_all = $parser->skip_all ) {
$formatter->_output( $pretty . "skipped: $skip_all\n" );
}
elsif ( $parser->has_problems ) {
$formatter->_output(
$pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) );
$self->_output_test_failure($parser);
}
else {
my $time_report = $self->time_report($formatter, $parser);
$formatter->_output( $pretty
. ( $self->{results} ? "\n" . $self->{results} : "" )
. $self->_make_ok_line($time_report) );
}
}
1;
PK �[�p p Parser/Result/YAML.pmnu �[��� package TAP::Parser::Result::YAML;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::YAML - YAML result token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=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;
PK �[���� � Parser/Result/Comment.pmnu �[��� package TAP::Parser::Result::Comment;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::Comment - Comment result token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=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;
PK �[�-�&� � Parser/Result/Pragma.pmnu �[��� package TAP::Parser::Result::Pragma;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::Pragma - TAP pragma token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=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;
PK �[k*r�| | Parser/Result/Bailout.pmnu �[��� package TAP::Parser::Result::Bailout;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::Bailout - Bailout result token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=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;
PK �[��� Parser/Result/Plan.pmnu �[��� package TAP::Parser::Result::Plan;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::Plan - Plan result token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This is a subclass of L<TAP::Parser::Result>. A token of this class will be
returned if a plan line is encountered.
1..1
ok 1 - woo hooo!
C<1..1> is the plan. Gotta have a plan.
=head1 OVERRIDDEN METHODS
Mainly listed here to shut up the pitiful screams of the pod coverage tests.
They keep me awake at night.
=over 4
=item * C<as_string>
=item * C<raw>
=back
=cut
##############################################################################
=head2 Instance Methods
=head3 C<plan>
if ( $result->is_plan ) {
print $result->plan;
}
This is merely a synonym for C<as_string>.
=cut
sub plan { '1..' . shift->{tests_planned} }
##############################################################################
=head3 C<tests_planned>
my $planned = $result->tests_planned;
Returns the number of tests planned. For example, a plan of C<1..17> will
cause this method to return '17'.
=cut
sub tests_planned { shift->{tests_planned} }
##############################################################################
=head3 C<directive>
my $directive = $plan->directive;
If a SKIP directive is included with the plan, this method will return it.
1..0 # SKIP: why bother?
=cut
sub directive { shift->{directive} }
##############################################################################
=head3 C<has_skip>
if ( $result->has_skip ) { ... }
Returns a boolean value indicating whether or not this test has a SKIP
directive.
=head3 C<explanation>
my $explanation = $plan->explanation;
If a SKIP directive was included with the plan, this method will return the
explanation, if any.
=cut
sub explanation { shift->{explanation} }
=head3 C<todo_list>
my $todo = $result->todo_list;
for ( @$todo ) {
...
}
=cut
sub todo_list { shift->{todo_list} }
1;
PK �[/�ߐ� � Parser/Result/Unknown.pmnu �[��� package TAP::Parser::Result::Unknown;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::Unknown - Unknown result token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=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;
PK �[|Az�� � Parser/Result/Test.pmnu �[��� package TAP::Parser::Result::Test;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::Test - Test result token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=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 explanation, 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;
PK �[C;M� � Parser/Result/Version.pmnu �[��� package TAP::Parser::Result::Version;
use strict;
use warnings;
use base 'TAP::Parser::Result';
=head1 NAME
TAP::Parser::Result::Version - TAP syntax version token.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 DESCRIPTION
This is a subclass of L<TAP::Parser::Result>. A token of this class will be
returned if a version line is encountered.
TAP version 13
ok 1
not ok 2
The first version of TAP to include an explicit version number is 13.
=head1 OVERRIDDEN METHODS
Mainly listed here to shut up the pitiful screams of the pod coverage tests.
They keep me awake at night.
=over 4
=item * C<as_string>
=item * C<raw>
=back
=cut
##############################################################################
=head2 Instance Methods
=head3 C<version>
if ( $result->is_version ) {
print $result->version;
}
This is merely a synonym for C<as_string>.
=cut
sub version { shift->{version} }
1;
PK �[�$� � Parser/Scheduler/Spinner.pmnu �[��� package TAP::Parser::Scheduler::Spinner;
use strict;
use warnings;
use Carp;
=head1 NAME
TAP::Parser::Scheduler::Spinner - A no-op job.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Scheduler::Spinner;
=head1 DESCRIPTION
A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
the harness to spin (keep executing tests) while the scheduler can't
return a real job.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $job = TAP::Parser::Scheduler::Spinner->new;
Ignores any arguments and returns a new C<TAP::Parser::Scheduler::Spinner> object.
=cut
sub new { bless {}, shift }
=head2 Instance Methods
=head3 C<is_spinner>
Returns true indicating that is a 'spinner' job. Spinners are returned
when the scheduler still has pending jobs but can't (because of locking)
return one right now.
=cut
sub is_spinner {1}
=head1 SEE ALSO
L<TAP::Parser::Scheduler>, L<TAP::Parser::Scheduler::Job>
=cut
1;
PK �[i"dj� � Parser/Scheduler/Job.pmnu �[��� package TAP::Parser::Scheduler::Job;
use strict;
use warnings;
use Carp;
=head1 NAME
TAP::Parser::Scheduler::Job - A single testing job.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Scheduler::Job;
=head1 DESCRIPTION
Represents a single test 'job'.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $job = TAP::Parser::Scheduler::Job->new(
$filename, $description
);
Given the filename and description of a test as scalars, returns a new
L<TAP::Parser::Scheduler::Job> object.
=cut
sub new {
my ( $class, $name, $desc, @ctx ) = @_;
return bless {
filename => $name,
description => $desc,
@ctx ? ( context => \@ctx ) : (),
}, $class;
}
=head2 Instance Methods
=head3 C<on_finish>
$self->on_finish(\&method).
Register a closure to be called when this job is destroyed. The callback
will be passed the C<TAP::Parser::Scheduler::Job> object as it's only argument.
=cut
sub on_finish {
my ( $self, $cb ) = @_;
$self->{on_finish} = $cb;
}
=head3 C<finish>
$self->finish;
Called when a job is complete to unlock it. If a callback has been registered
with C<on_finish>, it calls it. Otherwise, it does nothing.
=cut
sub finish {
my $self = shift;
if ( my $cb = $self->{on_finish} ) {
$cb->($self);
}
}
=head2 Attributes
$self->filename;
$self->description;
$self->context;
These are all "getters" which return the data set for these attributes during object construction.
=head3 C<filename>
=head3 C<description>
=head3 C<context>
=cut
sub filename { shift->{filename} }
sub description { shift->{description} }
sub context { @{ shift->{context} || [] } }
=head3 C<as_array_ref>
For backwards compatibility in callbacks.
=cut
sub as_array_ref {
my $self = shift;
return [ $self->filename, $self->description, $self->{context} ||= [] ];
}
=head3 C<is_spinner>
$self->is_spinner;
Returns false indicating that this is a real job rather than a
'spinner'. Spinners are returned when the scheduler still has pending
jobs but can't (because of locking) return one right now.
=cut
sub is_spinner {0}
1;
PK �[* H$ $ Parser/Aggregator.pmnu �[��� package TAP::Parser::Aggregator;
use strict;
use warnings;
use Benchmark;
use base 'TAP::Object';
=head1 NAME
TAP::Parser::Aggregator - Aggregate TAP::Parser results
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Aggregator;
my $aggregate = TAP::Parser::Aggregator->new;
$aggregate->add( 't/00-load.t', $load_parser );
$aggregate->add( 't/10-lex.t', $lex_parser );
my $summary = <<'END_SUMMARY';
Passed: %s
Failed: %s
Unexpectedly succeeded: %s
END_SUMMARY
printf $summary,
scalar $aggregate->passed,
scalar $aggregate->failed,
scalar $aggregate->todo_passed;
=head1 DESCRIPTION
C<TAP::Parser::Aggregator> collects parser objects and allows
reporting/querying their aggregate results.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $aggregate = TAP::Parser::Aggregator->new;
Returns a new C<TAP::Parser::Aggregator> object.
=cut
# new() implementation supplied by TAP::Object
my %SUMMARY_METHOD_FOR;
BEGIN { # install summary methods
%SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
failed
parse_errors
passed
skipped
todo
todo_passed
total
wait
exit
);
$SUMMARY_METHOD_FOR{total} = 'tests_run';
$SUMMARY_METHOD_FOR{planned} = 'tests_planned';
for my $method ( keys %SUMMARY_METHOD_FOR ) {
next if 'total' eq $method;
no strict 'refs';
*$method = sub {
my $self = shift;
return wantarray
? @{ $self->{"descriptions_for_$method"} }
: $self->{$method};
};
}
} # end install summary methods
sub _initialize {
my ($self) = @_;
$self->{parser_for} = {};
$self->{parse_order} = [];
for my $summary ( keys %SUMMARY_METHOD_FOR ) {
$self->{$summary} = 0;
next if 'total' eq $summary;
$self->{"descriptions_for_$summary"} = [];
}
return $self;
}
##############################################################################
=head2 Instance Methods
=head3 C<add>
$aggregate->add( $description => $parser );
The C<$description> is usually a test file name (but only by
convention.) It is used as a unique identifier (see e.g.
L<"parsers">.) Reusing a description is a fatal error.
The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
=cut
sub add {
my ( $self, $description, $parser ) = @_;
if ( exists $self->{parser_for}{$description} ) {
$self->_croak( "You already have a parser for ($description)."
. " Perhaps you have run the same test twice." );
}
push @{ $self->{parse_order} } => $description;
$self->{parser_for}{$description} = $parser;
while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
# Slightly nasty. Instead we should maybe have 'cooked' accessors
# for results that may be masked by the parser.
next
if ( $method eq 'exit' || $method eq 'wait' )
&& $parser->ignore_exit;
if ( my $count = $parser->$method() ) {
$self->{$summary} += $count;
push @{ $self->{"descriptions_for_$summary"} } => $description;
}
}
return $self;
}
##############################################################################
=head3 C<parsers>
my $count = $aggregate->parsers;
my @parsers = $aggregate->parsers;
my @parsers = $aggregate->parsers(@descriptions);
In scalar context without arguments, this method returns the number of parsers
aggregated. In list context without arguments, returns the parsers in the
order they were added.
If C<@descriptions> is given, these correspond to the keys used in each
call to the add() method. Returns an array of the requested parsers (in
the requested order) in list context or an array reference in scalar
context.
Requesting an unknown identifier is a fatal error.
=cut
sub parsers {
my $self = shift;
return $self->_get_parsers(@_) if @_;
my $descriptions = $self->{parse_order};
my @parsers = @{ $self->{parser_for} }{@$descriptions};
# Note: Because of the way context works, we must assign the parsers to
# the @parsers array or else this method does not work as documented.
return @parsers;
}
sub _get_parsers {
my ( $self, @descriptions ) = @_;
my @parsers;
for my $description (@descriptions) {
$self->_croak("A parser for ($description) could not be found")
unless exists $self->{parser_for}{$description};
push @parsers => $self->{parser_for}{$description};
}
return wantarray ? @parsers : \@parsers;
}
=head3 C<descriptions>
Get an array of descriptions in the order in which they were added to
the aggregator.
=cut
sub descriptions { @{ shift->{parse_order} || [] } }
=head3 C<start>
Call C<start> immediately before adding any results to the aggregator.
Among other times it records the start time for the test run.
=cut
sub start {
my $self = shift;
$self->{start_time} = Benchmark->new;
}
=head3 C<stop>
Call C<stop> immediately after adding all test results to the aggregator.
=cut
sub stop {
my $self = shift;
$self->{end_time} = Benchmark->new;
}
=head3 C<elapsed>
Elapsed returns a L<Benchmark> object that represents the running time
of the aggregated tests. In order for C<elapsed> to be valid you must
call C<start> before running the tests and C<stop> immediately
afterwards.
=cut
sub elapsed {
my $self = shift;
require Carp;
Carp::croak
q{Can't call elapsed without first calling start and then stop}
unless defined $self->{start_time} && defined $self->{end_time};
return timediff( $self->{end_time}, $self->{start_time} );
}
=head3 C<elapsed_timestr>
Returns a formatted string representing the runtime returned by
C<elapsed()>. This lets the caller not worry about Benchmark.
=cut
sub elapsed_timestr {
my $self = shift;
my $elapsed = $self->elapsed;
return timestr($elapsed);
}
=head3 C<all_passed>
Return true if all the tests passed and no parse errors were detected.
=cut
sub all_passed {
my $self = shift;
return
$self->total
&& $self->total == $self->passed
&& !$self->has_errors;
}
=head3 C<get_status>
Get a single word describing the status of the aggregated tests.
Depending on the outcome of the tests returns 'PASS', 'FAIL' or
'NOTESTS'. This token is understood by L<CPAN::Reporter>.
=cut
sub get_status {
my $self = shift;
my $total = $self->total;
my $passed = $self->passed;
return
( $self->has_errors || $total != $passed ) ? 'FAIL'
: $total ? 'PASS'
: 'NOTESTS';
}
##############################################################################
=head2 Summary methods
Each of the following methods will return the total number of corresponding
tests if called in scalar context. If called in list context, returns the
descriptions of the parsers which contain the corresponding tests (see C<add>
for an explanation of description.
=over 4
=item * failed
=item * parse_errors
=item * passed
=item * planned
=item * skipped
=item * todo
=item * todo_passed
=item * wait
=item * exit
=back
For example, to find out how many tests unexpectedly succeeded (TODO tests
which passed when they shouldn't):
my $count = $aggregate->todo_passed;
my @descriptions = $aggregate->todo_passed;
Note that C<wait> and C<exit> are the totals of the wait and exit
statuses of each of the tests. These values are totalled only to provide
a true value if any of them are non-zero.
=cut
##############################################################################
=head3 C<total>
my $tests_run = $aggregate->total;
Returns the total number of tests run.
=cut
sub total { shift->{total} }
##############################################################################
=head3 C<has_problems>
if ( $parser->has_problems ) {
...
}
Identical to C<has_errors>, but also returns true if any TODO tests
unexpectedly succeeded. This is more akin to "warnings".
=cut
sub has_problems {
my $self = shift;
return $self->todo_passed
|| $self->has_errors;
}
##############################################################################
=head3 C<has_errors>
if ( $parser->has_errors ) {
...
}
Returns true if I<any> of the parsers failed. This includes:
=over 4
=item * Failed tests
=item * Parse errors
=item * Bad exit or wait status
=back
=cut
sub has_errors {
my $self = shift;
return
$self->failed
|| $self->parse_errors
|| $self->exit
|| $self->wait;
}
##############################################################################
=head3 C<todo_failed>
# deprecated in favor of 'todo_passed'. This method was horribly misnamed.
This was a badly misnamed method. It indicates which TODO tests unexpectedly
succeeded. Will now issue a warning and call C<todo_passed>.
=cut
sub todo_failed {
warn
'"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
goto &todo_passed;
}
=head1 See Also
L<TAP::Parser>
L<TAP::Harness>
=cut
1;
PK �[�=^2= 2= Parser/Grammar.pmnu �[��� package TAP::Parser::Grammar;
use strict;
use warnings;
use TAP::Parser::ResultFactory ();
use TAP::Parser::YAMLish::Reader ();
use base 'TAP::Object';
=head1 NAME
TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Grammar;
my $grammar = $self->make_grammar({
iterator => $tap_parser_iterator,
parser => $tap_parser,
version => 12,
});
my $result = $grammar->tokenize;
=head1 DESCRIPTION
C<TAP::Parser::Grammar> tokenizes lines from a L<TAP::Parser::Iterator> and
constructs L<TAP::Parser::Result> subclasses to represent the tokens.
Do not attempt to use this class directly. It won't make sense. It's mainly
here to ensure that we will be able to have pluggable grammars when TAP is
expanded at some future date (plus, this stuff was really cluttering the
parser).
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $grammar = TAP::Parser::Grammar->new({
iterator => $iterator,
parser => $parser,
version => $version,
});
Returns L<TAP::Parser> grammar object that will parse the TAP stream from the
specified iterator. Both C<iterator> and C<parser> are required arguments.
If C<version> is not set it defaults to C<12> (see L</set_version> for more
details).
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my ( $self, $args ) = @_;
$self->{iterator} = $args->{iterator}; # TODO: accessor
$self->{iterator} ||= $args->{stream}; # deprecated
$self->{parser} = $args->{parser}; # TODO: accessor
$self->set_version( $args->{version} || 12 );
return $self;
}
my %language_for;
{
# XXX the 'not' and 'ok' might be on separate lines in VMS ...
my $ok = qr/(?:not )?ok\b/;
my $num = qr/\d+/;
my %v12 = (
version => {
syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i,
handler => sub {
my ( $self, $line ) = @_;
my $version = $1;
return $self->_make_version_token( $line, $version, );
},
},
plan => {
syntax => qr/^1\.\.(\d+)\s*(.*)\z/,
handler => sub {
my ( $self, $line ) = @_;
my ( $tests_planned, $tail ) = ( $1, $2 );
my $explanation = undef;
my $skip = '';
if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
my @todo = split /\s+/, _trim($1);
return $self->_make_plan_token(
$line, $tests_planned, 'TODO',
'', \@todo
);
}
elsif ( 0 == $tests_planned ) {
$skip = 'SKIP';
# If we can't match # SKIP the directive should be undef.
($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i;
}
elsif ( $tail !~ /^\s*$/ ) {
return $self->_make_unknown_token($line);
}
$explanation = '' unless defined $explanation;
return $self->_make_plan_token(
$line, $tests_planned, $skip,
$explanation, []
);
},
},
# An optimization to handle the most common test lines without
# directives.
simple_test => {
syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
handler => sub {
my ( $self, $line ) = @_;
my ( $ok, $num, $desc ) = ( $1, $2, $3 );
return $self->_make_test_token(
$line, $ok, $num,
$desc
);
},
},
test => {
syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
handler => sub {
my ( $self, $line ) = @_;
my ( $ok, $num, $desc ) = ( $1, $2, $3 );
my ( $dir, $explanation ) = ( '', '' );
if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
\# \s* (SKIP|TODO) \b \s* (.*) $/ix
)
{
( $desc, $dir, $explanation ) = ( $1, $2, $3 );
}
return $self->_make_test_token(
$line, $ok, $num, $desc,
$dir, $explanation
);
},
},
comment => {
syntax => qr/^#(.*)/,
handler => sub {
my ( $self, $line ) = @_;
my $comment = $1;
return $self->_make_comment_token( $line, $comment );
},
},
bailout => {
syntax => qr/^\s*Bail out!\s*(.*)/,
handler => sub {
my ( $self, $line ) = @_;
my $explanation = $1;
return $self->_make_bailout_token(
$line,
$explanation
);
},
},
);
my %v13 = (
%v12,
plan => {
syntax => qr/^1\.\.(\d+)\s*(?:\s*#\s*SKIP\b(.*))?\z/i,
handler => sub {
my ( $self, $line ) = @_;
my ( $tests_planned, $explanation ) = ( $1, $2 );
my $skip
= ( 0 == $tests_planned || defined $explanation )
? 'SKIP'
: '';
$explanation = '' unless defined $explanation;
return $self->_make_plan_token(
$line, $tests_planned, $skip,
$explanation, []
);
},
},
yaml => {
syntax => qr/^ (\s+) (---.*) $/x,
handler => sub {
my ( $self, $line ) = @_;
my ( $pad, $marker ) = ( $1, $2 );
return $self->_make_yaml_token( $pad, $marker );
},
},
pragma => {
syntax =>
qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
handler => sub {
my ( $self, $line ) = @_;
my $pragmas = $1;
return $self->_make_pragma_token( $line, $pragmas );
},
},
);
%language_for = (
'12' => {
tokens => \%v12,
},
'13' => {
tokens => \%v13,
setup => sub {
shift->{iterator}->handle_unicode;
},
},
);
}
##############################################################################
=head2 Instance Methods
=head3 C<set_version>
$grammar->set_version(13);
Tell the grammar which TAP syntax version to support. The lowest
supported version is 12. Although 'TAP version' isn't valid version 12
syntax it is accepted so that higher version numbers may be parsed.
=cut
sub set_version {
my $self = shift;
my $version = shift;
if ( my $language = $language_for{$version} ) {
$self->{version} = $version;
$self->{tokens} = $language->{tokens};
if ( my $setup = $language->{setup} ) {
$self->$setup();
}
$self->_order_tokens;
}
else {
require Carp;
Carp::croak("Unsupported syntax version: $version");
}
}
# Optimization to put the most frequent tokens first.
sub _order_tokens {
my $self = shift;
my %copy = %{ $self->{tokens} };
my @ordered_tokens = grep {defined}
map { delete $copy{$_} } qw( simple_test test comment plan );
push @ordered_tokens, values %copy;
$self->{ordered_tokens} = \@ordered_tokens;
}
##############################################################################
=head3 C<tokenize>
my $token = $grammar->tokenize;
This method will return a L<TAP::Parser::Result> object representing the
current line of TAP.
=cut
sub tokenize {
my $self = shift;
my $line = $self->{iterator}->next;
unless ( defined $line ) {
delete $self->{parser}; # break circular ref
return;
}
my $token;
for my $token_data ( @{ $self->{ordered_tokens} } ) {
if ( $line =~ $token_data->{syntax} ) {
my $handler = $token_data->{handler};
$token = $self->$handler($line);
last;
}
}
$token = $self->_make_unknown_token($line) unless $token;
return $self->{parser}->make_result($token);
}
##############################################################################
=head3 C<token_types>
my @types = $grammar->token_types;
Returns the different types of tokens which this grammar can parse.
=cut
sub token_types {
my $self = shift;
return keys %{ $self->{tokens} };
}
##############################################################################
=head3 C<syntax_for>
my $syntax = $grammar->syntax_for($token_type);
Returns a pre-compiled regular expression which will match a chunk of TAP
corresponding to the token type. For example (not that you should really pay
attention to this, C<< $grammar->syntax_for('comment') >> will return
C<< qr/^#(.*)/ >>.
=cut
sub syntax_for {
my ( $self, $type ) = @_;
return $self->{tokens}->{$type}->{syntax};
}
##############################################################################
=head3 C<handler_for>
my $handler = $grammar->handler_for($token_type);
Returns a code reference which, when passed an appropriate line of TAP,
returns the lexed token corresponding to that line. As a result, the basic
TAP parsing loop looks similar to the following:
my @tokens;
my $grammar = TAP::Grammar->new;
LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
for my $type ( $grammar->token_types ) {
my $syntax = $grammar->syntax_for($type);
if ( $line =~ $syntax ) {
my $handler = $grammar->handler_for($type);
push @tokens => $grammar->$handler($line);
next LINE;
}
}
push @tokens => $grammar->_make_unknown_token($line);
}
=cut
sub handler_for {
my ( $self, $type ) = @_;
return $self->{tokens}->{$type}->{handler};
}
sub _make_version_token {
my ( $self, $line, $version ) = @_;
return {
type => 'version',
raw => $line,
version => $version,
};
}
sub _make_plan_token {
my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
if ( $directive eq 'SKIP'
&& 0 != $tests_planned
&& $self->{version} < 13 )
{
warn
"Specified SKIP directive in plan but more than 0 tests ($line)\n";
}
return {
type => 'plan',
raw => $line,
tests_planned => $tests_planned,
directive => $directive,
explanation => _trim($explanation),
todo_list => $todo,
};
}
sub _make_test_token {
my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
return {
ok => $ok,
# forcing this to be an integer (and not a string) reduces memory
# consumption. RT #84939
test_num => ( defined $num ? 0 + $num : undef ),
description => _trim($desc),
directive => ( defined $dir ? uc $dir : '' ),
explanation => _trim($explanation),
raw => $line,
type => 'test',
};
}
sub _make_unknown_token {
my ( $self, $line ) = @_;
return {
raw => $line,
type => 'unknown',
};
}
sub _make_comment_token {
my ( $self, $line, $comment ) = @_;
return {
type => 'comment',
raw => $line,
comment => _trim($comment)
};
}
sub _make_bailout_token {
my ( $self, $line, $explanation ) = @_;
return {
type => 'bailout',
raw => $line,
bailout => _trim($explanation)
};
}
sub _make_yaml_token {
my ( $self, $pad, $marker ) = @_;
my $yaml = TAP::Parser::YAMLish::Reader->new;
my $iterator = $self->{iterator};
# 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 = $iterator->next;
return $2 if $line =~ $strip;
return;
};
my $data = $yaml->read($reader);
# Reconstitute input. This is convoluted. Maybe we should just
# record it on the way in...
chomp( my $raw = $yaml->get_raw );
$raw =~ s/^/$pad/mg;
return {
type => 'yaml',
raw => $raw,
data => $data
};
}
sub _make_pragma_token {
my ( $self, $line, $pragmas ) = @_;
return {
type => 'pragma',
raw => $line,
pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
};
}
sub _trim {
my $data = shift;
return '' unless defined $data;
$data =~ s/^\s+//;
$data =~ s/\s+$//;
return $data;
}
1;
=head1 TAP GRAMMAR
B<NOTE:> This grammar is slightly out of date. There's still some discussion
about it and a new one will be provided when we have things better defined.
The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
stream-based protocol. In fact, it's quite legal to have an infinite stream.
For the same reason that we don't apply regexes to streams, we're not using a
formal grammar here. Instead, we parse the TAP in lines.
For purposes for forward compatibility, any result which does not match the
following grammar is currently referred to as
L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
A formal grammar would look similar to the following:
(*
For the time being, I'm cheating on the EBNF by allowing
certain terms to be defined by POSIX character classes by
using the following syntax:
digit ::= [:digit:]
As far as I am aware, that's not valid EBNF. Sue me. I
didn't know how to write "char" otherwise (Unicode issues).
Suggestions welcome.
*)
tap ::= version? { comment | unknown } leading_plan lines
|
lines trailing_plan {comment}
version ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
leading_plan ::= plan skip_directive? "\n"
trailing_plan ::= plan "\n"
plan ::= '1..' nonNegativeInteger
lines ::= line {line}
line ::= (comment | test | unknown | bailout ) "\n"
test ::= status positiveInteger? description? directive?
status ::= 'not '? 'ok '
description ::= (character - (digit | '#')) {character - '#'}
directive ::= todo_directive | skip_directive
todo_directive ::= hash_mark 'TODO' ' ' {character}
skip_directive ::= hash_mark 'SKIP' ' ' {character}
comment ::= hash_mark {character}
hash_mark ::= '#' {' '}
bailout ::= 'Bail out!' {character}
unknown ::= { (character - "\n") }
(* POSIX character classes and other terminals *)
digit ::= [:digit:]
character ::= ([:print:] - "\n")
positiveInteger ::= ( digit - '0' ) {digit}
nonNegativeInteger ::= digit {digit}
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
do is read through the code. There's no easy way of summarizing it here.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
L<TAP::Parser::Result>,
=cut
PK �[!���� � Parser/ResultFactory.pmnu �[��� package TAP::Parser::ResultFactory;
use strict;
use warnings;
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 ();
use base 'TAP::Object';
##############################################################################
=head1 NAME
TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
=head1 SYNOPSIS
use TAP::Parser::ResultFactory;
my $token = {...};
my $factory = TAP::Parser::ResultFactory->new;
my $result = $factory->make_result( $token );
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head2 DESCRIPTION
This is a simple factory class which returns a L<TAP::Parser::Result> subclass
representing the current bit of test data from TAP (usually a single line).
It is used primarily by L<TAP::Parser::Grammar>. Unless you're subclassing,
you probably won't need to use this module directly.
=head2 METHODS
=head2 Class Methods
=head3 C<new>
Creates a new factory class.
I<Note:> You currently don't need to instantiate a factory in order to use it.
=head3 C<make_result>
Returns an instance the appropriate class for the test token passed in.
my $result = TAP::Parser::ResultFactory->make_result($token);
Can also be called as an instance method.
=cut
sub make_result {
my ( $proto, $token ) = @_;
my $type = $token->{type};
return $proto->class_for($type)->new($token);
}
=head3 C<class_for>
Takes one argument: C<$type>. Returns the class for this $type, or C<croak>s
with an error.
=head3 C<register_type>
Takes two arguments: C<$type>, C<$class>
This lets you override an existing type with your own custom type, or register
a completely new type, eg:
# create a custom result type:
package MyResult;
use strict;
use base 'TAP::Parser::Result';
# register with the factory:
TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
# use it:
my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
Your custom type should then be picked up automatically by the L<TAP::Parser>.
=cut
our %CLASS_FOR = (
plan => 'TAP::Parser::Result::Plan',
pragma => 'TAP::Parser::Result::Pragma',
test => 'TAP::Parser::Result::Test',
comment => 'TAP::Parser::Result::Comment',
bailout => 'TAP::Parser::Result::Bailout',
version => 'TAP::Parser::Result::Version',
unknown => 'TAP::Parser::Result::Unknown',
yaml => 'TAP::Parser::Result::YAML',
);
sub class_for {
my ( $class, $type ) = @_;
# return target class:
return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
# or complain:
require Carp;
Carp::croak("Could not determine class for result type '$type'");
}
sub register_type {
my ( $class, $type, $rclass ) = @_;
# register it blindly, assume they know what they're doing
$CLASS_FOR{$type} = $rclass;
return $class;
}
1;
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
There are a few things to bear in mind when creating your own
C<ResultFactory>:
=over 4
=item 1
The factory itself is never instantiated (this I<may> change in the future).
This means that C<_initialize> is never called.
=item 2
C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
This I<will> change in a future version!
=item 3
L<TAP::Parser::Result> subclasses will register themselves with
L<TAP::Parser::ResultFactory> directly:
package MyFooResult;
TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
Of course, it's up to you to decide whether or not to ignore them.
=back
=head2 Example
package MyResultFactory;
use strict;
use MyResult;
use base 'TAP::Parser::ResultFactory';
# force all results to be 'MyResult'
sub class_for {
return 'MyResult';
}
1;
=head1 SEE ALSO
L<TAP::Parser>,
L<TAP::Parser::Result>,
L<TAP::Parser::Grammar>
=cut
PK �[i��O% O% Parser/Source.pmnu �[��� package TAP::Parser::Source;
use strict;
use warnings;
use File::Basename qw( fileparse );
use base 'TAP::Object';
use constant BLK_SIZE => 512;
=head1 NAME
TAP::Parser::Source - a TAP source & meta data about it
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Source;
my $source = TAP::Parser::Source->new;
$source->raw( \'reference to raw TAP source' )
->config( \%config )
->merge( $boolean )
->switches( \@switches )
->test_args( \@args )
->assemble_meta;
do { ... } if $source->meta->{is_file};
# see assemble_meta for a full list of data available
=head1 DESCRIPTION
A TAP I<source> is something that produces a stream of TAP for the parser to
consume, such as an executable file, a text file, an archive, an IO handle, a
database, etc. C<TAP::Parser::Source>s encapsulate these I<raw> sources, and
provide some useful meta data about them. They are used by
L<TAP::Parser::SourceHandler>s, which do whatever is required to produce &
capture a stream of TAP from the I<raw> source, and package it up in a
L<TAP::Parser::Iterator> for the parser to consume.
Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or
subclassing L<TAP::Parser>, you probably won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $source = TAP::Parser::Source->new;
Returns a new C<TAP::Parser::Source> object.
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my ($self) = @_;
$self->meta( {} );
$self->config( {} );
return $self;
}
##############################################################################
=head2 Instance Methods
=head3 C<raw>
my $raw = $source->raw;
$source->raw( $some_value );
Chaining getter/setter for the raw TAP source. This is a reference, as it may
contain large amounts of data (eg: raw TAP).
=head3 C<meta>
my $meta = $source->meta;
$source->meta({ %some_value });
Chaining getter/setter for meta data about the source. This defaults to an
empty hashref. See L</assemble_meta> for more info.
=head3 C<has_meta>
True if the source has meta data.
=head3 C<config>
my $config = $source->config;
$source->config({ %some_value });
Chaining getter/setter for the source's configuration, if any has been provided
by the user. How it's used is up to you. This defaults to an empty hashref.
See L</config_for> for more info.
=head3 C<merge>
my $merge = $source->merge;
$source->config( $bool );
Chaining getter/setter for the flag that dictates whether STDOUT and STDERR
should be merged (where appropriate). Defaults to undef.
=head3 C<switches>
my $switches = $source->switches;
$source->config([ @switches ]);
Chaining getter/setter for the list of command-line switches that should be
passed to the source (where appropriate). Defaults to undef.
=head3 C<test_args>
my $test_args = $source->test_args;
$source->config([ @test_args ]);
Chaining getter/setter for the list of command-line arguments that should be
passed to the source (where appropriate). Defaults to undef.
=cut
sub raw {
my $self = shift;
return $self->{raw} unless @_;
$self->{raw} = shift;
return $self;
}
sub meta {
my $self = shift;
return $self->{meta} unless @_;
$self->{meta} = shift;
return $self;
}
sub has_meta {
return scalar %{ shift->meta } ? 1 : 0;
}
sub config {
my $self = shift;
return $self->{config} unless @_;
$self->{config} = shift;
return $self;
}
sub merge {
my $self = shift;
return $self->{merge} unless @_;
$self->{merge} = shift;
return $self;
}
sub switches {
my $self = shift;
return $self->{switches} unless @_;
$self->{switches} = shift;
return $self;
}
sub test_args {
my $self = shift;
return $self->{test_args} unless @_;
$self->{test_args} = shift;
return $self;
}
=head3 C<assemble_meta>
my $meta = $source->assemble_meta;
Gathers meta data about the L</raw> source, stashes it in L</meta> and returns
it as a hashref. This is done so that the L<TAP::Parser::SourceHandler>s don't
have to repeat common checks. Currently this includes:
is_scalar => $bool,
is_hash => $bool,
is_array => $bool,
# for scalars:
length => $n
has_newlines => $bool
# only done if the scalar looks like a filename
is_file => $bool,
is_dir => $bool,
is_symlink => $bool,
file => {
# only done if the scalar looks like a filename
basename => $string, # including ext
dir => $string,
ext => $string,
lc_ext => $string,
# system checks
exists => $bool,
stat => [ ... ], # perldoc -f stat
empty => $bool,
size => $n,
text => $bool,
binary => $bool,
read => $bool,
write => $bool,
execute => $bool,
setuid => $bool,
setgid => $bool,
sticky => $bool,
is_file => $bool,
is_dir => $bool,
is_symlink => $bool,
# only done if the file's a symlink
lstat => [ ... ], # perldoc -f lstat
# only done if the file's a readable text file
shebang => $first_line,
}
# for arrays:
size => $n,
=cut
sub assemble_meta {
my ($self) = @_;
return $self->meta if $self->has_meta;
my $meta = $self->meta;
my $raw = $self->raw;
# rudimentary is object test - if it's blessed it'll
# inherit from UNIVERSAL
$meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0;
if ( $meta->{is_object} ) {
$meta->{class} = ref($raw);
}
else {
my $ref = lc( ref($raw) );
$meta->{"is_$ref"} = 1;
}
if ( $meta->{is_scalar} ) {
my $source = $$raw;
$meta->{length} = length($$raw);
$meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0;
# only do file checks if it looks like a filename
if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) {
my $file = {};
$file->{exists} = -e $source ? 1 : 0;
if ( $file->{exists} ) {
$meta->{file} = $file;
# avoid extra system calls (see `perldoc -f -X`)
$file->{stat} = [ stat(_) ];
$file->{empty} = -z _ ? 1 : 0;
$file->{size} = -s _;
$file->{text} = -T _ ? 1 : 0;
$file->{binary} = -B _ ? 1 : 0;
$file->{read} = -r _ ? 1 : 0;
$file->{write} = -w _ ? 1 : 0;
$file->{execute} = -x _ ? 1 : 0;
$file->{setuid} = -u _ ? 1 : 0;
$file->{setgid} = -g _ ? 1 : 0;
$file->{sticky} = -k _ ? 1 : 0;
$meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0;
$meta->{is_dir} = $file->{is_dir} = -d _ ? 1 : 0;
# symlink check requires another system call
$meta->{is_symlink} = $file->{is_symlink}
= -l $source ? 1 : 0;
if ( $file->{is_symlink} ) {
$file->{lstat} = [ lstat(_) ];
}
# put together some common info about the file
( $file->{basename}, $file->{dir}, $file->{ext} )
= map { defined $_ ? $_ : '' }
fileparse( $source, qr/\.[^.]*/ );
$file->{lc_ext} = lc( $file->{ext} );
$file->{basename} .= $file->{ext} if $file->{ext};
if ( !$file->{is_dir} && $file->{read} ) {
eval { $file->{shebang} = $self->shebang($$raw); };
if ( my $e = $@ ) {
warn $e;
}
}
}
}
}
elsif ( $meta->{is_array} ) {
$meta->{size} = $#$raw + 1;
}
elsif ( $meta->{is_hash} ) {
; # do nothing
}
return $meta;
}
=head3 C<shebang>
Get the shebang line for a script file.
my $shebang = TAP::Parser::Source->shebang( $some_script );
May be called as a class method
=cut
{
# Global shebang cache.
my %shebang_for;
sub _read_shebang {
my ( $class, $file ) = @_;
open my $fh, '<', $file or die "Can't read $file: $!\n";
# Might be a binary file - so read a fixed number of bytes.
my $got = read $fh, my ($buf), BLK_SIZE;
defined $got or die "I/O error: $!\n";
return $1 if $buf =~ /(.*)/;
return;
}
sub shebang {
my ( $class, $file ) = @_;
$shebang_for{$file} = $class->_read_shebang($file)
unless exists $shebang_for{$file};
return $shebang_for{$file};
}
}
=head3 C<config_for>
my $config = $source->config_for( $class );
Returns L</config> for the $class given. Class names may be fully qualified
or abbreviated, eg:
# these are equivalent
$source->config_for( 'Perl' );
$source->config_for( 'TAP::Parser::SourceHandler::Perl' );
If a fully qualified $class is given, its abbreviated version is checked first.
=cut
sub config_for {
my ( $self, $class ) = @_;
my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ );
my $config = $self->config->{$abbrv_class} || $self->config->{$class};
return $config;
}
1;
__END__
=head1 AUTHORS
Steve Purkis.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::IteratorFactory>,
L<TAP::Parser::SourceHandler>
=cut
PK �[ c5- - Parser/Scheduler.pmnu �[��� package TAP::Parser::Scheduler;
use strict;
use warnings;
use Carp;
use TAP::Parser::Scheduler::Job;
use TAP::Parser::Scheduler::Spinner;
=head1 NAME
TAP::Parser::Scheduler - Schedule tests during parallel testing
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Scheduler;
=head1 DESCRIPTION
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $sched = TAP::Parser::Scheduler->new(tests => \@tests);
my $sched = TAP::Parser::Scheduler->new(
tests => [ ['t/test_name.t','Test Description'], ... ],
rules => \%rules,
);
Given 'tests' and optional 'rules' as input, returns a new
C<TAP::Parser::Scheduler> object. Each member of C<@tests> should be either a
a test file name, or a two element arrayref, where the first element is a test
file name, and the second element is a test description. By default, we'll use
the test name as the description.
The optional C<rules> attribute provides direction on which tests should be run
in parallel and which should be run sequentially. If no rule data structure is
provided, a default data structure is used which makes every test eligible to
be run in parallel:
{ par => '**' },
The rules data structure is documented more in the next section.
=head2 Rules data structure
The "C<rules>" data structure is the the heart of the scheduler. It allows you
to express simple rules like "run all tests in sequence" or "run all tests in
parallel except these five tests.". However, the rules structure also supports
glob-style pattern matching and recursive definitions, so you can also express
arbitarily complicated patterns.
The rule must only have one top level key: either 'par' for "parallel" or 'seq'
for "sequence".
Values must be either strings with possible glob-style matching, or arrayrefs
of strings or hashrefs which follow this pattern recursively.
Every element in an arrayref directly below a 'par' key is eligible to be run
in parallel, while vavalues directly below a 'seq' key must be run in sequence.
=head3 Rules examples
Here are some examples:
# All tests be run in parallel (the default rule)
{ par => '**' },
# Run all tests in sequence, except those starting with "p"
{ par => 't/p*.t' },
# Run all tests in parallel, except those starting with "p"
{
seq => [
{ seq => 't/p*.t' },
{ par => '**' },
],
}
# Run some startup tests in sequence, then some parallel tests then some
# teardown tests in sequence.
{
seq => [
{ seq => 't/startup/*.t' },
{ par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
{ seq => 't/shutdown/*.t' },
],
},
=head3 Rules resolution
=over 4
=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
=item * "First match wins". The first rule that matches a test will be the one that applies.
=item * Any test which does not match a rule will be run in sequence at the end of the run.
=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
=item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
=back
=head3 Glob-style pattern matching for rules
We implement our own glob-style pattern matching. Here are the patterns it supports:
** is any number of characters, including /, within a pathname
* is zero or more characters within a filename/directory name
? is exactly one character within a filename/directory name
{foo,bar,baz} is any of foo, bar or baz.
\ is an escape character
=cut
sub new {
my $class = shift;
croak "Need a number of key, value pairs" if @_ % 2;
my %args = @_;
my $tests = delete $args{tests} || croak "Need a 'tests' argument";
my $rules = delete $args{rules} || { par => '**' };
croak "Unknown arg(s): ", join ', ', sort keys %args
if keys %args;
# Turn any simple names into a name, description pair. TODO: Maybe
# construct jobs here?
my $self = bless {}, $class;
$self->_set_rules( $rules, $tests );
return $self;
}
# Build the scheduler data structure.
#
# SCHEDULER-DATA ::= JOB
# || ARRAY OF ARRAY OF SCHEDULER-DATA
#
# The nested arrays are the key to scheduling. The outer array contains
# a list of things that may be executed in parallel. Whenever an
# eligible job is sought any element of the outer array that is ready to
# execute can be selected. The inner arrays represent sequential
# execution. They can only proceed when the first job is ready to run.
sub _set_rules {
my ( $self, $rules, $tests ) = @_;
# Convert all incoming tests to job objects.
# If no test description is provided use the file name as the description.
my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
my $schedule = $self->_rule_clause( $rules, \@tests );
# If any tests are left add them as a sequential block at the end of
# the run.
$schedule = [ [ $schedule, @tests ] ] if @tests;
$self->{schedule} = $schedule;
}
sub _rule_clause {
my ( $self, $rule, $tests ) = @_;
croak 'Rule clause must be a hash'
unless 'HASH' eq ref $rule;
my @type = keys %$rule;
croak 'Rule clause must have exactly one key'
unless @type == 1;
my %handlers = (
par => sub {
[ map { [$_] } @_ ];
},
seq => sub { [ [@_] ] },
);
my $handler = $handlers{ $type[0] }
|| croak 'Unknown scheduler type: ', $type[0];
my $val = $rule->{ $type[0] };
return $handler->(
map {
'HASH' eq ref $_
? $self->_rule_clause( $_, $tests )
: $self->_expand( $_, $tests )
} 'ARRAY' eq ref $val ? @$val : $val
);
}
sub _glob_to_regexp {
my ( $self, $glob ) = @_;
my $nesting;
my $pattern;
while (1) {
if ( $glob =~ /\G\*\*/gc ) {
# ** is any number of characters, including /, within a pathname
$pattern .= '.*?';
}
elsif ( $glob =~ /\G\*/gc ) {
# * is zero or more characters within a filename/directory name
$pattern .= '[^/]*';
}
elsif ( $glob =~ /\G\?/gc ) {
# ? is exactly one character within a filename/directory name
$pattern .= '[^/]';
}
elsif ( $glob =~ /\G\{/gc ) {
# {foo,bar,baz} is any of foo, bar or baz.
$pattern .= '(?:';
++$nesting;
}
elsif ( $nesting and $glob =~ /\G,/gc ) {
# , is only special inside {}
$pattern .= '|';
}
elsif ( $nesting and $glob =~ /\G\}/gc ) {
# } that matches { is special. But unbalanced } are not.
$pattern .= ')';
--$nesting;
}
elsif ( $glob =~ /\G(\\.)/gc ) {
# A quoted literal
$pattern .= $1;
}
elsif ( $glob =~ /\G([\},])/gc ) {
# Sometimes meta characters
$pattern .= '\\' . $1;
}
else {
# Eat everything that is not a meta character.
$glob =~ /\G([^{?*\\\},]*)/gc;
$pattern .= quotemeta $1;
}
return $pattern if pos $glob == length $glob;
}
}
sub _expand {
my ( $self, $name, $tests ) = @_;
my $pattern = $self->_glob_to_regexp($name);
$pattern = qr/^ $pattern $/x;
my @match = ();
for ( my $ti = 0; $ti < @$tests; $ti++ ) {
if ( $tests->[$ti]->filename =~ $pattern ) {
push @match, splice @$tests, $ti, 1;
$ti--;
}
}
return @match;
}
=head2 Instance Methods
=head3 C<get_all>
Get a list of all remaining tests.
=cut
sub get_all {
my $self = shift;
my @all = $self->_gather( $self->{schedule} );
$self->{count} = @all;
@all;
}
sub _gather {
my ( $self, $rule ) = @_;
return unless defined $rule;
return $rule unless 'ARRAY' eq ref $rule;
return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
}
=head3 C<get_job>
Return the next available job as L<TAP::Parser::Scheduler::Job> object or
C<undef> if none are available. Returns a L<TAP::Parser::Scheduler::Spinner> if
the scheduler still has pending jobs but none are available to run right now.
=cut
sub get_job {
my $self = shift;
$self->{count} ||= $self->get_all;
my @jobs = $self->_find_next_job( $self->{schedule} );
if (@jobs) {
--$self->{count};
return $jobs[0];
}
return TAP::Parser::Scheduler::Spinner->new
if $self->{count};
return;
}
sub _not_empty {
my $ar = shift;
return 1 unless 'ARRAY' eq ref $ar;
for (@$ar) {
return 1 if _not_empty($_);
}
return;
}
sub _is_empty { !_not_empty(@_) }
sub _find_next_job {
my ( $self, $rule ) = @_;
my @queue = ();
my $index = 0;
while ( $index < @$rule ) {
my $seq = $rule->[$index];
# Prune any exhausted items.
shift @$seq while @$seq && _is_empty( $seq->[0] );
if (@$seq) {
if ( defined $seq->[0] ) {
if ( 'ARRAY' eq ref $seq->[0] ) {
push @queue, $seq;
}
else {
my $job = splice @$seq, 0, 1, undef;
$job->on_finish( sub { shift @$seq } );
return $job;
}
}
++$index;
}
else {
# Remove the empty sub-array from the array
splice @$rule, $index, 1;
}
}
for my $seq (@queue) {
if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
return @jobs;
}
}
return;
}
=head3 C<as_string>
Return a human readable representation of the scheduling tree.
For example:
my @tests = (qw{
t/startup/foo.t
t/shutdown/foo.t
t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t
});
my $sched = TAP::Parser::Scheduler->new(
tests => \@tests,
rules => {
seq => [
{ seq => 't/startup/*.t' },
{ par => ['t/a/*.t','t/b/*.t','t/c/*.t'] },
{ seq => 't/shutdown/*.t' },
],
},
);
Produces:
par:
seq:
par:
seq:
par:
seq:
't/startup/foo.t'
par:
seq:
't/a/foo.t'
seq:
't/b/foo.t'
seq:
't/c/foo.t'
par:
seq:
't/shutdown/foo.t'
't/d/foo.t'
=cut
sub as_string {
my $self = shift;
return $self->_as_string( $self->{schedule} );
}
sub _as_string {
my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
my $pad = ' ' x 2;
my $indent = $pad x $depth;
if ( !defined $rule ) {
return "$indent(undef)\n";
}
elsif ( 'ARRAY' eq ref $rule ) {
return unless @$rule;
my $type = ( 'par', 'seq' )[ $depth % 2 ];
return join(
'', "$indent$type:\n",
map { $self->_as_string( $_, $depth + 1 ) } @$rule
);
}
else {
return "$indent'" . $rule->filename . "'\n";
}
}
1;
PK �[r��^� � Parser/Multiplexer.pmnu �[��� package TAP::Parser::Multiplexer;
use strict;
use warnings;
use IO::Select;
use base 'TAP::Object';
use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
use constant IS_VMS => $^O eq 'VMS';
use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
=head1 NAME
TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Multiplexer;
my $mux = TAP::Parser::Multiplexer->new;
$mux->add( $parser1, $stash1 );
$mux->add( $parser2, $stash2 );
while ( my ( $parser, $stash, $result ) = $mux->next ) {
# do stuff
}
=head1 DESCRIPTION
C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
Internally it calls select on the input file handles for those parsers
to wait for one or more of them to have input available.
See L<TAP::Harness> for an example of its use.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $mux = TAP::Parser::Multiplexer->new;
Returns a new C<TAP::Parser::Multiplexer> object.
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my $self = shift;
$self->{select} = IO::Select->new;
$self->{avid} = []; # Parsers that can't select
$self->{count} = 0;
return $self;
}
##############################################################################
=head2 Instance Methods
=head3 C<add>
$mux->add( $parser, $stash );
Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
reference that will be returned from C<next> along with the parser and
the next result.
=cut
sub add {
my ( $self, $parser, $stash ) = @_;
if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
my $sel = $self->{select};
# We have to turn handles into file numbers here because by
# the time we want to remove them from our IO::Select they
# will already have been closed by the iterator.
my @filenos = map { fileno $_ } @handles;
for my $h (@handles) {
$sel->add( [ $h, $parser, $stash, @filenos ] );
}
$self->{count}++;
}
else {
push @{ $self->{avid} }, [ $parser, $stash ];
}
}
=head3 C<parsers>
my $count = $mux->parsers;
Returns the number of parsers. Parsers are removed from the multiplexer
when their input is exhausted.
=cut
sub parsers {
my $self = shift;
return $self->{count} + scalar @{ $self->{avid} };
}
sub _iter {
my $self = shift;
my $sel = $self->{select};
my $avid = $self->{avid};
my @ready = ();
return sub {
# Drain all the non-selectable parsers first
if (@$avid) {
my ( $parser, $stash ) = @{ $avid->[0] };
my $result = $parser->next;
shift @$avid unless defined $result;
return ( $parser, $stash, $result );
}
unless (@ready) {
return unless $sel->count;
@ready = $sel->can_read;
}
my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
my $result = $parser->next;
unless ( defined $result ) {
$sel->remove(@handles);
$self->{count}--;
# Force another can_read - we may now have removed a handle
# thought to have been ready.
@ready = ();
}
return ( $parser, $stash, $result );
};
}
=head3 C<next>
Return a result from the next available parser. Returns a list
containing the parser from which the result came, the stash that
corresponds with that parser and the result.
my ( $parser, $stash, $result ) = $mux->next;
If C<$result> is undefined the corresponding parser has reached the end
of its input (and will automatically be removed from the multiplexer).
When all parsers are exhausted an empty list will be returned.
if ( my ( $parser, $stash, $result ) = $mux->next ) {
if ( ! defined $result ) {
# End of this parser
}
else {
# Process result
}
}
else {
# All parsers finished
}
=cut
sub next {
my $self = shift;
return ( $self->{_iter} ||= $self->_iter )->();
}
=head1 See Also
L<TAP::Parser>
L<TAP::Harness>
=cut
1;
PK �[I��ɳ � Parser/YAMLish/Reader.pmnu �[��� package TAP::Parser::YAMLish::Reader;
use strict;
use warnings;
use base 'TAP::Object';
our $VERSION = '3.42';
# TODO:
# Handle blessed object syntax
# Printable characters for escapes
my %UNESCAPES = (
z => "\x00", a => "\x07", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
# new() implementation supplied by TAP::Object
sub read {
my $self = shift;
my $obj = shift;
die "Must have a code reference to read input from"
unless ref $obj eq 'CODE';
$self->{reader} = $obj;
$self->{capture} = [];
# Prime the reader
$self->_next;
return unless $self->{next};
my $doc = $self->_read;
# The terminator is mandatory otherwise we'd consume a line from the
# iterator that doesn't belong to us. If we want to remove this
# restriction we'll have to implement look-ahead in the iterators.
# Which might not be a bad idea.
my $dots = $self->_peek;
die "Missing '...' at end of YAMLish"
unless defined $dots
and $dots =~ $IS_END_YAML;
delete $self->{reader};
delete $self->{next};
return $doc;
}
sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
sub _peek {
my $self = shift;
return $self->{next} unless wantarray;
my $line = $self->{next};
$line =~ /^ (\s*) (.*) $ /x;
return ( $2, length $1 );
}
sub _next {
my $self = shift;
die "_next called with no reader"
unless $self->{reader};
my $line = $self->{reader}->();
$self->{next} = $line;
push @{ $self->{capture} }, $line;
}
sub _read {
my $self = shift;
my $line = $self->_peek;
# Do we have a document header?
if ( $line =~ /^ --- (?: \s* (.+?)? \s* )? $/x ) {
$self->_next;
return $self->_read_scalar($1) if defined $1; # Inline?
my ( $next, $indent ) = $self->_peek;
if ( $next =~ /^ - /x ) {
return $self->_read_array($indent);
}
elsif ( $next =~ $IS_HASH_KEY ) {
return $self->_read_hash( $next, $indent );
}
elsif ( $next =~ $IS_END_YAML ) {
die "Premature end of YAMLish";
}
else {
die "Unsupported YAMLish syntax: '$next'";
}
}
else {
die "YAMLish document header not found";
}
}
# Parse a double quoted string
sub _read_qq {
my $self = shift;
my $str = shift;
unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
die "Internal: not a quoted string";
}
$str =~ s/\\"/"/gx;
$str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
/ (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
return $str;
}
# Parse a scalar string to the actual scalar
sub _read_scalar {
my $self = shift;
my $string = shift;
return undef if $string eq '~';
return {} if $string eq '{}';
return [] if $string eq '[]';
if ( $string eq '>' || $string eq '|' ) {
my ( $line, $indent ) = $self->_peek;
die "Multi-line scalar content missing" unless defined $line;
my @multiline = ($line);
while (1) {
$self->_next;
my ( $next, $ind ) = $self->_peek;
last if $ind < $indent;
my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
push @multiline, $pad . $next;
}
return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
}
if ( $string =~ /^ ' (.*) ' $/x ) {
( my $rv = $1 ) =~ s/''/'/g;
return $rv;
}
if ( $string =~ $IS_QQ_STRING ) {
return $self->_read_qq($string);
}
if ( $string =~ /^['"]/ ) {
# A quote with folding... we don't support that
die __PACKAGE__ . " does not support multi-line quoted scalars";
}
# Regular unquoted string
return $string;
}
sub _read_nested {
my $self = shift;
my ( $line, $indent ) = $self->_peek;
if ( $line =~ /^ -/x ) {
return $self->_read_array($indent);
}
elsif ( $line =~ $IS_HASH_KEY ) {
return $self->_read_hash( $line, $indent );
}
else {
die "Unsupported YAMLish syntax: '$line'";
}
}
# Parse an array
sub _read_array {
my ( $self, $limit ) = @_;
my $ar = [];
while (1) {
my ( $line, $indent ) = $self->_peek;
last
if $indent < $limit
|| !defined $line
|| $line =~ $IS_END_YAML;
if ( $indent > $limit ) {
die "Array line over-indented";
}
if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
$indent += length $1;
$line =~ s/-\s+//;
push @$ar, $self->_read_hash( $line, $indent );
}
elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
die "Unexpected start of YAMLish" if $line =~ /^---/;
$self->_next;
push @$ar, $self->_read_scalar($1);
}
elsif ( $line =~ /^ - \s* $/x ) {
$self->_next;
push @$ar, $self->_read_nested;
}
elsif ( $line =~ $IS_HASH_KEY ) {
$self->_next;
push @$ar, $self->_read_hash( $line, $indent, );
}
else {
die "Unsupported YAMLish syntax: '$line'";
}
}
return $ar;
}
sub _read_hash {
my ( $self, $line, $limit ) = @_;
my $indent;
my $hash = {};
while (1) {
die "Badly formed hash line: '$line'"
unless $line =~ $HASH_LINE;
my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
$self->_next;
if ( defined $value ) {
$hash->{$key} = $self->_read_scalar($value);
}
else {
$hash->{$key} = $self->_read_nested;
}
( $line, $indent ) = $self->_peek;
last
if $indent < $limit
|| !defined $line
|| $line =~ $IS_END_YAML;
}
return $hash;
}
1;
__END__
=pod
=head1 NAME
TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
=head1 VERSION
Version 3.42
=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($iterator);
Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
represents.
=head3 C<get_raw>
my $source = $reader->get_source;
Return the raw YAMLish source from the most recent C<read>.
=head1 AUTHOR
Andy Armstrong, <andy@hexten.net>
Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
the YAML matching regular expressions for this module.
=head1 SEE ALSO
L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
L<http://use.perl.org/~Alias/journal/29427>
=head1 COPYRIGHT
Copyright 2007-2011 Andy Armstrong.
Portions copyright 2006-2008 Adam Kennedy.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut
PK �[�J��s s Parser/YAMLish/Writer.pmnu �[��� package TAP::Parser::YAMLish::Writer;
use strict;
use warnings;
use base 'TAP::Object';
our $VERSION = '3.42';
my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
my @UNPRINTABLE = qw(
z x01 x02 x03 x04 x05 x06 a
x08 t n v f r x0e x0f
x10 x11 x12 x13 x14 x15 x16 x17
x18 x19 x1a e x1c x1d x1e x1f
);
# new() implementation supplied by TAP::Object
sub write {
my $self = shift;
die "Need something to write"
unless @_;
my $obj = shift;
my $out = shift || \*STDOUT;
die "Need a reference to something I can write to"
unless ref $out;
$self->{writer} = $self->_make_writer($out);
$self->_write_obj( '---', $obj );
$self->_put('...');
delete $self->{writer};
}
sub _make_writer {
my $self = shift;
my $out = shift;
my $ref = ref $out;
if ( 'CODE' eq $ref ) {
return $out;
}
elsif ( 'ARRAY' eq $ref ) {
return sub { push @$out, shift };
}
elsif ( 'SCALAR' eq $ref ) {
return sub { $$out .= shift() . "\n" };
}
elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
return sub { print $out shift(), "\n" };
}
die "Can't write to $out";
}
sub _put {
my $self = shift;
$self->{writer}->( join '', @_ );
}
sub _enc_scalar {
my $self = shift;
my $val = shift;
my $rule = shift;
return '~' unless defined $val;
if ( $val =~ /$rule/ ) {
$val =~ s/\\/\\\\/g;
$val =~ s/"/\\"/g;
$val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
return qq{"$val"};
}
if ( length($val) == 0 or $val =~ /\s/ ) {
$val =~ s/'/''/;
return "'$val'";
}
return $val;
}
sub _write_obj {
my $self = shift;
my $prefix = shift;
my $obj = shift;
my $indent = shift || 0;
if ( my $ref = ref $obj ) {
my $pad = ' ' x $indent;
if ( 'HASH' eq $ref ) {
if ( keys %$obj ) {
$self->_put($prefix);
for my $key ( sort keys %$obj ) {
my $value = $obj->{$key};
$self->_write_obj(
$pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
$value, $indent + 1
);
}
}
else {
$self->_put( $prefix, ' {}' );
}
}
elsif ( 'ARRAY' eq $ref ) {
if (@$obj) {
$self->_put($prefix);
for my $value (@$obj) {
$self->_write_obj(
$pad . '-', $value,
$indent + 1
);
}
}
else {
$self->_put( $prefix, ' []' );
}
}
else {
die "Don't know how to encode $ref";
}
}
else {
$self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
}
}
1;
__END__
=pod
=head1 NAME
TAP::Parser::YAMLish::Writer - Write YAMLish data
=head1 VERSION
Version 3.42
=head1 SYNOPSIS
use TAP::Parser::YAMLish::Writer;
my $data = {
one => 1,
two => 2,
three => [ 1, 2, 3 ],
};
my $yw = TAP::Parser::YAMLish::Writer->new;
# Write to an array...
$yw->write( $data, \@some_array );
# ...an open file handle...
$yw->write( $data, $some_file_handle );
# ...a string ...
$yw->write( $data, \$some_string );
# ...or a closure
$yw->write( $data, sub {
my $line = shift;
print "$line\n";
} );
=head1 DESCRIPTION
Encodes a scalar, hash reference or array reference as YAMLish.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $writer = TAP::Parser::YAMLish::Writer->new;
The constructor C<new> creates and returns an empty
C<TAP::Parser::YAMLish::Writer> object.
=head2 Instance Methods
=head3 C<write>
$writer->write($obj, $output );
Encode a scalar, hash reference or array reference as YAML.
my $writer = sub {
my $line = shift;
print SOMEFILE "$line\n";
};
my $data = {
one => 1,
two => 2,
three => [ 1, 2, 3 ],
};
my $yw = TAP::Parser::YAMLish::Writer->new;
$yw->write( $data, $writer );
The C< $output > argument may be:
=over
=item * a reference to a scalar to append YAML to
=item * the handle of an open file
=item * a reference to an array into which YAML will be pushed
=item * a code reference
=back
If you supply a code reference the subroutine will be called once for
each line of output with the line as its only argument. Passed lines
will have no trailing newline.
=head1 AUTHOR
Andy Armstrong, <andy@hexten.net>
=head1 SEE ALSO
L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
L<http://use.perl.org/~Alias/journal/29427>
=head1 COPYRIGHT
Copyright 2007-2011 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
PK �[�V<L Parser/Result.pmnu �[��� package TAP::Parser::Result;
use strict;
use warnings;
use base 'TAP::Object';
BEGIN {
# make is_* methods
my @attrs = qw( plan pragma test comment bailout version unknown yaml );
no strict 'refs';
for my $token (@attrs) {
my $method = "is_$token";
*$method = sub { return $token eq shift->type };
}
}
##############################################################################
=head1 NAME
TAP::Parser::Result - Base class for TAP::Parser output objects
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
# abstract class - not meant to be used directly
# see TAP::Parser::ResultFactory for preferred usage
# directly:
use TAP::Parser::Result;
my $token = {...};
my $result = TAP::Parser::Result->new( $token );
=head2 DESCRIPTION
This is a simple base class used by L<TAP::Parser> to store objects that
represent the current bit of test output data from TAP (usually a single
line). Unless you're subclassing, you probably won't need to use this module
directly.
=head2 METHODS
=head3 C<new>
# see TAP::Parser::ResultFactory for preferred usage
# to use directly:
my $result = TAP::Parser::Result->new($token);
Returns an instance the appropriate class for the test token passed in.
=cut
# new() implementation provided by TAP::Object
sub _initialize {
my ( $self, $token ) = @_;
if ($token) {
# assign to a hash slice to make a shallow copy of the token.
# I guess we could assign to the hash as (by default) there are not
# contents, but that seems less helpful if someone wants to subclass us
@{$self}{ keys %$token } = values %$token;
}
return $self;
}
##############################################################################
=head2 Boolean methods
The following methods all return a boolean value and are to be overridden in
the appropriate subclass.
=over 4
=item * C<is_plan>
Indicates whether or not this is the test plan line.
1..3
=item * C<is_pragma>
Indicates whether or not this is a pragma line.
pragma +strict
=item * C<is_test>
Indicates whether or not this is a test line.
ok 1 Is OK!
=item * C<is_comment>
Indicates whether or not this is a comment.
# this is a comment
=item * C<is_bailout>
Indicates whether or not this is bailout line.
Bail out! We're out of dilithium crystals.
=item * C<is_version>
Indicates whether or not this is a TAP version line.
TAP version 4
=item * C<is_unknown>
Indicates whether or not the current line could be parsed.
... this line is junk ...
=item * C<is_yaml>
Indicates whether or not this is a YAML chunk.
=back
=cut
##############################################################################
=head3 C<raw>
print $result->raw;
Returns the original line of text which was parsed.
=cut
sub raw { shift->{raw} }
##############################################################################
=head3 C<type>
my $type = $result->type;
Returns the "type" of a token, such as C<comment> or C<test>.
=cut
sub type { shift->{type} }
##############################################################################
=head3 C<as_string>
print $result->as_string;
Prints a string representation of the token. This might not be the exact
output, however. Tests will have test numbers added if not present, TODO and
SKIP directives will be capitalized and, in general, things will be cleaned
up. If you need the original text for the token, see the C<raw> method.
=cut
sub as_string { shift->{raw} }
##############################################################################
=head3 C<is_ok>
if ( $result->is_ok ) { ... }
Reports whether or not a given result has passed. Anything which is B<not> a
test result returns true. This is merely provided as a convenient shortcut.
=cut
sub is_ok {1}
##############################################################################
=head3 C<passed>
Deprecated. Please use C<is_ok> instead.
=cut
sub passed {
warn 'passed() is deprecated. Please use "is_ok()"';
shift->is_ok;
}
##############################################################################
=head3 C<has_directive>
if ( $result->has_directive ) {
...
}
Indicates whether or not the given result has a TODO or SKIP directive.
=cut
sub has_directive {
my $self = shift;
return ( $self->has_todo || $self->has_skip );
}
##############################################################################
=head3 C<has_todo>
if ( $result->has_todo ) {
...
}
Indicates whether or not the given result has a TODO directive.
=cut
sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
##############################################################################
=head3 C<has_skip>
if ( $result->has_skip ) {
...
}
Indicates whether or not the given result has a SKIP directive.
=cut
sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
=head3 C<set_directive>
Set the directive associated with this token. Used internally to fake
TODO tests.
=cut
sub set_directive {
my ( $self, $dir ) = @_;
$self->{directive} = $dir;
}
1;
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
Remember: if you want your subclass to be automatically used by the parser,
you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
If you're creating a completely new result I<type>, you'll probably need to
subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
=head2 Example
package MyResult;
use strict;
use base 'TAP::Parser::Result';
# register with the factory:
TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
sub as_string { 'My results all look the same' }
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::ResultFactory>,
L<TAP::Parser::Result::Bailout>,
L<TAP::Parser::Result::Comment>,
L<TAP::Parser::Result::Plan>,
L<TAP::Parser::Result::Pragma>,
L<TAP::Parser::Result::Test>,
L<TAP::Parser::Result::Unknown>,
L<TAP::Parser::Result::Version>,
L<TAP::Parser::Result::YAML>,
=cut
PK �[�yo^� � Parser/Iterator/Stream.pmnu �[��� package TAP::Parser::Iterator::Stream;
use strict;
use warnings;
use base 'TAP::Parser::Iterator';
=head1 NAME
TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Iterator::Stream;
open( TEST, 'test.tap' );
my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
my $line = $it->next;
=head1 DESCRIPTION
This is a simple iterator wrapper for reading from filehandles, used by
L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Create an iterator. Expects one argument containing a filehandle.
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my ( $self, $thing ) = @_;
$self->{fh} = $thing;
return $self;
}
=head2 Instance Methods
=head3 C<next>
Iterate through it, of course.
=head3 C<next_raw>
Iterate raw input without applying any fixes for quirky input syntax.
=head3 C<wait>
Get the wait status for this iterator. Always returns zero.
=head3 C<exit>
Get the exit status for this iterator. Always returns zero.
=cut
sub wait { shift->exit }
sub exit { shift->{fh} ? () : 0 }
sub next_raw {
my $self = shift;
my $fh = $self->{fh};
if ( defined( my $line = <$fh> ) ) {
chomp $line;
return $line;
}
else {
$self->_finish;
return;
}
}
sub _finish {
my $self = shift;
close delete $self->{fh};
}
sub get_select_handles {
my $self = shift;
# return our handle in case it's a socket or pipe (select()-able)
return ( $self->{fh}, )
if (-S $self->{fh} || -p $self->{fh});
return;
}
1;
=head1 ATTRIBUTION
Originally ripped off from L<Test::Harness>.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
=cut
PK �[�"i� � Parser/Iterator/Array.pmnu �[��� package TAP::Parser::Iterator::Array;
use strict;
use warnings;
use base 'TAP::Parser::Iterator';
=head1 NAME
TAP::Parser::Iterator::Array - Iterator for array-based TAP sources
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Iterator::Array;
my @data = ('foo', 'bar', baz');
my $it = TAP::Parser::Iterator::Array->new(\@data);
my $line = $it->next;
=head1 DESCRIPTION
This is a simple iterator wrapper for arrays of scalar content, used by
L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Create an iterator. Takes one argument: an C<$array_ref>
=head2 Instance Methods
=head3 C<next>
Iterate through it, of course.
=head3 C<next_raw>
Iterate raw input without applying any fixes for quirky input syntax.
=head3 C<wait>
Get the wait status for this iterator. For an array iterator this will always
be zero.
=head3 C<exit>
Get the exit status for this iterator. For an array iterator this will always
be zero.
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my ( $self, $thing ) = @_;
chomp @$thing;
$self->{idx} = 0;
$self->{array} = $thing;
$self->{exit} = undef;
return $self;
}
sub wait { shift->exit }
sub exit {
my $self = shift;
return 0 if $self->{idx} >= @{ $self->{array} };
return;
}
sub next_raw {
my $self = shift;
return $self->{array}->[ $self->{idx}++ ];
}
1;
=head1 ATTRIBUTION
Originally ripped off from L<Test::Harness>.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
=cut
PK �[ ��# �# Parser/Iterator/Process.pmnu �[��� package TAP::Parser::Iterator::Process;
use strict;
use warnings;
use Config;
use IO::Handle;
use base 'TAP::Parser::Iterator';
my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
=head1 NAME
TAP::Parser::Iterator::Process - Iterator for process-based TAP sources
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Iterator::Process;
my %args = (
command => ['python', 'setup.py', 'test'],
merge => 1,
setup => sub { ... },
teardown => sub { ... },
);
my $it = TAP::Parser::Iterator::Process->new(\%args);
my $line = $it->next;
=head1 DESCRIPTION
This is a simple iterator wrapper for executing external processes, used by
L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Create an iterator. Expects one argument containing a hashref of the form:
command => \@command_to_execute
merge => $attempt_merge_stderr_and_stdout?
setup => $callback_to_setup_command
teardown => $callback_to_teardown_command
Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
process if they are available. Falls back onto C<open()>.
=head2 Instance Methods
=head3 C<next>
Iterate through the process output, of course.
=head3 C<next_raw>
Iterate raw input without applying any fixes for quirky input syntax.
=head3 C<wait>
Get the wait status for this iterator's process.
=head3 C<exit>
Get the exit status for this iterator's process.
=cut
{
no warnings 'uninitialized';
# get around a catch22 in the test suite that causes failures on Win32:
local $SIG{__DIE__} = undef;
eval { require POSIX; &POSIX::WEXITSTATUS(0) };
if ($@) {
*_wait2exit = sub { $_[1] >> 8 };
}
else {
*_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
}
}
sub _use_open3 {
my $self = shift;
return unless $Config{d_fork} || $IS_WIN32;
for my $module (qw( IPC::Open3 IO::Select )) {
eval "use $module";
return if $@;
}
return 1;
}
{
my $got_unicode;
sub _get_unicode {
return $got_unicode if defined $got_unicode;
eval 'use Encode qw(decode_utf8);';
$got_unicode = $@ ? 0 : 1;
}
}
# new() implementation supplied by TAP::Object
sub _initialize {
my ( $self, $args ) = @_;
my @command = @{ delete $args->{command} || [] }
or die "Must supply a command to execute";
$self->{command} = [@command];
# Private. Used to frig with chunk size during testing.
my $chunk_size = delete $args->{_chunk_size} || 65536;
my $merge = delete $args->{merge};
my ( $pid, $err, $sel );
if ( my $setup = delete $args->{setup} ) {
$setup->(@command);
}
my $out = IO::Handle->new;
if ( $self->_use_open3 ) {
# HOTPATCH {{{
my $xclose = \&IPC::Open3::xclose;
no warnings;
local *IPC::Open3::xclose = sub {
my $fh = shift;
no strict 'refs';
return if ( fileno($fh) == fileno(STDIN) );
$xclose->($fh);
};
# }}}
if ($IS_WIN32) {
$err = $merge ? '' : '>&STDERR';
eval {
$pid = open3(
'<&STDIN', $out, $merge ? '' : $err,
@command
);
};
die "Could not execute (@command): $@" if $@;
if ( $] >= 5.006 ) {
binmode($out, ":crlf");
}
}
else {
$err = $merge ? '' : IO::Handle->new;
eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
die "Could not execute (@command): $@" if $@;
$sel = $merge ? undef : IO::Select->new( $out, $err );
}
}
else {
$err = '';
my $command
= join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
open( $out, "$command|" )
or die "Could not execute ($command): $!";
}
$self->{out} = $out;
$self->{err} = $err;
$self->{sel} = $sel;
$self->{pid} = $pid;
$self->{exit} = undef;
$self->{chunk_size} = $chunk_size;
if ( my $teardown = delete $args->{teardown} ) {
$self->{teardown} = sub {
$teardown->(@command);
};
}
return $self;
}
=head3 C<handle_unicode>
Upgrade the input stream to handle UTF8.
=cut
sub handle_unicode {
my $self = shift;
if ( $self->{sel} ) {
if ( _get_unicode() ) {
# Make sure our iterator has been constructed and...
my $next = $self->{_next} ||= $self->_next;
# ...wrap it to do UTF8 casting
$self->{_next} = sub {
my $line = $next->();
return decode_utf8($line) if defined $line;
return;
};
}
}
else {
if ( $] >= 5.008 ) {
eval 'binmode($self->{out}, ":utf8")';
}
}
}
##############################################################################
sub wait { shift->{wait} }
sub exit { shift->{exit} }
sub _next {
my $self = shift;
if ( my $out = $self->{out} ) {
if ( my $sel = $self->{sel} ) {
my $err = $self->{err};
my @buf = ();
my $partial = ''; # Partial line
my $chunk_size = $self->{chunk_size};
return sub {
return shift @buf if @buf;
READ:
while ( my @ready = $sel->can_read ) {
for my $fh (@ready) {
my $got = sysread $fh, my ($chunk), $chunk_size;
if ( $got == 0 ) {
$sel->remove($fh);
}
elsif ( $fh == $err ) {
print STDERR $chunk; # echo STDERR
}
else {
$chunk = $partial . $chunk;
$partial = '';
# Make sure we have a complete line
unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
my $nl = rindex $chunk, "\n";
if ( $nl == -1 ) {
$partial = $chunk;
redo READ;
}
else {
$partial = substr( $chunk, $nl + 1 );
$chunk = substr( $chunk, 0, $nl );
}
}
push @buf, split /\n/, $chunk;
return shift @buf if @buf;
}
}
}
# Return partial last line
if ( length $partial ) {
my $last = $partial;
$partial = '';
return $last;
}
$self->_finish;
return;
};
}
else {
return sub {
if ( defined( my $line = <$out> ) ) {
chomp $line;
return $line;
}
$self->_finish;
return;
};
}
}
else {
return sub {
$self->_finish;
return;
};
}
}
sub next_raw {
my $self = shift;
return ( $self->{_next} ||= $self->_next )->();
}
sub _finish {
my $self = shift;
my $status = $?;
# Avoid circular refs
$self->{_next} = sub {return}
if $] >= 5.006;
# If we have a subprocess we need to wait for it to terminate
if ( defined $self->{pid} ) {
if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
$status = $?;
}
}
( delete $self->{out} )->close if $self->{out};
# If we have an IO::Select we also have an error handle to close.
if ( $self->{sel} ) {
( delete $self->{err} )->close;
delete $self->{sel};
}
else {
$status = $?;
}
# Sometimes we get -1 on Windows. Presumably that means status not
# available.
$status = 0 if $IS_WIN32 && $status == -1;
$self->{wait} = $status;
$self->{exit} = $self->_wait2exit($status);
if ( my $teardown = $self->{teardown} ) {
$teardown->();
}
return $self;
}
=head3 C<get_select_handles>
Return a list of filehandles that may be used upstream in a select()
call to signal that this Iterator is ready. Iterators that are not
handle based should return an empty list.
=cut
sub get_select_handles {
my $self = shift;
return grep $_, ( $self->{out}, $self->{err} );
}
1;
=head1 ATTRIBUTION
Originally ripped off from L<Test::Harness>.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
=cut
PK �[ � � Parser/Iterator.pmnu �[��� package TAP::Parser::Iterator;
use strict;
use warnings;
use base 'TAP::Object';
=head1 NAME
TAP::Parser::Iterator - Base class for TAP source iterators
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
# to subclass:
use TAP::Parser::Iterator ();
use base 'TAP::Parser::Iterator';
sub _initialize {
# see TAP::Object...
}
sub next_raw { ... }
sub wait { ... }
sub exit { ... }
=head1 DESCRIPTION
This is a simple iterator base class that defines L<TAP::Parser>'s iterator
API. Iterators are typically created from L<TAP::Parser::SourceHandler>s.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Create an iterator. Provided by L<TAP::Object>.
=head2 Instance Methods
=head3 C<next>
while ( my $item = $iter->next ) { ... }
Iterate through it, of course.
=head3 C<next_raw>
B<Note:> this method is abstract and should be overridden.
while ( my $item = $iter->next_raw ) { ... }
Iterate raw input without applying any fixes for quirky input syntax.
=cut
sub next {
my $self = shift;
my $line = $self->next_raw;
# vms nit: When encountering 'not ok', vms often has the 'not' on a line
# by itself:
# not
# ok 1 - 'I hate VMS'
if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
$line .= ( $self->next_raw || '' );
}
return $line;
}
sub next_raw {
require Carp;
my $msg = Carp::longmess('abstract method called directly!');
$_[0]->_croak($msg);
}
=head3 C<handle_unicode>
If necessary switch the input stream to handle unicode. This only has
any effect for I/O handle based streams.
The default implementation does nothing.
=cut
sub handle_unicode { }
=head3 C<get_select_handles>
Return a list of filehandles that may be used upstream in a select()
call to signal that this Iterator is ready. Iterators that are not
handle-based should return an empty list.
The default implementation does nothing.
=cut
sub get_select_handles {
return;
}
=head3 C<wait>
B<Note:> this method is abstract and should be overridden.
my $wait_status = $iter->wait;
Return the C<wait> status for this iterator.
=head3 C<exit>
B<Note:> this method is abstract and should be overridden.
my $wait_status = $iter->exit;
Return the C<exit> status for this iterator.
=cut
sub wait {
require Carp;
my $msg = Carp::longmess('abstract method called directly!');
$_[0]->_croak($msg);
}
sub exit {
require Carp;
my $msg = Carp::longmess('abstract method called directly!');
$_[0]->_croak($msg);
}
1;
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
You must override the abstract methods as noted above.
=head2 Example
L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
There's not much point repeating it here.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator::Array>,
L<TAP::Parser::Iterator::Stream>,
L<TAP::Parser::Iterator::Process>,
=cut
PK �[ '�� � Parser/SourceHandler/File.pmnu �[��� package TAP::Parser::SourceHandler::File;
use strict;
use warnings;
use TAP::Parser::IteratorFactory ();
use TAP::Parser::Iterator::Stream ();
use base 'TAP::Parser::SourceHandler';
TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
=head1 NAME
TAP::Parser::SourceHandler::File - Stream TAP from a text file.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Source;
use TAP::Parser::SourceHandler::File;
my $source = TAP::Parser::Source->new->raw( \'file.tap' );
$source->assemble_meta;
my $class = 'TAP::Parser::SourceHandler::File';
my $vote = $class->can_handle( $source );
my $iter = $class->make_iterator( $source );
=head1 DESCRIPTION
This is a I<raw TAP stored in a file> L<TAP::Parser::SourceHandler> - it has 2 jobs:
1. Figure out if the I<raw> source it's given is a file containing raw TAP
output. See L<TAP::Parser::IteratorFactory> for more details.
2. Takes raw TAP from the text file given, and converts into an iterator.
Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<can_handle>
my $vote = $class->can_handle( $source );
Only votes if $source looks like a regular file. Casts the following votes:
0.9 if it's a .tap file
0.9 if it has an extension matching any given in user config.
=cut
sub can_handle {
my ( $class, $src ) = @_;
my $meta = $src->meta;
my $config = $src->config_for($class);
return 0 unless $meta->{is_file};
my $file = $meta->{file};
return 0.9 if $file->{lc_ext} eq '.tap';
if ( my $exts = $config->{extensions} ) {
my @exts = ref $exts eq 'ARRAY' ? @$exts : $exts;
return 0.9 if grep { lc($_) eq $file->{lc_ext} } @exts;
}
return 0;
}
=head3 C<make_iterator>
my $iterator = $class->make_iterator( $source );
Returns a new L<TAP::Parser::Iterator::Stream> for the source. C<croak>s
on error.
=cut
sub make_iterator {
my ( $class, $source ) = @_;
$class->_croak('$source->raw must be a scalar ref')
unless $source->meta->{is_scalar};
my $file = ${ $source->raw };
my $fh;
open( $fh, '<', $file )
or $class->_croak("error opening TAP source file '$file': $!");
return $class->iterator_class->new($fh);
}
=head3 C<iterator_class>
The class of iterator to use, override if you're sub-classing. Defaults
to L<TAP::Parser::Iterator::Stream>.
=cut
use constant iterator_class => 'TAP::Parser::Iterator::Stream';
1;
__END__
=head1 CONFIGURATION
{
extensions => [ @case_insensitive_exts_to_match ]
}
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::SourceHandler>,
L<TAP::Parser::SourceHandler::Executable>,
L<TAP::Parser::SourceHandler::Perl>,
L<TAP::Parser::SourceHandler::Handle>,
L<TAP::Parser::SourceHandler::RawTAP>
=cut
PK �[KlJ[
[
Parser/SourceHandler/Handle.pmnu �[��� package TAP::Parser::SourceHandler::Handle;
use strict;
use warnings;
use TAP::Parser::IteratorFactory ();
use TAP::Parser::Iterator::Stream ();
use base 'TAP::Parser::SourceHandler';
TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
=head1 NAME
TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Source;
use TAP::Parser::SourceHandler::Executable;
my $source = TAP::Parser::Source->new->raw( \*TAP_FILE );
$source->assemble_meta;
my $class = 'TAP::Parser::SourceHandler::Handle';
my $vote = $class->can_handle( $source );
my $iter = $class->make_iterator( $source );
=head1 DESCRIPTION
This is a I<raw TAP stored in an IO Handle> L<TAP::Parser::SourceHandler> class. It
has 2 jobs:
1. Figure out if the L<TAP::Parser::Source> it's given is an L<IO::Handle> or
GLOB containing raw TAP output (L</can_handle>).
2. Creates an iterator for IO::Handle's & globs (L</make_iterator>).
Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<can_handle>
my $vote = $class->can_handle( $source );
Casts the following votes:
0.9 if $source is an IO::Handle
0.8 if $source is a glob
=cut
sub can_handle {
my ( $class, $src ) = @_;
my $meta = $src->meta;
return 0.9
if $meta->{is_object}
&& UNIVERSAL::isa( $src->raw, 'IO::Handle' );
return 0.8 if $meta->{is_glob};
return 0;
}
=head3 C<make_iterator>
my $iterator = $class->make_iterator( $source );
Returns a new L<TAP::Parser::Iterator::Stream> for the source.
=cut
sub make_iterator {
my ( $class, $source ) = @_;
$class->_croak('$source->raw must be a glob ref or an IO::Handle')
unless $source->meta->{is_glob}
|| UNIVERSAL::isa( $source->raw, 'IO::Handle' );
return $class->iterator_class->new( $source->raw );
}
=head3 C<iterator_class>
The class of iterator to use, override if you're sub-classing. Defaults
to L<TAP::Parser::Iterator::Stream>.
=cut
use constant iterator_class => 'TAP::Parser::Iterator::Stream';
1;
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
L<TAP::Parser::Iterator::Stream>,
L<TAP::Parser::IteratorFactory>,
L<TAP::Parser::SourceHandler>,
L<TAP::Parser::SourceHandler::Executable>,
L<TAP::Parser::SourceHandler::Perl>,
L<TAP::Parser::SourceHandler::File>,
L<TAP::Parser::SourceHandler::RawTAP>
=cut
PK �[�Y[ Parser/SourceHandler/RawTAP.pmnu �[��� package TAP::Parser::SourceHandler::RawTAP;
use strict;
use warnings;
use TAP::Parser::IteratorFactory ();
use TAP::Parser::Iterator::Array ();
use base 'TAP::Parser::SourceHandler';
TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
=head1 NAME
TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/array ref.
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Source;
use TAP::Parser::SourceHandler::RawTAP;
my $source = TAP::Parser::Source->new->raw( \"1..1\nok 1\n" );
$source->assemble_meta;
my $class = 'TAP::Parser::SourceHandler::RawTAP';
my $vote = $class->can_handle( $source );
my $iter = $class->make_iterator( $source );
=head1 DESCRIPTION
This is a I<raw TAP output> L<TAP::Parser::SourceHandler> - it has 2 jobs:
1. Figure out if the L<TAP::Parser::Source> it's given is raw TAP output
(L</can_handle>).
2. Creates an iterator for raw TAP output (L</make_iterator>).
Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<can_handle>
my $vote = $class->can_handle( $source );
Only votes if $source is an array, or a scalar with newlines. Casts the
following votes:
0.9 if it's a scalar with '..' in it
0.7 if it's a scalar with 'ok' in it
0.3 if it's just a scalar with newlines
0.5 if it's an array
=cut
sub can_handle {
my ( $class, $src ) = @_;
my $meta = $src->meta;
return 0 if $meta->{file};
if ( $meta->{is_scalar} ) {
return 0 unless $meta->{has_newlines};
return 0.9 if ${ $src->raw } =~ /\d\.\.\d/;
return 0.7 if ${ $src->raw } =~ /ok/;
return 0.3;
}
elsif ( $meta->{is_array} ) {
return 0.5;
}
return 0;
}
=head3 C<make_iterator>
my $iterator = $class->make_iterator( $source );
Returns a new L<TAP::Parser::Iterator::Array> for the source.
C<$source-E<gt>raw> must be an array ref, or a scalar ref.
C<croak>s on error.
=cut
sub make_iterator {
my ( $class, $src ) = @_;
my $meta = $src->meta;
my $tap_array;
if ( $meta->{is_scalar} ) {
$tap_array = [ split "\n" => ${ $src->raw } ];
}
elsif ( $meta->{is_array} ) {
$tap_array = $src->raw;
}
$class->_croak('No raw TAP found in $source->raw')
unless scalar $tap_array;
return TAP::Parser::Iterator::Array->new($tap_array);
}
1;
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::IteratorFactory>,
L<TAP::Parser::SourceHandler>,
L<TAP::Parser::SourceHandler::Executable>,
L<TAP::Parser::SourceHandler::Perl>,
L<TAP::Parser::SourceHandler::File>,
L<TAP::Parser::SourceHandler::Handle>
=cut
PK �[�M
v�$ �$ Parser/SourceHandler/Perl.pmnu �[��� package TAP::Parser::SourceHandler::Perl;
use strict;
use warnings;
use Config;
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_VMS => ( $^O eq 'VMS' );
use TAP::Parser::IteratorFactory ();
use TAP::Parser::Iterator::Process ();
use Text::ParseWords qw(shellwords);
use base 'TAP::Parser::SourceHandler::Executable';
TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
=head1 NAME
TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Source;
use TAP::Parser::SourceHandler::Perl;
my $source = TAP::Parser::Source->new->raw( \'script.pl' );
$source->assemble_meta;
my $class = 'TAP::Parser::SourceHandler::Perl';
my $vote = $class->can_handle( $source );
my $iter = $class->make_iterator( $source );
=head1 DESCRIPTION
This is a I<Perl> L<TAP::Parser::SourceHandler> - it has 2 jobs:
1. Figure out if the L<TAP::Parser::Source> it's given is actually a Perl
script (L</can_handle>).
2. Creates an iterator for Perl sources (L</make_iterator>).
Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<can_handle>
my $vote = $class->can_handle( $source );
Only votes if $source looks like a file. Casts the following votes:
0.9 if it has a shebang ala "#!...perl"
0.75 if it has any shebang
0.8 if it's a .t file
0.9 if it's a .pl file
0.75 if it's in a 't' directory
0.25 by default (backwards compat)
=cut
sub can_handle {
my ( $class, $source ) = @_;
my $meta = $source->meta;
return 0 unless $meta->{is_file};
my $file = $meta->{file};
if ( my $shebang = $file->{shebang} ) {
return 0.9 if $shebang =~ /^#!.*\bperl/;
# We favour Perl as the interpreter for any shebang to preserve
# previous semantics: we used to execute everything via Perl and
# relied on it to pass the shebang off to the appropriate
# interpreter.
return 0.3;
}
return 0.8 if $file->{lc_ext} eq '.t'; # vote higher than Executable
return 0.9 if $file->{lc_ext} eq '.pl';
return 0.75 if $file->{dir} =~ /^t\b/; # vote higher than Executable
# backwards compat, always vote:
return 0.25;
}
=head3 C<make_iterator>
my $iterator = $class->make_iterator( $source );
Constructs & returns a new L<TAP::Parser::Iterator::Process> for the source.
Assumes C<$source-E<gt>raw> contains a reference to the perl script. C<croak>s
if the file could not be found.
The command to run is built as follows:
$perl @switches $perl_script @test_args
The perl command to use is determined by L</get_perl>. The command generated
is guaranteed to preserve:
PERL5LIB
PERL5OPT
Taint Mode, if set in the script's shebang
I<Note:> the command generated will I<not> respect any shebang line defined in
your Perl script. This is only a problem if you have compiled a custom version
of Perl or if you want to use a specific version of Perl for one test and a
different version for another, for example:
#!/path/to/a/custom_perl --some --args
#!/usr/local/perl-5.6/bin/perl -w
Currently you need to write a plugin to get around this.
=cut
sub _autoflush_stdhandles {
my ($class) = @_;
$class->_autoflush( \*STDOUT );
$class->_autoflush( \*STDERR );
}
sub make_iterator {
my ( $class, $source ) = @_;
my $meta = $source->meta;
my $perl_script = ${ $source->raw };
$class->_croak("Cannot find ($perl_script)") unless $meta->{is_file};
# TODO: does this really need to be done here?
$class->_autoflush_stdhandles;
my ( $libs, $switches )
= $class->_mangle_switches(
$class->_filter_libs( $class->_switches($source) ) );
$class->_run( $source, $libs, $switches );
}
sub _has_taint_switch {
my( $class, $switches ) = @_;
my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches};
return $has_taint ? 1 : 0;
}
sub _mangle_switches {
my ( $class, $libs, $switches ) = @_;
# Taint mode ignores environment variables so we must retranslate
# PERL5LIB as -I switches and place PERL5OPT on the command line
# in order that it be seen.
if ( $class->_has_taint_switch($switches) ) {
my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : ();
return (
$libs,
[ @{$switches},
$class->_libs2switches([@$libs, @perl5lib]),
defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : ()
],
);
}
return ( $libs, $switches );
}
sub _filter_libs {
my ( $class, @switches ) = @_;
my $path_sep = $Config{path_sep};
my $path_re = qr{$path_sep};
# Filter out any -I switches to be handled as libs later.
#
# Nasty kludge. It might be nicer if we got the libs separately
# although at least this way we find any -I switches that were
# supplied other then as explicit libs.
#
# We filter out any names containing colons because they will break
# PERL5LIB
my @libs;
my @filtered_switches;
for (@switches) {
if ( !/$path_re/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
push @libs, $1;
}
else {
push @filtered_switches, $_;
}
}
return \@libs, \@filtered_switches;
}
sub _iterator_hooks {
my ( $class, $source, $libs, $switches ) = @_;
my $setup = sub {
if ( @{$libs} and !$class->_has_taint_switch($switches) ) {
$ENV{PERL5LIB} = join(
$Config{path_sep}, grep {defined} @{$libs},
$ENV{PERL5LIB}
);
}
};
# VMS environment variables aren't guaranteed to reset at the end of
# the process, so we need to put PERL5LIB back.
my $previous = $ENV{PERL5LIB};
my $teardown = sub {
if ( defined $previous ) {
$ENV{PERL5LIB} = $previous;
}
else {
delete $ENV{PERL5LIB};
}
};
return ( $setup, $teardown );
}
sub _run {
my ( $class, $source, $libs, $switches ) = @_;
my @command = $class->_get_command_for_switches( $source, $switches )
or $class->_croak("No command found!");
my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches );
return $class->_create_iterator( $source, \@command, $setup, $teardown );
}
sub _create_iterator {
my ( $class, $source, $command, $setup, $teardown ) = @_;
return TAP::Parser::Iterator::Process->new(
{ command => $command,
merge => $source->merge,
setup => $setup,
teardown => $teardown,
}
);
}
sub _get_command_for_switches {
my ( $class, $source, $switches ) = @_;
my $file = ${ $source->raw };
my @args = @{ $source->test_args || [] };
my $command = $class->get_perl;
# XXX don't need to quote if we treat the parts as atoms (except maybe vms)
#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
my @command = ( $command, @{$switches}, $file, @args );
return @command;
}
sub _libs2switches {
my $class = shift;
return map {"-I$_"} grep {$_} @{ $_[0] };
}
=head3 C<get_taint>
Decode any taint switches from a Perl shebang line.
# $taint will be 't'
my $taint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl -t' );
# $untaint will be undefined
my $untaint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl' );
=cut
sub get_taint {
my ( $class, $shebang ) = @_;
return
unless defined $shebang
&& $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
return $1;
}
sub _switches {
my ( $class, $source ) = @_;
my $file = ${ $source->raw };
my @switches = @{ $source->switches || [] };
my $shebang = $source->meta->{file}->{shebang};
return unless defined $shebang;
my $taint = $class->get_taint($shebang);
push @switches, "-$taint" if defined $taint;
# Quote the argument if we're VMS, since VMS will downcase anything
# not quoted.
if (IS_VMS) {
for (@switches) {
$_ = qq["$_"];
}
}
return @switches;
}
=head3 C<get_perl>
Gets the version of Perl currently running the test suite.
=cut
sub get_perl {
my $class = shift;
return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
return qq["$^X"] if IS_WIN32 && ( $^X =~ /[^\w\.\/\\]/ );
return $^X;
}
1;
__END__
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
=head2 Example
package MyPerlSourceHandler;
use strict;
use TAP::Parser::SourceHandler::Perl;
use base 'TAP::Parser::SourceHandler::Perl';
# use the version of perl from the shebang line in the test file
sub get_perl {
my $self = shift;
if (my $shebang = $self->shebang( $self->{file} )) {
$shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
return $1 if $1;
}
return $self->SUPER::get_perl(@_);
}
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::IteratorFactory>,
L<TAP::Parser::SourceHandler>,
L<TAP::Parser::SourceHandler::Executable>,
L<TAP::Parser::SourceHandler::File>,
L<TAP::Parser::SourceHandler::Handle>,
L<TAP::Parser::SourceHandler::RawTAP>
=cut
PK �[�Z�� � " Parser/SourceHandler/Executable.pmnu �[��� package TAP::Parser::SourceHandler::Executable;
use strict;
use warnings;
use TAP::Parser::IteratorFactory ();
use TAP::Parser::Iterator::Process ();
use base 'TAP::Parser::SourceHandler';
TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
=head1 NAME
TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP source
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::Source;
use TAP::Parser::SourceHandler::Executable;
my $source = TAP::Parser::Source->new->raw(['/usr/bin/ruby', 'mytest.rb']);
$source->assemble_meta;
my $class = 'TAP::Parser::SourceHandler::Executable';
my $vote = $class->can_handle( $source );
my $iter = $class->make_iterator( $source );
=head1 DESCRIPTION
This is an I<executable> L<TAP::Parser::SourceHandler> - it has 2 jobs:
1. Figure out if the L<TAP::Parser::Source> it's given is an executable
command (L</can_handle>).
2. Creates an iterator for executable commands (L</make_iterator>).
Unless you're writing a plugin or subclassing L<TAP::Parser>, you
probably won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<can_handle>
my $vote = $class->can_handle( $source );
Only votes if $source looks like an executable file. Casts the
following votes:
0.9 if it's a hash with an 'exec' key
0.8 if it's a .bat file
0.75 if it's got an execute bit set
=cut
sub can_handle {
my ( $class, $src ) = @_;
my $meta = $src->meta;
if ( $meta->{is_file} ) {
my $file = $meta->{file};
return 0.85 if $file->{execute} && $file->{binary};
return 0.8 if $file->{lc_ext} eq '.bat';
return 0.25 if $file->{execute};
}
elsif ( $meta->{is_hash} ) {
return 0.9 if $src->raw->{exec};
}
return 0;
}
=head3 C<make_iterator>
my $iterator = $class->make_iterator( $source );
Returns a new L<TAP::Parser::Iterator::Process> for the source.
C<$source-E<gt>raw> must be in one of the following forms:
{ exec => [ @exec ] }
[ @exec ]
$file
C<croak>s on error.
=cut
sub make_iterator {
my ( $class, $source ) = @_;
my $meta = $source->meta;
my @command;
if ( $meta->{is_hash} ) {
@command = @{ $source->raw->{exec} || [] };
}
elsif ( $meta->{is_scalar} ) {
@command = ${ $source->raw };
}
elsif ( $meta->{is_array} ) {
@command = @{ $source->raw };
}
$class->_croak('No command found in $source->raw!') unless @command;
$class->_autoflush( \*STDOUT );
$class->_autoflush( \*STDERR );
push @command, @{ $source->test_args || [] };
return $class->iterator_class->new(
{ command => \@command,
merge => $source->merge
}
);
}
=head3 C<iterator_class>
The class of iterator to use, override if you're sub-classing. Defaults
to L<TAP::Parser::Iterator::Process>.
=cut
use constant iterator_class => 'TAP::Parser::Iterator::Process';
# Turns on autoflush for the handle passed
sub _autoflush {
my ( $class, $flushed ) = @_;
my $old_fh = select $flushed;
$| = 1;
select $old_fh;
}
1;
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
=head2 Example
package MyRubySourceHandler;
use strict;
use Carp qw( croak );
use TAP::Parser::SourceHandler::Executable;
use base 'TAP::Parser::SourceHandler::Executable';
# expect $handler->(['mytest.rb', 'cmdline', 'args']);
sub make_iterator {
my ($self, $source) = @_;
my @test_args = @{ $source->test_args };
my $rb_file = $test_args[0];
croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
return $self->SUPER::raw_source(['/usr/bin/ruby', @test_args]);
}
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::IteratorFactory>,
L<TAP::Parser::SourceHandler>,
L<TAP::Parser::SourceHandler::Perl>,
L<TAP::Parser::SourceHandler::File>,
L<TAP::Parser::SourceHandler::Handle>,
L<TAP::Parser::SourceHandler::RawTAP>
=cut
PK �[���s s Parser/IteratorFactory.pmnu �[��� package TAP::Parser::IteratorFactory;
use strict;
use warnings;
use Carp qw( confess );
use File::Basename qw( fileparse );
use base 'TAP::Object';
use constant handlers => [];
=head1 NAME
TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
use TAP::Parser::IteratorFactory;
my $factory = TAP::Parser::IteratorFactory->new({ %config });
my $iterator = $factory->make_iterator( $filename );
=head1 DESCRIPTION
This is a factory class that takes a L<TAP::Parser::Source> and runs it through all the
registered L<TAP::Parser::SourceHandler>s to see which one should handle the source.
If you're a plugin author, you'll be interested in how to L</register_handler>s,
how L</detect_source> works.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Creates a new factory class:
my $sf = TAP::Parser::IteratorFactory->new( $config );
C<$config> is optional. If given, sets L</config> and calls L</load_handlers>.
=cut
sub _initialize {
my ( $self, $config ) = @_;
$self->config( $config || {} )->load_handlers;
return $self;
}
=head3 C<register_handler>
Registers a new L<TAP::Parser::SourceHandler> with this factory.
__PACKAGE__->register_handler( $handler_class );
=head3 C<handlers>
List of handlers that have been registered.
=cut
sub register_handler {
my ( $class, $dclass ) = @_;
confess("$dclass must implement can_handle & make_iterator methods!")
unless UNIVERSAL::can( $dclass, 'can_handle' )
&& UNIVERSAL::can( $dclass, 'make_iterator' );
my $handlers = $class->handlers;
push @{$handlers}, $dclass
unless grep { $_ eq $dclass } @{$handlers};
return $class;
}
##############################################################################
=head2 Instance Methods
=head3 C<config>
my $cfg = $sf->config;
$sf->config({ Perl => { %config } });
Chaining getter/setter for the configuration of the available source handlers.
This is a hashref keyed on handler class whose values contain config to be passed
onto the handlers during detection & creation. Class names may be fully qualified
or abbreviated, eg:
# these are equivalent
$sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } });
$sf->config({ 'Perl' => { %config } });
=cut
sub config {
my $self = shift;
return $self->{config} unless @_;
unless ( 'HASH' eq ref $_[0] ) {
$self->_croak('Argument to &config must be a hash reference');
}
$self->{config} = shift;
return $self;
}
sub _last_handler {
my $self = shift;
return $self->{last_handler} unless @_;
$self->{last_handler} = shift;
return $self;
}
sub _testing {
my $self = shift;
return $self->{testing} unless @_;
$self->{testing} = shift;
return $self;
}
##############################################################################
=head3 C<load_handlers>
$sf->load_handlers;
Loads the handler classes defined in L</config>. For example, given a config:
$sf->config({
MySourceHandler => { some => 'config' },
});
C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in
C<@INC> for it in this order:
TAP::Parser::SourceHandler::MySourceHandler
MySourceHandler
C<croak>s on error.
=cut
sub load_handlers {
my ($self) = @_;
for my $handler ( keys %{ $self->config } ) {
my $sclass = $self->_load_handler($handler);
# TODO: store which class we loaded anywhere?
}
return $self;
}
sub _load_handler {
my ( $self, $handler ) = @_;
my @errors;
for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) {
return $dclass
if UNIVERSAL::can( $dclass, 'can_handle' )
&& UNIVERSAL::can( $dclass, 'make_iterator' );
eval "use $dclass";
if ( my $e = $@ ) {
push @errors, $e;
next;
}
return $dclass
if UNIVERSAL::can( $dclass, 'can_handle' )
&& UNIVERSAL::can( $dclass, 'make_iterator' );
push @errors,
"handler '$dclass' does not implement can_handle & make_iterator";
}
$self->_croak(
"Cannot load handler '$handler': " . join( "\n", @errors ) );
}
##############################################################################
=head3 C<make_iterator>
my $iterator = $src_factory->make_iterator( $source );
Given a L<TAP::Parser::Source>, finds the most suitable L<TAP::Parser::SourceHandler>
to use to create a L<TAP::Parser::Iterator> (see L</detect_source>). Dies on error.
=cut
sub make_iterator {
my ( $self, $source ) = @_;
$self->_croak('no raw source defined!') unless defined $source->raw;
$source->config( $self->config )->assemble_meta;
# is the raw source already an object?
return $source->raw
if ( $source->meta->{is_object}
&& UNIVERSAL::isa( $source->raw, 'TAP::Parser::SourceHandler' ) );
# figure out what kind of source it is
my $sd_class = $self->detect_source($source);
$self->_last_handler($sd_class);
return if $self->_testing;
# create it
my $iterator = $sd_class->make_iterator($source);
return $iterator;
}
=head3 C<detect_source>
Given a L<TAP::Parser::Source>, detects what kind of source it is and
returns I<one> L<TAP::Parser::SourceHandler> (the most confident one). Dies
on error.
The detection algorithm works something like this:
for (@registered_handlers) {
# ask them how confident they are about handling this source
$confidence{$handler} = $handler->can_handle( $source )
}
# choose the most confident handler
Ties are handled by choosing the first handler.
=cut
sub detect_source {
my ( $self, $source ) = @_;
confess('no raw source ref defined!') unless defined $source->raw;
# find a list of handlers that can handle this source:
my %confidence_for;
for my $handler ( @{ $self->handlers } ) {
my $confidence = $handler->can_handle($source);
# warn "handler: $handler: $confidence\n";
$confidence_for{$handler} = $confidence if $confidence;
}
if ( !%confidence_for ) {
# error: can't detect source
my $raw_source_short = substr( ${ $source->raw }, 0, 50 );
confess("Cannot detect source of '$raw_source_short'!");
return;
}
# if multiple handlers can handle it, choose the most confident one
my @handlers =
sort { $confidence_for{$b} <=> $confidence_for{$a} }
keys %confidence_for;
# Check for a tie.
if( @handlers > 1 &&
$confidence_for{$handlers[0]} == $confidence_for{$handlers[1]}
) {
my $filename = $source->meta->{file}{basename};
die("There is a tie between $handlers[0] and $handlers[1].\n".
"Both voted $confidence_for{$handlers[0]} on $filename.\n");
}
# this is really useful for debugging handlers:
if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) {
warn(
"votes: ",
join( ', ', map {"$_: $confidence_for{$_}"} @handlers ),
"\n"
);
}
# return 1st
return $handlers[0];
}
1;
__END__
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
=head2 Example
If we've done things right, you'll probably want to write a new source,
rather than sub-classing this (see L<TAP::Parser::SourceHandler> for that).
But in case you find the need to...
package MyIteratorFactory;
use strict;
use base 'TAP::Parser::IteratorFactory';
# override source detection algorithm
sub detect_source {
my ($self, $raw_source_ref, $meta) = @_;
# do detective work, using $meta and whatever else...
}
1;
=head1 AUTHORS
Steve Purkis
=head1 ATTRIBUTION
Originally ripped off from L<Test::Harness>.
Moved out of L<TAP::Parser> & converted to a factory class to support
extensible TAP source detective work by Steve Purkis.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::SourceHandler>,
L<TAP::Parser::SourceHandler::File>,
L<TAP::Parser::SourceHandler::Perl>,
L<TAP::Parser::SourceHandler::RawTAP>,
L<TAP::Parser::SourceHandler::Handle>,
L<TAP::Parser::SourceHandler::Executable>
=cut
PK �[s厤" " Parser/SourceHandler.pmnu �[��� package TAP::Parser::SourceHandler;
use strict;
use warnings;
use TAP::Parser::Iterator ();
use base 'TAP::Object';
=head1 NAME
TAP::Parser::SourceHandler - Base class for different TAP source handlers
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
# abstract class - don't use directly!
# see TAP::Parser::IteratorFactory for general usage
# must be sub-classed for use
package MySourceHandler;
use base 'TAP::Parser::SourceHandler';
sub can_handle { return $confidence_level }
sub make_iterator { return $iterator }
# see example below for more details
=head1 DESCRIPTION
This is an abstract base class for L<TAP::Parser::Source> handlers / handlers.
A C<TAP::Parser::SourceHandler> does whatever is necessary to produce & capture
a stream of TAP from the I<raw> source, and package it up in a
L<TAP::Parser::Iterator> for the parser to consume.
C<SourceHandlers> must implement the I<source detection & handling> interface
used by L<TAP::Parser::IteratorFactory>. At 2 methods, the interface is pretty
simple: L</can_handle> and L</make_source>.
Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin, or
subclassing L<TAP::Parser>, you probably won't need to use this module directly.
=head1 METHODS
=head2 Class Methods
=head3 C<can_handle>
I<Abstract method>.
my $vote = $class->can_handle( $source );
C<$source> is a L<TAP::Parser::Source>.
Returns a number between C<0> & C<1> reflecting how confidently the raw source
can be handled. For example, C<0> means the source cannot handle it, C<0.5>
means it may be able to, and C<1> means it definitely can. See
L<TAP::Parser::IteratorFactory/detect_source> for details on how this is used.
=cut
sub can_handle {
my ( $class, $args ) = @_;
$class->_croak(
"Abstract method 'can_handle' not implemented for $class!");
return;
}
=head3 C<make_iterator>
I<Abstract method>.
my $iterator = $class->make_iterator( $source );
C<$source> is a L<TAP::Parser::Source>.
Returns a new L<TAP::Parser::Iterator> object for use by the L<TAP::Parser>.
C<croak>s on error.
=cut
sub make_iterator {
my ( $class, $args ) = @_;
$class->_croak(
"Abstract method 'make_iterator' not implemented for $class!");
return;
}
1;
__END__
=head1 SUBCLASSING
Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview, and any
of the subclasses that ship with this module as an example. What follows is
a quick overview.
Start by familiarizing yourself with L<TAP::Parser::Source> and
L<TAP::Parser::IteratorFactory>. L<TAP::Parser::SourceHandler::RawTAP> is
the easiest sub-class to use as an example.
It's important to point out that if you want your subclass to be automatically
used by L<TAP::Parser> you'll have to and make sure it gets loaded somehow.
If you're using L<prove> you can write an L<App::Prove> plugin. If you're
using L<TAP::Parser> or L<TAP::Harness> directly (e.g. through a custom script,
L<ExtUtils::MakeMaker>, or L<Module::Build>) you can use the C<config> option
which will cause L<TAP::Parser::IteratorFactory/load_sources> to load your
subclass).
Don't forget to register your class with
L<TAP::Parser::IteratorFactory/register_handler>.
=head2 Example
package MySourceHandler;
use strict;
use MySourceHandler; # see TAP::Parser::SourceHandler
use TAP::Parser::IteratorFactory;
use base 'TAP::Parser::SourceHandler';
TAP::Parser::IteratorFactory->register_handler( __PACKAGE__ );
sub can_handle {
my ( $class, $src ) = @_;
my $meta = $src->meta;
my $config = $src->config_for( $class );
if ($config->{accept_all}) {
return 1.0;
} elsif (my $file = $meta->{file}) {
return 0.0 unless $file->{exists};
return 1.0 if $file->{lc_ext} eq '.tap';
return 0.9 if $file->{shebang} && $file->{shebang} =~ /^#!.+tap/;
return 0.5 if $file->{text};
return 0.1 if $file->{binary};
} elsif ($meta->{scalar}) {
return 0.8 if $$raw_source_ref =~ /\d\.\.\d/;
return 0.6 if $meta->{has_newlines};
} elsif ($meta->{array}) {
return 0.8 if $meta->{size} < 5;
return 0.6 if $raw_source_ref->[0] =~ /foo/;
return 0.5;
} elsif ($meta->{hash}) {
return 0.6 if $raw_source_ref->{foo};
return 0.2;
}
return 0;
}
sub make_iterator {
my ($class, $source) = @_;
# this is where you manipulate the source and
# capture the stream of TAP in an iterator
# either pick a TAP::Parser::Iterator::* or write your own...
my $iterator = TAP::Parser::Iterator::Array->new([ 'foo', 'bar' ]);
return $iterator;
}
1;
=head1 AUTHORS
TAPx Developers.
Source detection stuff added by Steve Purkis
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Source>,
L<TAP::Parser::Iterator>,
L<TAP::Parser::IteratorFactory>,
L<TAP::Parser::SourceHandler::Executable>,
L<TAP::Parser::SourceHandler::Perl>,
L<TAP::Parser::SourceHandler::File>,
L<TAP::Parser::SourceHandler::Handle>,
L<TAP::Parser::SourceHandler::RawTAP>
=cut
PK �[�ֈ
�
Object.pmnu �[��� package TAP::Object;
use strict;
use warnings;
=head1 NAME
TAP::Object - Base class that provides common functionality to all C<TAP::*> modules
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
=head1 SYNOPSIS
package TAP::Whatever;
use strict;
use base 'TAP::Object';
# new() implementation by TAP::Object
sub _initialize {
my ( $self, @args) = @_;
# initialize your object
return $self;
}
# ... later ...
my $obj = TAP::Whatever->new(@args);
=head1 DESCRIPTION
C<TAP::Object> provides a default constructor and exception model for all
C<TAP::*> classes. Exceptions are raised using L<Carp>.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Create a new object. Any arguments passed to C<new> will be passed on to the
L</_initialize> method. Returns a new object.
=cut
sub new {
my $class = shift;
my $self = bless {}, $class;
return $self->_initialize(@_);
}
=head2 Instance Methods
=head3 C<_initialize>
Initializes a new object. This method is a stub by default, you should override
it as appropriate.
I<Note:> L</new> expects you to return C<$self> or raise an exception. See
L</_croak>, and L<Carp>.
=cut
sub _initialize {
return $_[0];
}
=head3 C<_croak>
Raise an exception using C<croak> from L<Carp>, eg:
$self->_croak( 'why me?', 'aaarrgh!' );
May also be called as a I<class> method.
$class->_croak( 'this works too' );
=cut
sub _croak {
my $proto = shift;
require Carp;
Carp::croak(@_);
return;
}
=head3 C<_confess>
Raise an exception using C<confess> from L<Carp>, eg:
$self->_confess( 'why me?', 'aaarrgh!' );
May also be called as a I<class> method.
$class->_confess( 'this works too' );
=cut
sub _confess {
my $proto = shift;
require Carp;
Carp::confess(@_);
return;
}
=head3 C<_construct>
Create a new instance of the specified class.
=cut
sub _construct {
my ( $self, $class, @args ) = @_;
$self->_croak("Bad module name $class")
unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
unless ( $class->can('new') ) {
local $@;
eval "require $class";
$self->_croak("Can't load $class: $@") if $@;
}
return $class->new(@args);
}
=head3 C<mk_methods>
Create simple getter/setters.
__PACKAGE__->mk_methods(@method_names);
=cut
sub mk_methods {
my ( $class, @methods ) = @_;
for my $method_name (@methods) {
my $method = "${class}::$method_name";
no strict 'refs';
*$method = sub {
my $self = shift;
$self->{$method_name} = shift if @_;
return $self->{$method_name};
};
}
}
1;
PK �[�}�Nq Nq
Harness.pmnu �[��� package TAP::Harness;
use strict;
use warnings;
use Carp;
use File::Spec;
use File::Path;
use IO::Handle;
use base 'TAP::Base';
=head1 NAME
TAP::Harness - Run test scripts with statistics
=head1 VERSION
Version 3.42
=cut
our $VERSION = '3.42';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
END {
# For VMS.
delete $ENV{HARNESS_ACTIVE};
delete $ENV{HARNESS_VERSION};
}
=head1 DESCRIPTION
This is a simple test harness which allows tests to be run and results
automatically aggregated and output to STDOUT.
=head1 SYNOPSIS
use TAP::Harness;
my $harness = TAP::Harness->new( \%args );
$harness->runtests(@tests);
=cut
my %VALIDATION_FOR;
my @FORMATTER_ARGS;
sub _error {
my $self = shift;
return $self->{error} unless @_;
$self->{error} = shift;
}
BEGIN {
@FORMATTER_ARGS = qw(
directives verbosity timer failures comments errors stdout color
show_count normalize
);
%VALIDATION_FOR = (
lib => sub {
my ( $self, $libs ) = @_;
$libs = [$libs] unless 'ARRAY' eq ref $libs;
return [ map {"-I$_"} @$libs ];
},
switches => sub { shift; shift },
exec => sub { shift; shift },
merge => sub { shift; shift },
aggregator_class => sub { shift; shift },
formatter_class => sub { shift; shift },
multiplexer_class => sub { shift; shift },
parser_class => sub { shift; shift },
scheduler_class => sub { shift; shift },
formatter => sub { shift; shift },
jobs => sub { shift; shift },
test_args => sub { shift; shift },
ignore_exit => sub { shift; shift },
rules => sub { shift; shift },
rulesfile => sub { shift; shift },
sources => sub { shift; shift },
version => sub { shift; shift },
trap => sub { shift; shift },
);
for my $method ( sort keys %VALIDATION_FOR ) {
no strict 'refs';
if ( $method eq 'lib' || $method eq 'switches' ) {
*{$method} = sub {
my $self = shift;
unless (@_) {
$self->{$method} ||= [];
return wantarray
? @{ $self->{$method} }
: $self->{$method};
}
$self->_croak("Too many arguments to method '$method'")
if @_ > 1;
my $args = shift;
$args = [$args] unless ref $args;
$self->{$method} = $args;
return $self;
};
}
else {
*{$method} = sub {
my $self = shift;
return $self->{$method} unless @_;
$self->{$method} = shift;
};
}
}
for my $method (@FORMATTER_ARGS) {
no strict 'refs';
*{$method} = sub {
my $self = shift;
return $self->formatter->$method(@_);
};
}
}
##############################################################################
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my %args = (
verbosity => 1,
lib => [ 'lib', 'blib/lib', 'blib/arch' ],
)
my $harness = TAP::Harness->new( \%args );
The constructor returns a new C<TAP::Harness> object. It accepts an
optional hashref whose allowed keys are:
=over 4
=item * C<verbosity>
Set the verbosity level:
1 verbose Print individual test results to STDOUT.
0 normal
-1 quiet Suppress some test output (mostly failures
while tests are running).
-2 really quiet Suppress everything but the tests summary.
-3 silent Suppress everything.
=item * C<timer>
Append run time for each test to output. Uses L<Time::HiRes> if
available.
=item * C<failures>
Show test failures (this is a no-op if C<verbose> is selected).
=item * C<comments>
Show test comments (this is a no-op if C<verbose> is selected).
=item * C<show_count>
Update the running test count during testing.
=item * C<normalize>
Set to a true value to normalize the TAP that is emitted in verbose modes.
=item * C<lib>
Accepts a scalar value or array ref of scalar values indicating which
paths to allowed libraries should be included if Perl tests are
executed. Naturally, this only makes sense in the context of tests
written in Perl.
=item * C<switches>
Accepts a scalar value or array ref of scalar values indicating which
switches should be included if Perl tests are executed. Naturally, this
only makes sense in the context of tests written in Perl.
=item * C<test_args>
A reference to an C<@INC> style array of arguments to be passed to each
test program.
test_args => ['foo', 'bar'],
if you want to pass different arguments to each test then you should
pass a hash of arrays, keyed by the alias for each test:
test_args => {
my_test => ['foo', 'bar'],
other_test => ['baz'],
}
=item * C<color>
Attempt to produce color output.
=item * C<exec>
Typically, Perl tests are run through this. However, anything which
spits out TAP is fine. You can use this argument to specify the name of
the program (and optional switches) to run your tests with:
exec => ['/usr/bin/ruby', '-w']
You can also pass a subroutine reference in order to determine and
return the proper program to run based on a given test script. The
subroutine reference should expect the TAP::Harness object itself as the
first argument, and the file name as the second argument. It should
return an array reference containing the command to be run and including
the test file name. It can also simply return C<undef>, in which case
TAP::Harness will fall back on executing the test script in Perl:
exec => sub {
my ( $harness, $test_file ) = @_;
# Let Perl tests run.
return undef if $test_file =~ /[.]t$/;
return [ qw( /usr/bin/ruby -w ), $test_file ]
if $test_file =~ /[.]rb$/;
}
If the subroutine returns a scalar with a newline or a filehandle, it
will be interpreted as raw TAP or as a TAP stream, respectively.
=item * C<merge>
If C<merge> is true the harness will create parsers that merge STDOUT
and STDERR together for any processes they start.
=item * C<sources>
I<NEW to 3.18>.
If set, C<sources> must be a hashref containing the names of the
L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a
hash of configuration that will be accessible to the source handlers via
L<TAP::Parser::Source/config_for>.
For example:
sources => {
Perl => { exec => '/path/to/custom/perl' },
File => { extensions => [ '.tap', '.txt' ] },
MyCustom => { some => 'config' },
}
The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters
are handled.
For more details, see the C<sources> parameter in L<TAP::Parser/new>,
L<TAP::Parser::Source>, and L<TAP::Parser::IteratorFactory>.
=item * C<aggregator_class>
The name of the class to use to aggregate test results. The default is
L<TAP::Parser::Aggregator>.
=item * C<version>
I<NEW to 3.22>.
Assume this TAP version for L<TAP::Parser> instead of default TAP
version 12.
=item * C<formatter_class>
The name of the class to use to format output. The default is
L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
isn't a TTY.
=item * C<multiplexer_class>
The name of the class to use to multiplex tests during parallel testing.
The default is L<TAP::Parser::Multiplexer>.
=item * C<parser_class>
The name of the class to use to parse TAP. The default is
L<TAP::Parser>.
=item * C<scheduler_class>
The name of the class to use to schedule test execution. The default is
L<TAP::Parser::Scheduler>.
=item * C<formatter>
If set C<formatter> must be an object that is capable of formatting the
TAP output. See L<TAP::Formatter::Console> for an example.
=item * C<errors>
If parse errors are found in the TAP output, a note of this will be
made in the summary report. To see all of the parse errors, set this
argument to true:
errors => 1
=item * C<directives>
If set to a true value, only test results with directives will be
displayed. This overrides other settings such as C<verbose> or
C<failures>.
=item * C<ignore_exit>
If set to a true value instruct C<TAP::Parser> to ignore exit and wait
status from test scripts.
=item * C<jobs>
The maximum number of parallel tests to run at any time. Which tests
can be run in parallel is controlled by C<rules>. The default is to
run only one test at a time.
=item * C<rules>
A reference to a hash of rules that control which tests may be executed in
parallel. If no rules are declared and L<CPAN::Meta::YAML> is available,
C<TAP::Harness> attempts to load rules from a YAML file specified by the
C<rulesfile> parameter. If no rules file exists, the default is for all
tests to be eligible to be run in parallel.
Here some simple examples. For the full details of the data structure
and the related glob-style pattern matching, see
L<TAP::Parser::Scheduler/"Rules data structure">.
# Run all tests in sequence, except those starting with "p"
$harness->rules({
par => 't/p*.t'
});
# Equivalent YAML file
---
par: t/p*.t
# Run all tests in parallel, except those starting with "p"
$harness->rules({
seq => [
{ seq => 't/p*.t' },
{ par => '**' },
],
});
# Equivalent YAML file
---
seq:
- seq: t/p*.t
- par: **
# Run some startup tests in sequence, then some parallel tests than some
# teardown tests in sequence.
$harness->rules({
seq => [
{ seq => 't/startup/*.t' },
{ par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
{ seq => 't/shutdown/*.t' },
],
});
# Equivalent YAML file
---
seq:
- seq: t/startup/*.t
- par:
- t/a/*.t
- t/b/*.t
- t/c/*.t
- seq: t/shutdown/*.t
This is an experimental feature and the interface may change.
=item * C<rulesfiles>
This specifies where to find a YAML file of test scheduling rules. If not
provided, it looks for a default file to use. It first checks for a file given
in the C<HARNESS_RULESFILE> environment variable, then it checks for
F<testrules.yml> and then F<t/testrules.yml>.
=item * C<stdout>
A filehandle for catching standard output.
=item * C<trap>
Attempt to print summary information if run is interrupted by
SIGINT (Ctrl-C).
=back
Any keys for which the value is C<undef> will be ignored.
=cut
# new supplied by TAP::Base
{
my @legal_callback = qw(
parser_args
made_parser
before_runtests
after_runtests
after_test
);
my %default_class = (
aggregator_class => 'TAP::Parser::Aggregator',
formatter_class => 'TAP::Formatter::Console',
multiplexer_class => 'TAP::Parser::Multiplexer',
parser_class => 'TAP::Parser',
scheduler_class => 'TAP::Parser::Scheduler',
);
sub _initialize {
my ( $self, $arg_for ) = @_;
$arg_for ||= {};
$self->SUPER::_initialize( $arg_for, \@legal_callback );
my %arg_for = %$arg_for; # force a shallow copy
for my $name ( sort keys %VALIDATION_FOR ) {
my $property = delete $arg_for{$name};
if ( defined $property ) {
my $validate = $VALIDATION_FOR{$name};
my $value = $self->$validate($property);
if ( $self->_error ) {
$self->_croak;
}
$self->$name($value);
}
}
$self->jobs(1) unless defined $self->jobs;
if ( ! defined $self->rules ) {
$self->_maybe_load_rulesfile;
}
local $default_class{formatter_class} = 'TAP::Formatter::File'
unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY};
while ( my ( $attr, $class ) = each %default_class ) {
$self->$attr( $self->$attr() || $class );
}
unless ( $self->formatter ) {
# This is a little bodge to preserve legacy behaviour. It's
# pretty horrible that we know which args are destined for
# the formatter.
my %formatter_args = ( jobs => $self->jobs );
for my $name (@FORMATTER_ARGS) {
if ( defined( my $property = delete $arg_for{$name} ) ) {
$formatter_args{$name} = $property;
}
}
$self->formatter(
$self->_construct( $self->formatter_class, \%formatter_args )
);
}
if ( my @props = sort keys %arg_for ) {
$self->_croak("Unknown arguments to TAP::Harness::new (@props)");
}
return $self;
}
sub _maybe_load_rulesfile {
my ($self) = @_;
my ($rulesfile) = defined $self->rulesfile ? $self->rulesfile :
defined($ENV{HARNESS_RULESFILE}) ? $ENV{HARNESS_RULESFILE} :
grep { -r } qw(./testrules.yml t/testrules.yml);
if ( defined $rulesfile && -r $rulesfile ) {
if ( ! eval { require CPAN::Meta::YAML; 1} ) {
warn "CPAN::Meta::YAML required to process $rulesfile" ;
return;
}
my $layer = $] lt "5.008" ? "" : ":encoding(UTF-8)";
open my $fh, "<$layer", $rulesfile
or die "Couldn't open $rulesfile: $!";
my $yaml_text = do { local $/; <$fh> };
my $yaml = CPAN::Meta::YAML->read_string($yaml_text)
or die CPAN::Meta::YAML->errstr;
$self->rules( $yaml->[0] );
}
return;
}
}
##############################################################################
=head2 Instance Methods
=head3 C<runtests>
$harness->runtests(@tests);
Accepts an array of C<@tests> to be run. This should generally be the
names of test files, but this is not required. Each element in C<@tests>
will be passed to C<TAP::Parser::new()> as a C<source>. See
L<TAP::Parser> for more information.
It is possible to provide aliases that will be displayed in place of the
test name by supplying the test as a reference to an array containing
C<< [ $test, $alias ] >>:
$harness->runtests( [ 't/foo.t', 'Foo Once' ],
[ 't/foo.t', 'Foo Twice' ] );
Normally it is an error to attempt to run the same test twice. Aliases
allow you to overcome this limitation by giving each run of the test a
unique name.
Tests will be run in the order found.
If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
should name a directory into which a copy of the raw TAP for each test
will be written. TAP is written to files named for each test.
Subdirectories will be created as needed.
Returns a L<TAP::Parser::Aggregator> containing the test results.
=cut
sub runtests {
my ( $self, @tests ) = @_;
my $aggregate = $self->_construct( $self->aggregator_class );
$self->_make_callback( 'before_runtests', $aggregate );
$aggregate->start;
my $finish = sub {
my $interrupted = shift;
$aggregate->stop;
$self->summary( $aggregate, $interrupted );
$self->_make_callback( 'after_runtests', $aggregate );
};
my $run = sub {
$self->aggregate_tests( $aggregate, @tests );
$finish->();
};
if ( $self->trap ) {
local $SIG{INT} = sub {
print "\n";
$finish->(1);
exit;
};
$run->();
}
else {
$run->();
}
return $aggregate;
}
=head3 C<summary>
$harness->summary( $aggregator );
Output the summary for a L<TAP::Parser::Aggregator>.
=cut
sub summary {
my ( $self, @args ) = @_;
$self->formatter->summary(@args);
}
sub _after_test {
my ( $self, $aggregate, $job, $parser ) = @_;
$self->_make_callback( 'after_test', $job->as_array_ref, $parser );
$aggregate->add( $job->description, $parser );
}
sub _bailout {
my ( $self, $result ) = @_;
my $explanation = $result->explanation;
die "FAILED--Further testing stopped"
. ( $explanation ? ": $explanation\n" : ".\n" );
}
sub _aggregate_parallel {
my ( $self, $aggregate, $scheduler ) = @_;
my $jobs = $self->jobs;
my $mux = $self->_construct( $self->multiplexer_class );
RESULT: {
# Keep multiplexer topped up
FILL:
while ( $mux->parsers < $jobs ) {
my $job = $scheduler->get_job;
# If we hit a spinner stop filling and start running.
last FILL if !defined $job || $job->is_spinner;
my ( $parser, $session ) = $self->make_parser($job);
$mux->add( $parser, [ $session, $job ] );
}
if ( my ( $parser, $stash, $result ) = $mux->next ) {
my ( $session, $job ) = @$stash;
if ( defined $result ) {
$session->result($result);
$self->_bailout($result) if $result->is_bailout;
}
else {
# End of parser. Automatically removed from the mux.
$self->finish_parser( $parser, $session );
$self->_after_test( $aggregate, $job, $parser );
$job->finish;
}
redo RESULT;
}
}
return;
}
sub _aggregate_single {
my ( $self, $aggregate, $scheduler ) = @_;
JOB:
while ( my $job = $scheduler->get_job ) {
next JOB if $job->is_spinner;
my ( $parser, $session ) = $self->make_parser($job);
while ( defined( my $result = $parser->next ) ) {
$session->result($result);
if ( $result->is_bailout ) {
# Keep reading until input is exhausted in the hope
# of allowing any pending diagnostics to show up.
1 while $parser->next;
$self->_bailout($result);
}
}
$self->finish_parser( $parser, $session );
$self->_after_test( $aggregate, $job, $parser );
$job->finish;
}
return;
}
=head3 C<aggregate_tests>
$harness->aggregate_tests( $aggregate, @tests );
Run the named tests and display a summary of result. Tests will be run
in the order found.
Test results will be added to the supplied L<TAP::Parser::Aggregator>.
C<aggregate_tests> may be called multiple times to run several sets of
tests. Multiple C<Test::Harness> instances may be used to pass results
to a single aggregator so that different parts of a complex test suite
may be run using different C<TAP::Harness> settings. This is useful, for
example, in the case where some tests should run in parallel but others
are unsuitable for parallel execution.
my $formatter = TAP::Formatter::Console->new;
my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
my $par_harness = TAP::Harness->new(
{ formatter => $formatter,
jobs => 9
}
);
my $aggregator = TAP::Parser::Aggregator->new;
$aggregator->start();
$ser_harness->aggregate_tests( $aggregator, @ser_tests );
$par_harness->aggregate_tests( $aggregator, @par_tests );
$aggregator->stop();
$formatter->summary($aggregator);
Note that for simpler testing requirements it will often be possible to
replace the above code with a single call to C<runtests>.
Each element of the C<@tests> array is either:
=over
=item * the source name of a test to run
=item * a reference to a [ source name, display name ] array
=back
In the case of a perl test suite, typically I<source names> are simply the file
names of the test scripts to run.
When you supply a separate display name it becomes possible to run a
test more than once; the display name is effectively the alias by which
the test is known inside the harness. The harness doesn't care if it
runs the same test more than once when each invocation uses a
different name.
=cut
sub aggregate_tests {
my ( $self, $aggregate, @tests ) = @_;
my $jobs = $self->jobs;
my $scheduler = $self->make_scheduler(@tests);
# #12458
local $ENV{HARNESS_IS_VERBOSE} = 1
if $self->formatter->verbosity > 0;
# Formatter gets only names.
$self->formatter->prepare( map { $_->description } $scheduler->get_all );
if ( $self->jobs > 1 ) {
$self->_aggregate_parallel( $aggregate, $scheduler );
}
else {
$self->_aggregate_single( $aggregate, $scheduler );
}
return;
}
sub _add_descriptions {
my $self = shift;
# Turn unwrapped scalars into anonymous arrays and copy the name as
# the description for tests that have only a name.
return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ }
map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
}
=head3 C<make_scheduler>
Called by the harness when it needs to create a
L<TAP::Parser::Scheduler>. Override in a subclass to provide an
alternative scheduler. C<make_scheduler> is passed the list of tests
that was passed to C<aggregate_tests>.
=cut
sub make_scheduler {
my ( $self, @tests ) = @_;
return $self->_construct(
$self->scheduler_class,
tests => [ $self->_add_descriptions(@tests) ],
rules => $self->rules
);
}
=head3 C<jobs>
Gets or sets the number of concurrent test runs the harness is
handling. By default, this value is 1 -- for parallel testing, this
should be set higher.
=cut
##############################################################################
sub _get_parser_args {
my ( $self, $job ) = @_;
my $test_prog = $job->filename;
my %args = ();
$args{sources} = $self->sources if $self->sources;
my @switches;
@switches = $self->lib if $self->lib;
push @switches => $self->switches if $self->switches;
$args{switches} = \@switches;
$args{spool} = $self->_open_spool($test_prog);
$args{merge} = $self->merge;
$args{ignore_exit} = $self->ignore_exit;
$args{version} = $self->version if $self->version;
if ( my $exec = $self->exec ) {
$args{exec}
= ref $exec eq 'CODE'
? $exec->( $self, $test_prog )
: [ @$exec, $test_prog ];
if ( not defined $args{exec} ) {
$args{source} = $test_prog;
}
elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) {
$args{source} = delete $args{exec};
}
}
else {
$args{source} = $test_prog;
}
if ( defined( my $test_args = $self->test_args ) ) {
if ( ref($test_args) eq 'HASH' ) {
# different args for each test
if ( exists( $test_args->{ $job->description } ) ) {
$test_args = $test_args->{ $job->description };
}
else {
$self->_croak( "TAP::Harness Can't find test_args for "
. $job->description );
}
}
$args{test_args} = $test_args;
}
return \%args;
}
=head3 C<make_parser>
Make a new parser and display formatter session. Typically used and/or
overridden in subclasses.
my ( $parser, $session ) = $harness->make_parser;
=cut
sub make_parser {
my ( $self, $job ) = @_;
my $args = $self->_get_parser_args($job);
$self->_make_callback( 'parser_args', $args, $job->as_array_ref );
my $parser = $self->_construct( $self->parser_class, $args );
$self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
my $session = $self->formatter->open_test( $job->description, $parser );
return ( $parser, $session );
}
=head3 C<finish_parser>
Terminate use of a parser. Typically used and/or overridden in
subclasses. The parser isn't destroyed as a result of this.
=cut
sub finish_parser {
my ( $self, $parser, $session ) = @_;
$session->close_test;
$self->_close_spool($parser);
return $parser;
}
sub _open_spool {
my $self = shift;
my $test = shift;
if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
my $spool = File::Spec->catfile( $spool_dir, $test );
# Make the directory
my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
my $path = File::Spec->catpath( $vol, $dir, '' );
eval { mkpath($path) };
$self->_croak($@) if $@;
my $spool_handle = IO::Handle->new;
open( $spool_handle, ">$spool" )
or $self->_croak(" Can't write $spool ( $! ) ");
return $spool_handle;
}
return;
}
sub _close_spool {
my $self = shift;
my ($parser) = @_;
if ( my $spool_handle = $parser->delete_spool ) {
close($spool_handle)
or $self->_croak(" Error closing TAP spool file( $! ) \n ");
}
return;
}
sub _croak {
my ( $self, $message ) = @_;
unless ($message) {
$message = $self->_error;
}
$self->SUPER::_croak($message);
return;
}
1;
__END__
##############################################################################
=head1 CONFIGURING
C<TAP::Harness> is designed to be easy to configure.
=head2 Plugins
C<TAP::Parser> plugins let you change the way TAP is I<input> to and I<output>
from the parser.
L<TAP::Parser::SourceHandler>s handle TAP I<input>. You can configure them
and load custom handlers using the C<sources> parameter to L</new>.
L<TAP::Formatter>s handle TAP I<output>. You can load custom formatters by
using the C<formatter_class> parameter to L</new>. To configure a formatter,
you currently need to instantiate it outside of L<TAP::Harness> and pass it in
with the C<formatter> parameter to L</new>. This I<may> be addressed by adding
a I<formatters> parameter to L</new> in the future.
=head2 C<Module::Build>
L<Module::Build> version C<0.30> supports C<TAP::Harness>.
To load C<TAP::Harness> plugins, you'll need to use the C<tap_harness_args>
parameter to C<new>, typically from your C<Build.PL>. For example:
Module::Build->new(
module_name => 'MyApp',
test_file_exts => [qw(.t .tap .txt)],
use_tap_harness => 1,
tap_harness_args => {
sources => {
MyCustom => {},
File => {
extensions => ['.tap', '.txt'],
},
},
formatter_class => 'TAP::Formatter::HTML',
},
build_requires => {
'Module::Build' => '0.30',
'TAP::Harness' => '3.18',
},
)->create_build_script;
See L</new>
=head2 C<ExtUtils::MakeMaker>
L<ExtUtils::MakeMaker> does not support L<TAP::Harness> out-of-the-box.
=head2 C<prove>
L<prove> supports C<TAP::Harness> plugins, and has a plugin system of its
own. See L<prove/FORMATTERS>, L<prove/SOURCE HANDLERS> and L<App::Prove>
for more details.
=head1 WRITING PLUGINS
If you can't configure C<TAP::Harness> to do what you want, and you can't find
an existing plugin, consider writing one.
The two primary use cases supported by L<TAP::Harness> for plugins are I<input>
and I<output>:
=over 2
=item Customize how TAP gets into the parser
To do this, you can either extend an existing L<TAP::Parser::SourceHandler>,
or write your own. It's a pretty simple API, and they can be loaded and
configured using the C<sources> parameter to L</new>.
=item Customize how TAP results are output from the parser
To do this, you can either extend an existing L<TAP::Formatter>, or write your
own. Writing formatters are a bit more involved than writing a
I<SourceHandler>, as you'll need to understand the L<TAP::Parser> API. A
good place to start is by understanding how L</aggregate_tests> works.
Custom formatters can be loaded configured using the C<formatter_class>
parameter to L</new>.
=back
=head1 SUBCLASSING
If you can't configure C<TAP::Harness> to do exactly what you want, and writing
a plugin isn't an option, consider extending it. It is designed to be (mostly)
easy to subclass, though the cases when sub-classing is necessary should be few
and far between.
=head2 Methods
The following methods are ones you may wish to override if you want to
subclass C<TAP::Harness>.
=over 4
=item L</new>
=item L</runtests>
=item L</summary>
=back
=cut
=head1 REPLACING
If you like the C<prove> utility and L<TAP::Parser> but you want your
own harness, all you need to do is write one and provide C<new> and
C<runtests> methods. Then you can use the C<prove> utility like so:
prove --harness My::Test::Harness
Note that while C<prove> accepts a list of tests (or things to be
tested), C<new> has a fairly rich set of arguments. You'll probably want
to read over this code carefully to see how all of them are being used.
=head1 SEE ALSO
L<Test::Harness>
=cut
# vim:ts=4:sw=4:et:sta
PK �[�[q�< �< Harness/Beyond.podnu �[��� =head1 NAME
Test::Harness::Beyond - Beyond make test
=head1 Beyond make test
Test::Harness is responsible for running test scripts, analysing
their output and reporting success or failure. When I type
F<make test> (or F<./Build test>) for a module, Test::Harness is usually
used to run the tests (not all modules use Test::Harness but the
majority do).
To start exploring some of the features of Test::Harness I need to
switch from F<make test> to the F<prove> command (which ships with
Test::Harness). For the following examples I'll also need a recent
version of Test::Harness installed; 3.14 is current as I write.
For the examples I'm going to assume that we're working with a
'normal' Perl module distribution. Specifically I'll assume that
typing F<make> or F<./Build> causes the built, ready-to-install module
code to be available below ./blib/lib and ./blib/arch and that
there's a directory called 't' that contains our tests. Test::Harness
isn't hardwired to that configuration but it saves me from explaining
which files live where for each example.
Back to F<prove>; like F<make test> it runs a test suite - but it
provides far more control over which tests are executed, in what
order and how their results are reported. Typically F<make test>
runs all the test scripts below the 't' directory. To do the same
thing with prove I type:
prove -rb t
The switches here are -r to recurse into any directories below 't'
and -b which adds ./blib/lib and ./blib/arch to Perl's include path
so that the tests can find the code they will be testing. If I'm
testing a module of which an earlier version is already installed
I need to be careful about the include path to make sure I'm not
running my tests against the installed version rather than the new
one that I'm working on.
Unlike F<make test>, typing F<prove> doesn't automatically rebuild
my module. If I forget to make before prove I will be testing against
older versions of those files - which inevitably leads to confusion.
I either get into the habit of typing
make && prove -rb t
or - if I have no XS code that needs to be built I use the modules
below F<lib> instead
prove -Ilib -r t
So far I've shown you nothing that F<make test> doesn't do. Let's
fix that.
=head2 Saved State
If I have failing tests in a test suite that consists of more than
a handful of scripts and takes more than a few seconds to run it
rapidly becomes tedious to run the whole test suite repeatedly as
I track down the problems.
I can tell prove just to run the tests that are failing like this:
prove -b t/this_fails.t t/so_does_this.t
That speeds things up but I have to make a note of which tests are
failing and make sure that I run those tests. Instead I can use
prove's --state switch and have it keep track of failing tests for
me. First I do a complete run of the test suite and tell prove to
save the results:
prove -rb --state=save t
That stores a machine readable summary of the test run in a file
called '.prove' in the current directory. If I have failures I can
then run just the failing scripts like this:
prove -b --state=failed
I can also tell prove to save the results again so that it updates
its idea of which tests failed:
prove -b --state=failed,save
As soon as one of my failing tests passes it will be removed from
the list of failed tests. Eventually I fix them all and prove can
find no failing tests to run:
Files=0, Tests=0, 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU)
Result: NOTESTS
As I work on a particular part of my module it's most likely that
the tests that cover that code will fail. I'd like to run the whole
test suite but have it prioritize these 'hot' tests. I can tell
prove to do this:
prove -rb --state=hot,save t
All the tests will run but those that failed most recently will be
run first. If no tests have failed since I started saving state all
tests will run in their normal order. This combines full test
coverage with early notification of failures.
The --state switch supports a number of options; for example to run
failed tests first followed by all remaining tests ordered by the
timestamps of the test scripts - and save the results - I can use
prove -rb --state=failed,new,save t
See the prove documentation (type prove --man) for the full list
of state options.
When I tell prove to save state it writes a file called '.prove'
('_prove' on Windows) in the current directory. It's a YAML document
so it's quite easy to write tools of your own that work on the saved
test state - but the format isn't officially documented so it might
change without (much) warning in the future.
=head2 Parallel Testing
If my tests take too long to run I may be able to speed them up by
running multiple test scripts in parallel. This is particularly
effective if the tests are I/O bound or if I have multiple CPU
cores. I tell prove to run my tests in parallel like this:
prove -rb -j 9 t
The -j switch enables parallel testing; the number that follows it
is the maximum number of tests to run in parallel. Sometimes tests
that pass when run sequentially will fail when run in parallel. For
example if two different test scripts use the same temporary file
or attempt to listen on the same socket I'll have problems running
them in parallel. If I see unexpected failures I need to check my
tests to work out which of them are trampling on the same resource
and rename temporary files or add locks as appropriate.
To get the most performance benefit I want to have the test scripts
that take the longest to run start first - otherwise I'll be waiting
for the one test that takes nearly a minute to complete after all
the others are done. I can use the --state switch to run the tests
in slowest to fastest order:
prove -rb -j 9 --state=slow,save t
=head2 Non-Perl Tests
The Test Anything Protocol (http://testanything.org/) isn't just
for Perl. Just about any language can be used to write tests that
output TAP. There are TAP based testing libraries for C, C++, PHP,
Python and many others. If I can't find a TAP library for my language
of choice it's easy to generate valid TAP. It looks like this:
1..3
ok 1 - init OK
ok 2 - opened file
not ok 3 - appended to file
The first line is the plan - it specifies the number of tests I'm
going to run so that it's easy to check that the test script didn't
exit before running all the expected tests. The following lines are
the test results - 'ok' for pass, 'not ok' for fail. Each test has
a number and, optionally, a description. And that's it. Any language
that can produce output like that on STDOUT can be used to write
tests.
Recently I've been rekindling a two-decades-old interest in Forth.
Evidently I have a masochistic streak that even Perl can't satisfy.
I want to write tests in Forth and run them using prove (you can
find my gforth TAP experiments at
https://svn.hexten.net/andy/Forth/Testing/). I can use the --exec
switch to tell prove to run the tests using gforth like this:
prove -r --exec gforth t
Alternately, if the language used to write my tests allows a shebang
line I can use that to specify the interpreter. Here's a test written
in PHP:
#!/usr/bin/php
<?php
print "1..2\n";
print "ok 1\n";
print "not ok 2\n";
?>
If I save that as t/phptest.t the shebang line will ensure that it
runs correctly along with all my other tests.
=head2 Mixing it up
Subtle interdependencies between test programs can mask problems -
for example an earlier test may neglect to remove a temporary file
that affects the behaviour of a later test. To find this kind of
problem I use the --shuffle and --reverse options to run my tests
in random or reversed order.
=head2 Rolling My Own
If I need a feature that prove doesn't provide I can easily write my own.
Typically you'll want to change how TAP gets I<input> into and I<output>
from the parser. L<App::Prove> supports arbitrary plugins, and L<TAP::Harness>
supports custom I<formatters> and I<source handlers> that you can load using
either L<prove> or L<Module::Build>; there are many examples to base mine on.
For more details see L<App::Prove>, L<TAP::Parser::SourceHandler>, and
L<TAP::Formatter::Base>.
If writing a plugin is not enough, you can write your own test harness; one of
the motives for the 3.00 rewrite of Test::Harness was to make it easier to
subclass and extend.
The Test::Harness module is a compatibility wrapper around TAP::Harness.
For new applications I should use TAP::Harness directly. As we'll
see, prove uses TAP::Harness.
When I run prove it processes its arguments, figures out which test
scripts to run and then passes control to TAP::Harness to run the
tests, parse, analyse and present the results. By subclassing
TAP::Harness I can customise many aspects of the test run.
I want to log my test results in a database so I can track them
over time. To do this I override the summary method in TAP::Harness.
I start with a simple prototype that dumps the results as a YAML
document:
package My::TAP::Harness;
use base 'TAP::Harness';
use YAML;
sub summary {
my ( $self, $aggregate ) = @_;
print Dump( $aggregate );
$self->SUPER::summary( $aggregate );
}
1;
I need to tell prove to use my My::TAP::Harness. If My::TAP::Harness
is on Perl's @INC include path I can
prove --harness=My::TAP::Harness -rb t
If I don't have My::TAP::Harness installed on @INC I need to provide
the correct path to perl when I run prove:
perl -Ilib `which prove` --harness=My::TAP::Harness -rb t
I can incorporate these options into my own version of prove. It's
pretty simple. Most of the work of prove is handled by App::Prove.
The important code in prove is just:
use App::Prove;
my $app = App::Prove->new;
$app->process_args(@ARGV);
exit( $app->run ? 0 : 1 );
If I write a subclass of App::Prove I can customise any aspect of
the test runner while inheriting all of prove's behaviour. Here's
myprove:
#!/usr/bin/env perl use lib qw( lib ); # Add ./lib to @INC
use App::Prove;
my $app = App::Prove->new;
# Use custom TAP::Harness subclass
$app->harness( 'My::TAP::Harness' );
$app->process_args( @ARGV ); exit( $app->run ? 0 : 1 );
Now I can run my tests like this
./myprove -rb t
=head2 Deeper Customisation
Now that I know how to subclass and replace TAP::Harness I can
replace any other part of the harness. To do that I need to know
which classes are responsible for which functionality. Here's a
brief guided tour; the default class for each component is shown
in parentheses. Normally any replacements I write will be subclasses
of these default classes.
When I run my tests TAP::Harness creates a scheduler
(TAP::Parser::Scheduler) to work out the running order for the
tests, an aggregator (TAP::Parser::Aggregator) to collect and analyse
the test results and a formatter (TAP::Formatter::Console) to display
those results.
If I'm running my tests in parallel there may also be a multiplexer
(TAP::Parser::Multiplexer) - the component that allows multiple
tests to run simultaneously.
Once it has created those helpers TAP::Harness starts running the
tests. For each test it creates a new parser (TAP::Parser) which
is responsible for running the test script and parsing its output.
To replace any of these components I call one of these harness
methods with the name of the replacement class:
aggregator_class
formatter_class
multiplexer_class
parser_class
scheduler_class
For example, to replace the aggregator I would
$harness->aggregator_class( 'My::Aggregator' );
Alternately I can supply the names of my substitute classes to the
TAP::Harness constructor:
my $harness = TAP::Harness->new(
{ aggregator_class => 'My::Aggregator' }
);
If I need to reach even deeper into the internals of the harness I
can replace the classes that TAP::Parser uses to execute test scripts
and tokenise their output. Before running a test script TAP::Parser
creates a grammar (TAP::Parser::Grammar) to decode the raw TAP into
tokens, a result factory (TAP::Parser::ResultFactory) to turn the
decoded TAP results into objects and, depending on whether it's
running a test script or reading TAP from a file, scalar or array
a source or an iterator (TAP::Parser::IteratorFactory).
Each of these objects may be replaced by calling one of these parser
methods:
source_class
perl_source_class
grammar_class
iterator_factory_class
result_factory_class
=head2 Callbacks
As an alternative to subclassing the components I need to change I
can attach callbacks to the default classes. TAP::Harness exposes
these callbacks:
parser_args Tweak the parameters used to create the parser
made_parser Just made a new parser
before_runtests About to run tests
after_runtests Have run all tests
after_test Have run an individual test script
TAP::Parser also supports callbacks; bailout, comment, plan, test,
unknown, version and yaml are called for the corresponding TAP
result types, ALL is called for all results, ELSE is called for all
results for which a named callback is not installed and EOF is
called once at the end of each TAP stream.
To install a callback I pass the name of the callback and a subroutine
reference to TAP::Harness or TAP::Parser's callback method:
$harness->callback( after_test => sub {
my ( $script, $desc, $parser ) = @_;
} );
I can also pass callbacks to the constructor:
my $harness = TAP::Harness->new({
callbacks => {
after_test => sub {
my ( $script, $desc, $parser ) = @_;
# Do something interesting here
}
}
});
When it comes to altering the behaviour of the test harness there's
more than one way to do it. Which way is best depends on my
requirements. In general if I only want to observe test execution
without changing the harness' behaviour (for example to log test
results to a database) I choose callbacks. If I want to make the
harness behave differently subclassing gives me more control.
=head2 Parsing TAP
Perhaps I don't need a complete test harness. If I already have a
TAP test log that I need to parse all I need is TAP::Parser and the
various classes it depends upon. Here's the code I need to run a
test and parse its TAP output
use TAP::Parser;
my $parser = TAP::Parser->new( { source => 't/simple.t' } );
while ( my $result = $parser->next ) {
print $result->as_string, "\n";
}
Alternately I can pass an open filehandle as source and have the
parser read from that rather than attempting to run a test script:
open my $tap, '<', 'tests.tap'
or die "Can't read TAP transcript ($!)\n";
my $parser = TAP::Parser->new( { source => $tap } );
while ( my $result = $parser->next ) {
print $result->as_string, "\n";
}
This approach is useful if I need to convert my TAP based test
results into some other representation. See TAP::Convert::TET
(http://search.cpan.org/dist/TAP-Convert-TET/) for an example of
this approach.
=head2 Getting Support
The Test::Harness developers hang out on the tapx-dev mailing
list[1]. For discussion of general, language independent TAP issues
there's the tap-l[2] list. Finally there's a wiki dedicated to the
Test Anything Protocol[3]. Contributions to the wiki, patches and
suggestions are all welcome.
=for comment
The URLs in [1] and [2] point to 404 pages. What are currently the
correct URLs?
[1] L<http://www.hexten.net/mailman/listinfo/tapx-dev>
[2] L<http://testanything.org/mailman/listinfo/tap-l>
[3] L<http://testanything.org/>
PK �[���J( ( Harness/Env.pmnu �[��� package TAP::Harness::Env;
use strict;
use warnings;
use constant IS_VMS => ( $^O eq 'VMS' );
use TAP::Object;
use Text::ParseWords qw/shellwords/;
our $VERSION = '3.42';
# Get the parts of @INC which are changed from the stock list AND
# preserve reordering of stock directories.
sub _filtered_inc_vms {
my @inc = grep { !ref } @INC; #28567
# 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;
my @default_inc = _default_inc();
my @new_inc;
my %seen;
for my $dir (@inc) {
next if $seen{$dir}++;
if ( $dir eq ( $default_inc[0] || '' ) ) {
shift @default_inc;
}
else {
push @new_inc, $dir;
}
shift @default_inc while @default_inc and $seen{ $default_inc[0] };
}
return @new_inc;
}
# Cache this to avoid repeatedly shelling out to Perl.
my @inc;
sub _default_inc {
return @inc if @inc;
local $ENV{PERL5LIB};
local $ENV{PERLLIB};
my $perl = $ENV{HARNESS_PERL} || $^X;
# Avoid using -l for the benefit of Perl 6
chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` );
return @inc;
}
sub create {
my $package = shift;
my %input = %{ shift || {} };
my @libs = @{ delete $input{libs} || [] };
my @raw_switches = @{ delete $input{switches} || [] };
my @opt
= ( @raw_switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} || '' ) );
my @switches;
while ( my $opt = shift @opt ) {
if ( $opt =~ /^ -I (.*) $ /x ) {
push @libs, length($1) ? $1 : shift @opt;
}
else {
push @switches, $opt;
}
}
# Do things the old way on VMS...
push @libs, _filtered_inc_vms() if IS_VMS;
# If $Verbose isn't numeric default to 1. This helps core.
my $verbose
= $ENV{HARNESS_VERBOSE}
? $ENV{HARNESS_VERBOSE} !~ /\d/
? 1
: $ENV{HARNESS_VERBOSE}
: 0;
my %args = (
lib => \@libs,
timer => $ENV{HARNESS_TIMER} || 0,
switches => \@switches,
color => $ENV{HARNESS_COLOR} || 0,
verbosity => $verbose,
ignore_exit => $ENV{HARNESS_IGNORE_EXIT} || 0,
);
my $class = delete $input{harness_class} || $ENV{HARNESS_SUBCLASS} || 'TAP::Harness';
if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
for my $opt ( split /:/, $env_opt ) {
if ( $opt =~ /^j(\d*)$/ ) {
$args{jobs} = $1 || 9;
}
elsif ( $opt eq 'c' ) {
$args{color} = 1;
}
elsif ( $opt =~ m/^f(.*)$/ ) {
my $fmt = $1;
$fmt =~ s/-/::/g;
$args{formatter_class} = $fmt;
}
elsif ( $opt =~ m/^a(.*)$/ ) {
my $archive = $1;
$class = 'TAP::Harness::Archive';
$args{archive} = $archive;
}
else {
die "Unknown HARNESS_OPTIONS item: $opt\n";
}
}
}
return TAP::Object->_construct($class, { %args, %input });
}
1;
=head1 NAME
TAP::Harness::Env - Parsing harness related environmental variables where appropriate
=head1 VERSION
Version 3.42
=head1 SYNOPSIS
my $harness = TAP::Harness::Env->create(\%extra_args)
=head1 DESCRIPTION
This module implements the environmental variables that L<Test::Harness> uses with TAP::Harness, and instantiates the appropriate class with the appropriate arguments.
=head1 METHODS
=over 4
=item * create( \%args )
This function reads the environment and generates an appropriate argument hash from it. If given any arguments in C<%extra_args>, these will override the environmental defaults. In accepts C<harness_class> (which defaults to C<TAP::Harness>), and any argument the harness class accepts.
=back
=head1 ENVIRONMENTAL VARIABLES
=over 4
=item C<HARNESS_PERL_SWITCHES>
Setting this adds perl command line switches to each test file run.
For example, C<HARNESS_PERL_SWITCHES=-T> will turn on taint mode.
C<HARNESS_PERL_SWITCHES=-MDevel::Cover> will run C<Devel::Cover> for
each test.
=item C<HARNESS_VERBOSE>
If true, C<TAP::Harness> will output the verbose results of running
its tests.
=item C<HARNESS_SUBCLASS>
Specifies a TAP::Harness subclass to be used in place of TAP::Harness.
=item C<HARNESS_OPTIONS>
Provide additional options to the harness. Currently supported options are:
=over
=item C<< j<n> >>
Run <n> (default 9) parallel jobs.
=item C<< c >>
Try to color output. See L<TAP::Formatter::Base/"new">.
=item C<< a<file.tgz> >>
Will use L<TAP::Harness::Archive> as the harness class, and save the TAP to
C<file.tgz>
=item C<< fPackage-With-Dashes >>
Set the formatter_class of the harness being run. Since the C<HARNESS_OPTIONS>
is seperated by C<:>, we use C<-> instead.
=back
Multiple options may be separated by colons:
HARNESS_OPTIONS=j9:c make test
=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_COLOR>
Attempt to produce color output.
=item C<HARNESS_IGNORE_EXIT>
If set to a true value instruct C<TAP::Parser> to ignore exit and wait
status from test scripts.
=back
PK �[-26�� � Base.pmnu �[��� PK �[^Ȳ۱� �� 4 Parser.pmnu �[��� PK �[�d}a^. ^. � Formatter/Base.pmnu �[��� PK �[�7�R R � Formatter/File.pmnu �[��� PK �[�z1�� � P Formatter/Console.pmnu �[��� PK �[���| | _ Formatter/Session.pmnu �[��� PK �[�·�� � # Formatter/Console/Session.pmnu �[��� PK �[|0s W W $ 9 Formatter/Console/ParallelSession.pmnu �[��� PK �[E�Tb �I Formatter/Color.pmnu �[��� PK �[eSUp� � S Formatter/File/Session.pmnu �[��� PK �[�p p �[ Parser/Result/YAML.pmnu �[��� PK �[���� � �_ Parser/Result/Comment.pmnu �[��� PK �[�-�&� � �c Parser/Result/Pragma.pmnu �[��� PK �[k*r�| | �g Parser/Result/Bailout.pmnu �[��� PK �[��� �l Parser/Result/Plan.pmnu �[��� PK �[/�ߐ� � �t Parser/Result/Unknown.pmnu �[��� PK �[|Az�� � �w Parser/Result/Test.pmnu �[��� PK �[C;M� � � Parser/Result/Version.pmnu �[��� PK �[�$� � � Parser/Scheduler/Spinner.pmnu �[��� PK �[i"dj� � � Parser/Scheduler/Job.pmnu �[��� PK �[* H$ $ �� Parser/Aggregator.pmnu �[��� PK �[�=^2= 2= V� Parser/Grammar.pmnu �[��� PK �[!���� � � Parser/ResultFactory.pmnu �[��� PK �[i��O% O% � Parser/Source.pmnu �[��� PK �[ c5- - �8 Parser/Scheduler.pmnu �[��� PK �[r��^� � �e Parser/Multiplexer.pmnu �[��� PK �[I��ɳ � �v Parser/YAMLish/Reader.pmnu �[��� PK �[�J��s s Ô Parser/YAMLish/Writer.pmnu �[��� PK �[�V<L ~� Parser/Result.pmnu �[��� PK �[�yo^� � �� Parser/Iterator/Stream.pmnu �[��� PK �[�"i� � �� Parser/Iterator/Array.pmnu �[��� PK �[ ��# �# u� Parser/Iterator/Process.pmnu �[��� PK �[ � � [� Parser/Iterator.pmnu �[��� PK �[ '�� � S Parser/SourceHandler/File.pmnu �[��� PK �[KlJ[
[
P Parser/SourceHandler/Handle.pmnu �[��� PK �[�Y[ � Parser/SourceHandler/RawTAP.pmnu �[��� PK �[�M
v�$ �$ a" Parser/SourceHandler/Perl.pmnu �[��� PK �[�Z�� � " �G Parser/SourceHandler/Executable.pmnu �[��� PK �[���s s �W Parser/IteratorFactory.pmnu �[��� PK �[s厤" " ox Parser/SourceHandler.pmnu �[��� PK �[�ֈ
�
، Object.pmnu �[��� PK �[�}�Nq Nq
�� Harness.pmnu �[��� PK �[�[q�< �< ! Harness/Beyond.podnu �[��� PK �[���J( ( @F Harness/Env.pmnu �[��� PK , , � �[