Initial Commit
This commit is contained in:
Riley Schneider
133
database/perl/lib/TAP/Base.pm
Normal file
133
database/perl/lib/TAP/Base.pm
Normal file
@@ -0,0 +1,133 @@
|
||||
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;
|
||||
467
database/perl/lib/TAP/Formatter/Base.pm
Normal file
467
database/perl/lib/TAP/Formatter/Base.pm
Normal file
@@ -0,0 +1,467 @@
|
||||
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;
|
||||
116
database/perl/lib/TAP/Formatter/Color.pm
Normal file
116
database/perl/lib/TAP/Formatter/Color.pm
Normal file
@@ -0,0 +1,116 @@
|
||||
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;
|
||||
100
database/perl/lib/TAP/Formatter/Console.pm
Normal file
100
database/perl/lib/TAP/Formatter/Console.pm
Normal file
@@ -0,0 +1,100 @@
|
||||
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;
|
||||
201
database/perl/lib/TAP/Formatter/Console/ParallelSession.pm
Normal file
201
database/perl/lib/TAP/Formatter/Console/ParallelSession.pm
Normal file
@@ -0,0 +1,201 @@
|
||||
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;
|
||||
205
database/perl/lib/TAP/Formatter/Console/Session.pm
Normal file
205
database/perl/lib/TAP/Formatter/Console/Session.pm
Normal file
@@ -0,0 +1,205 @@
|
||||
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;
|
||||
56
database/perl/lib/TAP/Formatter/File.pm
Normal file
56
database/perl/lib/TAP/Formatter/File.pm
Normal file
@@ -0,0 +1,56 @@
|
||||
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;
|
||||
95
database/perl/lib/TAP/Formatter/File/Session.pm
Normal file
95
database/perl/lib/TAP/Formatter/File/Session.pm
Normal file
@@ -0,0 +1,95 @@
|
||||
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;
|
||||
220
database/perl/lib/TAP/Formatter/Session.pm
Normal file
220
database/perl/lib/TAP/Formatter/Session.pm
Normal file
@@ -0,0 +1,220 @@
|
||||
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;
|
||||
1054
database/perl/lib/TAP/Harness.pm
Normal file
1054
database/perl/lib/TAP/Harness.pm
Normal file
File diff suppressed because it is too large
Load Diff
426
database/perl/lib/TAP/Harness/Beyond.pod
Normal file
426
database/perl/lib/TAP/Harness/Beyond.pod
Normal file
@@ -0,0 +1,426 @@
|
||||
=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/>
|
||||
215
database/perl/lib/TAP/Harness/Env.pm
Normal file
215
database/perl/lib/TAP/Harness/Env.pm
Normal file
@@ -0,0 +1,215 @@
|
||||
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
|
||||
155
database/perl/lib/TAP/Object.pm
Normal file
155
database/perl/lib/TAP/Object.pm
Normal file
@@ -0,0 +1,155 @@
|
||||
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;
|
||||
|
||||
1931
database/perl/lib/TAP/Parser.pm
Normal file
1931
database/perl/lib/TAP/Parser.pm
Normal file
File diff suppressed because it is too large
Load Diff
414
database/perl/lib/TAP/Parser/Aggregator.pm
Normal file
414
database/perl/lib/TAP/Parser/Aggregator.pm
Normal file
@@ -0,0 +1,414 @@
|
||||
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;
|
||||
584
database/perl/lib/TAP/Parser/Grammar.pm
Normal file
584
database/perl/lib/TAP/Parser/Grammar.pm
Normal file
@@ -0,0 +1,584 @@
|
||||
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
|
||||
162
database/perl/lib/TAP/Parser/Iterator.pm
Normal file
162
database/perl/lib/TAP/Parser/Iterator.pm
Normal file
@@ -0,0 +1,162 @@
|
||||
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
|
||||
|
||||
100
database/perl/lib/TAP/Parser/Iterator/Array.pm
Normal file
100
database/perl/lib/TAP/Parser/Iterator/Array.pm
Normal file
@@ -0,0 +1,100 @@
|
||||
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
|
||||
|
||||
378
database/perl/lib/TAP/Parser/Iterator/Process.pm
Normal file
378
database/perl/lib/TAP/Parser/Iterator/Process.pm
Normal file
@@ -0,0 +1,378 @@
|
||||
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
|
||||
|
||||
116
database/perl/lib/TAP/Parser/Iterator/Stream.pm
Normal file
116
database/perl/lib/TAP/Parser/Iterator/Stream.pm
Normal file
@@ -0,0 +1,116 @@
|
||||
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
|
||||
|
||||
339
database/perl/lib/TAP/Parser/IteratorFactory.pm
Normal file
339
database/perl/lib/TAP/Parser/IteratorFactory.pm
Normal file
@@ -0,0 +1,339 @@
|
||||
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
|
||||
|
||||
194
database/perl/lib/TAP/Parser/Multiplexer.pm
Normal file
194
database/perl/lib/TAP/Parser/Multiplexer.pm
Normal file
@@ -0,0 +1,194 @@
|
||||
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;
|
||||
297
database/perl/lib/TAP/Parser/Result.pm
Normal file
297
database/perl/lib/TAP/Parser/Result.pm
Normal file
@@ -0,0 +1,297 @@
|
||||
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
|
||||
62
database/perl/lib/TAP/Parser/Result/Bailout.pm
Normal file
62
database/perl/lib/TAP/Parser/Result/Bailout.pm
Normal file
@@ -0,0 +1,62 @@
|
||||
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;
|
||||
60
database/perl/lib/TAP/Parser/Result/Comment.pm
Normal file
60
database/perl/lib/TAP/Parser/Result/Comment.pm
Normal file
@@ -0,0 +1,60 @@
|
||||
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;
|
||||
119
database/perl/lib/TAP/Parser/Result/Plan.pm
Normal file
119
database/perl/lib/TAP/Parser/Result/Plan.pm
Normal file
@@ -0,0 +1,119 @@
|
||||
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;
|
||||
62
database/perl/lib/TAP/Parser/Result/Pragma.pm
Normal file
62
database/perl/lib/TAP/Parser/Result/Pragma.pm
Normal file
@@ -0,0 +1,62 @@
|
||||
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;
|
||||
271
database/perl/lib/TAP/Parser/Result/Test.pm
Normal file
271
database/perl/lib/TAP/Parser/Result/Test.pm
Normal file
@@ -0,0 +1,271 @@
|
||||
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;
|
||||
48
database/perl/lib/TAP/Parser/Result/Unknown.pm
Normal file
48
database/perl/lib/TAP/Parser/Result/Unknown.pm
Normal file
@@ -0,0 +1,48 @@
|
||||
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;
|
||||
62
database/perl/lib/TAP/Parser/Result/Version.pm
Normal file
62
database/perl/lib/TAP/Parser/Result/Version.pm
Normal file
@@ -0,0 +1,62 @@
|
||||
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;
|
||||
61
database/perl/lib/TAP/Parser/Result/YAML.pm
Normal file
61
database/perl/lib/TAP/Parser/Result/YAML.pm
Normal file
@@ -0,0 +1,61 @@
|
||||
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;
|
||||
183
database/perl/lib/TAP/Parser/ResultFactory.pm
Normal file
183
database/perl/lib/TAP/Parser/ResultFactory.pm
Normal file
@@ -0,0 +1,183 @@
|
||||
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
|
||||
448
database/perl/lib/TAP/Parser/Scheduler.pm
Normal file
448
database/perl/lib/TAP/Parser/Scheduler.pm
Normal file
@@ -0,0 +1,448 @@
|
||||
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;
|
||||
127
database/perl/lib/TAP/Parser/Scheduler/Job.pm
Normal file
127
database/perl/lib/TAP/Parser/Scheduler/Job.pm
Normal file
@@ -0,0 +1,127 @@
|
||||
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;
|
||||
61
database/perl/lib/TAP/Parser/Scheduler/Spinner.pm
Normal file
61
database/perl/lib/TAP/Parser/Scheduler/Spinner.pm
Normal file
@@ -0,0 +1,61 @@
|
||||
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;
|
||||
381
database/perl/lib/TAP/Parser/Source.pm
Normal file
381
database/perl/lib/TAP/Parser/Source.pm
Normal file
@@ -0,0 +1,381 @@
|
||||
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
|
||||
191
database/perl/lib/TAP/Parser/SourceHandler.pm
Normal file
191
database/perl/lib/TAP/Parser/SourceHandler.pm
Normal file
@@ -0,0 +1,191 @@
|
||||
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
|
||||
|
||||
184
database/perl/lib/TAP/Parser/SourceHandler/Executable.pm
Normal file
184
database/perl/lib/TAP/Parser/SourceHandler/Executable.pm
Normal file
@@ -0,0 +1,184 @@
|
||||
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
|
||||
136
database/perl/lib/TAP/Parser/SourceHandler/File.pm
Normal file
136
database/perl/lib/TAP/Parser/SourceHandler/File.pm
Normal file
@@ -0,0 +1,136 @@
|
||||
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
|
||||
124
database/perl/lib/TAP/Parser/SourceHandler/Handle.pm
Normal file
124
database/perl/lib/TAP/Parser/SourceHandler/Handle.pm
Normal file
@@ -0,0 +1,124 @@
|
||||
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
|
||||
370
database/perl/lib/TAP/Parser/SourceHandler/Perl.pm
Normal file
370
database/perl/lib/TAP/Parser/SourceHandler/Perl.pm
Normal file
@@ -0,0 +1,370 @@
|
||||
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
|
||||
130
database/perl/lib/TAP/Parser/SourceHandler/RawTAP.pm
Normal file
130
database/perl/lib/TAP/Parser/SourceHandler/RawTAP.pm
Normal file
@@ -0,0 +1,130 @@
|
||||
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
|
||||
332
database/perl/lib/TAP/Parser/YAMLish/Reader.pm
Normal file
332
database/perl/lib/TAP/Parser/YAMLish/Reader.pm
Normal file
@@ -0,0 +1,332 @@
|
||||
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
|
||||
|
||||
254
database/perl/lib/TAP/Parser/YAMLish/Writer.pm
Normal file
254
database/perl/lib/TAP/Parser/YAMLish/Writer.pm
Normal file
@@ -0,0 +1,254 @@
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user