From 6d3136644eb73f7a0727d341c90937f4234835bf Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Tue, 29 Jun 2010 10:16:45 +0100 Subject: Update Test-Harness to CPAN version 3.21 Mark UPSTREAM as 'cpan' in Maintainers.pl [DELTA] 3.21 2010-01-30 - Add test to ensure we're not depending on a module we no longer ship. - Fix up skip counts for Windows case - tests were failing on Windows. 3.20 2010-01-22 - Remove references / dependency on TAP::Parser::Source::Perl 3.19 2010-01-20 - Avoid depending on Module::Build. The resulting circular dependency made it impossible to install Test::Harness and/or Module::Build in some cases. 3.18 2010-01-19 - Handle the case where the filename of the perl executable contains space. Thanks to kmx. - Various documentation fixes. 3.17_04 2010-01-04 - Fix failures due to unknown location of Perl in t/source_handler.t. - Use EUMM style shebang magic to produce an executable 'psql' for t/source_handler.t. 3.17_03 2009-11-19 - Fix failures due to over-strict assertions in t/source.t. 3.17_02 2009-11-17 - Merge in Steve's missing changes. Oops. 3.17_01 2009-11-17 - Re-engineered source handling API to allow users to configure how TAP is sourced by the parser. Introduced a new 'sources' param to TAP::Harness, and new options to prove, eg: prove --source XYZ --xyz-option foo=bar The new TAP::Parser::SourceHandler API makes it much easier to write plugins. This breaks backwards compatibility for plugins & extenstions that rely on the following APIs: TAP::Parser::Source TAP::Parser::SourceFactory TAP::Parser::IteratorFactory TAP::Parser, specifically: new: 'source' & 'tap' params source_class perl_source_class iterator_factory_class make_source make_perl_source make_iterator Please see the TAP::Parser docs for more details. [Steve Purkis & David Wheeler] - Removed dependency on File::Spec [Schwern] - Made it possible to pass different args to each test [Lee Johnson] - Added HARNESS_SUBCLASS option to Test::Harness - Added TAP::Parser::SourceHandler::File which lets you to stream TAP from a text file (eg: *.tap). - Added TAP::Parser::SourceHandler::pgTAP. All the source handlers are new, but this is the only one to add major new functioality: the ability to run pgTAP tests (http://pgtap.projects.postgresql.org/). --- cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm | 10 +- cpan/Test-Harness/lib/TAP/Parser/Grammar.pm | 44 +-- cpan/Test-Harness/lib/TAP/Parser/Iterator.pm | 16 +- cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm | 14 +- .../lib/TAP/Parser/Iterator/Process.pm | 34 +- .../Test-Harness/lib/TAP/Parser/Iterator/Stream.pm | 14 +- .../Test-Harness/lib/TAP/Parser/IteratorFactory.pm | 327 +++++++++++++----- cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm | 6 +- cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm | 4 +- .../lib/TAP/Parser/Scheduler/Spinner.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Source.pm | 374 ++++++++++++++++----- cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm | 326 ------------------ cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm | 194 +++++++++++ .../lib/TAP/Parser/SourceHandler/Executable.pm | 185 ++++++++++ .../lib/TAP/Parser/SourceHandler/File.pm | 136 ++++++++ .../lib/TAP/Parser/SourceHandler/Handle.pm | 125 +++++++ .../lib/TAP/Parser/SourceHandler/Perl.pm | 310 +++++++++++++++++ .../lib/TAP/Parser/SourceHandler/RawTAP.pm | 131 ++++++++ .../lib/TAP/Parser/SourceHandler/pgTAP.pm | 253 ++++++++++++++ cpan/Test-Harness/lib/TAP/Parser/Utils.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm | 6 +- cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm | 4 +- 33 files changed, 1977 insertions(+), 588 deletions(-) delete mode 100644 cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm create mode 100644 cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm create mode 100644 cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm create mode 100644 cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm create mode 100644 cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm create mode 100644 cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm create mode 100644 cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm create mode 100644 cpan/Test-Harness/lib/TAP/Parser/SourceHandler/pgTAP.pm (limited to 'cpan/Test-Harness/lib/TAP/Parser') diff --git a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm index 10b37ef72a..931656fdc9 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm @@ -14,11 +14,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS @@ -74,7 +74,7 @@ BEGIN { # install summary methods $SUMMARY_METHOD_FOR{total} = 'tests_run'; $SUMMARY_METHOD_FOR{planned} = 'tests_planned'; - foreach my $method ( keys %SUMMARY_METHOD_FOR ) { + for my $method ( keys %SUMMARY_METHOD_FOR ) { next if 'total' eq $method; no strict 'refs'; *$method = sub { @@ -90,7 +90,7 @@ sub _initialize { my ($self) = @_; $self->{parser_for} = {}; $self->{parse_order} = []; - foreach my $summary ( keys %SUMMARY_METHOD_FOR ) { + for my $summary ( keys %SUMMARY_METHOD_FOR ) { $self->{$summary} = 0; next if 'total' eq $summary; $self->{"descriptions_for_$summary"} = []; @@ -175,7 +175,7 @@ sub parsers { sub _get_parsers { my ( $self, @descriptions ) = @_; my @parsers; - foreach my $description (@descriptions) { + 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}; diff --git a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm index 44f28a0491..7847098c5c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm @@ -15,27 +15,27 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS use TAP::Parser::Grammar; my $grammar = $self->make_grammar({ - stream => $tap_parser_stream, - parser => $tap_parser, - version => 12, + iterator => $tap_parser_iterator, + parser => $tap_parser, + version => 12, }); my $result = $grammar->tokenize; =head1 DESCRIPTION -C tokenizes lines from a TAP stream and constructs -L subclasses to represent the tokens. +C tokenizes lines from a L and +constructs L 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 @@ -49,22 +49,24 @@ parser). =head3 C my $grammar = TAP::Parser::Grammar->new({ - stream => $stream, - parser => $parser, - version => $version, + iterator => $iterator, + parser => $parser, + version => $version, }); -Returns L grammar object that will parse the specified stream. -Both C and C are required arguments. If C is not set -it defaults to C<12> (see L for more details). +Returns L grammar object that will parse the TAP stream from the +specified iterator. Both C and C are required arguments. +If C is not set it defaults to C<12> (see L for more +details). =cut # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $args ) = @_; - $self->{stream} = $args->{stream}; # TODO: accessor - $self->{parser} = $args->{parser}; # TODO: accessor + $self->{iterator} = $args->{iterator}; # TODO: accessor + $self->{iterator} ||= $args->{stream}; # deprecated + $self->{parser} = $args->{parser}; # TODO: accessor $self->set_version( $args->{version} || 12 ); return $self; } @@ -218,7 +220,7 @@ my %language_for; '13' => { tokens => \%v13, setup => sub { - shift->{stream}->handle_unicode; + shift->{iterator}->handle_unicode; }, }, ); @@ -284,7 +286,7 @@ current line of TAP. sub tokenize { my $self = shift; - my $line = $self->{stream}->next; + my $line = $self->{iterator}->next; unless ( defined $line ) { delete $self->{parser}; # break circular ref return; @@ -292,7 +294,7 @@ sub tokenize { my $token; - foreach my $token_data ( @{ $self->{ordered_tokens} } ) { + for my $token_data ( @{ $self->{ordered_tokens} } ) { if ( $line =~ $token_data->{syntax} ) { my $handler = $token_data->{handler}; $token = $self->$handler($line); @@ -351,7 +353,7 @@ TAP parsing loop looks similar to the following: my @tokens; my $grammar = TAP::Grammar->new; LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) { - foreach my $type ( $grammar->token_types ) { + for my $type ( $grammar->token_types ) { my $syntax = $grammar->syntax_for($type); if ( $line =~ $syntax ) { my $handler = $grammar->handler_for($type); @@ -443,7 +445,7 @@ sub _make_yaml_token { my $yaml = TAP::Parser::YAMLish::Reader->new; - my $stream = $self->{stream}; + my $iterator = $self->{iterator}; # Construct a reader that reads from our input stripping leading # spaces from each line. @@ -452,7 +454,7 @@ sub _make_yaml_token { my @extra = ($marker); my $reader = sub { return shift @extra if @extra; - my $line = $stream->next; + my $line = $iterator->next; return $2 if $line =~ $strip; return; }; diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm index 09d40bebcc..a6d8916751 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm @@ -9,20 +9,18 @@ use TAP::Object (); =head1 NAME -TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators +TAP::Parser::Iterator - Base class for TAP source iterators =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # see TAP::Parser::IteratorFactory for general usage - # to subclass: use vars qw(@ISA); use TAP::Parser::Iterator (); @@ -31,11 +29,14 @@ $VERSION = '3.17'; # see TAP::Object... } + sub next_raw { ... } + sub wait { ... } + sub exit { ... } + =head1 DESCRIPTION This is a simple iterator base class that defines L's iterator -API. See C for the preferred way of creating -iterators. +API. Iterators are typically created from Ls. =head1 METHODS @@ -156,7 +157,6 @@ There's not much point repeating it here. L, L, -L, L, L, L, diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm index 1513d5b994..99d98ca172 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm @@ -9,21 +9,18 @@ use TAP::Parser::Iterator (); =head1 NAME -TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator +TAP::Parser::Iterator::Array - Iterator for array-based TAP sources =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # see TAP::Parser::IteratorFactory for preferred usage - - # to use directly: use TAP::Parser::Iterator::Array; my @data = ('foo', 'bar', baz'); my $it = TAP::Parser::Iterator::Array->new(\@data); @@ -32,8 +29,8 @@ $VERSION = '3.17'; =head1 DESCRIPTION This is a simple iterator wrapper for arrays of scalar content, used by -L. Unless you're subclassing, you probably won't need to use -this module directly. +L. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. =head1 METHODS @@ -100,7 +97,6 @@ Originally ripped off from L. L, L, L, -L, =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm index a0a5a8ed32..2621e75ef2 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm @@ -13,21 +13,18 @@ my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); =head1 NAME -TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator +TAP::Parser::Iterator::Process - Iterator for proccess-based TAP sources =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # see TAP::Parser::IteratorFactory for preferred usage - - # to use directly: use TAP::Parser::Iterator::Process; my %args = ( command => ['python', 'setup.py', 'test'], @@ -41,8 +38,8 @@ $VERSION = '3.17'; =head1 DESCRIPTION This is a simple iterator wrapper for executing external processes, used by -L. Unless you're subclassing, you probably won't need to use -this module directly. +L. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. =head1 METHODS @@ -80,12 +77,18 @@ Get the exit status for this iterator's process. =cut -eval { require POSIX; &POSIX::WEXITSTATUS(0) }; -if ($@) { - *_wait2exit = sub { $_[1] >> 8 }; -} -else { - *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) } +{ + + local $^W; # no warnings + # 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 { @@ -117,6 +120,8 @@ sub _initialize { 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; @@ -371,7 +376,6 @@ Originally ripped off from L. L, L, L, -L, =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm index c92cbabe08..d905695859 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm @@ -9,21 +9,18 @@ use TAP::Parser::Iterator (); =head1 NAME -TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator +TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # see TAP::Parser::IteratorFactory for preferred usage - - # to use directly: use TAP::Parser::Iterator::Stream; open( TEST, 'test.tap' ); my $it = TAP::Parser::Iterator::Stream->new(\*TEST); @@ -32,8 +29,8 @@ $VERSION = '3.17'; =head1 DESCRIPTION This is a simple iterator wrapper for reading from filehandles, used by -L. Unless you're subclassing, you probably won't need to use -this module directly. +L. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. =head1 METHODS @@ -106,7 +103,6 @@ Originally ripped off from L. L, L, L, -L, =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm index 064d7beb16..b269d000b9 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm @@ -3,40 +3,40 @@ package TAP::Parser::IteratorFactory; use strict; use vars qw($VERSION @ISA); -use TAP::Object (); -use TAP::Parser::Iterator::Array (); -use TAP::Parser::Iterator::Stream (); -use TAP::Parser::Iterator::Process (); +use TAP::Object (); + +use Carp qw( confess ); +use File::Basename qw( fileparse ); @ISA = qw(TAP::Object); +use constant handlers => []; + =head1 NAME -TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator +TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS use TAP::Parser::IteratorFactory; - my $factory = TAP::Parser::IteratorFactory->new; - my $iter = $factory->make_iterator(\*TEST); - my $iter = $factory->make_iterator(\@array); - my $iter = $factory->make_iterator(\%hash); - - my $line = $iter->next; + my $factory = TAP::Parser::IteratorFactory->new({ %config }); + my $iterator = $factory->make_iterator( $filename ); =head1 DESCRIPTION -This is a factory class for simple iterator wrappers for arrays, filehandles, -and hashes. Unless you're subclassing, you probably won't need to use this -module directly. +This is a factory class that takes a L and runs it through all the +registered Ls to see which one should handle the source. + +If you're a plugin author, you'll be interested in how to Ls, +how L works. =head1 METHODS @@ -44,128 +44,299 @@ module directly. =head3 C -Creates a new factory class. -I You currently don't need to instantiate a factory in order to use it. +Creates a new factory class: -=head3 C + my $sf = TAP::Parser::IteratorFactory->new( $config ); -Create an iterator. The type of iterator created depends on the arguments to -the constructor: +C<$config> is optional. If given, sets L and calls L. - my $iter = TAP::Parser::Iterator->make_iterator( $filehandle ); +=cut + +sub _initialize { + my ( $self, $config ) = @_; + $self->config( $config || {} )->load_handlers; + return $self; +} -Creates a I iterator (see L). +=head3 C - my $iter = TAP::Parser::Iterator->make_iterator( $array_reference ); +Registers a new L with this factory. -Creates an I iterator (see L). + __PACKAGE__->register_handler( $handler_class ); - my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference ); +=head3 C -Creates a I iterator (see L). +List of handlers that have been registered. =cut -sub make_iterator { - my ( $proto, $thing ) = @_; +sub register_handler { + my ( $class, $dclass ) = @_; - my $ref = ref $thing; - if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) { - return $proto->make_stream_iterator($thing); - } - elsif ( $ref eq 'ARRAY' ) { - return $proto->make_array_iterator($thing); - } - elsif ( $ref eq 'HASH' ) { - return $proto->make_process_iterator($thing); - } - else { - die "Can't iterate with a $ref"; + 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 + + 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 +############################################################################## + +=head3 C + + $sf->load_handlers; -Make a new stream iterator and return it. Passes through any arguments given. -Defaults to a L. +Loads the handler classes defined in L. For example, given a config: -=head3 C + $sf->config({ + MySourceHandler => { some => 'config' }, + }); -Make a new array iterator and return it. Passes through any arguments given. -Defaults to a L. +C will attempt to load the C class by looking in +C<@INC> for it in this order: -=head3 C + TAP::Parser::SourceHandler::MySourceHandler + MySourceHandler -Make a new process iterator and return it. Passes through any arguments given. -Defaults to a L. +Cs on error. =cut -sub make_stream_iterator { - my $proto = shift; - TAP::Parser::Iterator::Stream->new(@_); +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 make_array_iterator { - my $proto = shift; - TAP::Parser::Iterator::Array->new(@_); +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 ) ); } -sub make_process_iterator { - my $proto = shift; - TAP::Parser::Iterator::Process->new(@_); +############################################################################## + +=head3 C + + my $iterator = $src_factory->make_iterator( $source ); + +Given a L, finds the most suitable L +to use to create a L (see L). 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; } -1; +=head3 C -=head1 SUBCLASSING +Given a L, detects what kind of source it is and +returns I L (the most confident one). Dies +on error. -Please see L for a subclassing overview. +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 ) = @_; -There are a few things to bear in mind when creating your own -C: + confess('no raw source ref defined!') unless defined $source->raw; -=over 4 + # find a list of handlers that can handle this source: + my %handlers; + for my $dclass ( @{ $self->handlers } ) { + my $confidence = $dclass->can_handle($source); -=item 1 + # warn "handler: $dclass: $confidence\n"; + $handlers{$dclass} = $confidence if $confidence; + } + + if ( !%handlers ) { + + # use Data::Dump qw( pp ); + # warn pp( $meta ); + + # error: can't detect source + my $raw_source_short = substr( ${ $source->raw }, 0, 50 ); + confess("Cannot detect source of '$raw_source_short'!"); + return; + } -The factory itself is never instantiated (this I change in the future). -This means that C<_initialize> is never called. + # if multiple handlers can handle it, choose the most confident one + my @handlers = ( + map {$_} + sort { $handlers{$a} cmp $handlers{$b} } + keys %handlers + ); + + # this is really useful for debugging handlers: + if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) { + warn( + "votes: ", + join( ', ', map {"$_: $handlers{$_}"} @handlers ), + "\n" + ); + } + + # return 1st + return pop @handlers; +} + +1; -=back +__END__ + +=head1 SUBCLASSING + +Please see L 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 for that). + +But in case you find the need to... + package MyIteratorFactory; use strict; use vars '@ISA'; - use MyStreamIterator; use TAP::Parser::IteratorFactory; @ISA = qw( TAP::Parser::IteratorFactory ); - # override stream iterator - sub make_stream_iterator { - my $proto = shift; - MyStreamIterator->new(@_); + # 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. +Moved out of L & converted to a factory class to support +extensible TAP source detective work by Steve Purkis. + =head1 SEE ALSO L, L, -L, -L, -L, -L, +L, +L, +L, +L, +L, +L =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm index 2e5d929688..9d33619294 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm @@ -18,11 +18,11 @@ TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result.pm b/cpan/Test-Harness/lib/TAP/Parser/Result.pm index b01e95c5d9..44287e89a8 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result.pm @@ -26,11 +26,11 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm index 3e42f4110f..8aeecfa29c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm index 1e9ba13c5f..b5498abd5d 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm index 67c01df200..78b77c35a1 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm index 3eb62b3322..bef77fda71 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm index 11cf302de6..fcae343266 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm index 52e19585d9..b08536e267 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm index b97681eb06..06d63bf1ae 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm index ada3ae445b..aa7bc4c887 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm index 46d0df29db..66ee9fb36f 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm @@ -30,11 +30,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head2 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm index f1817093af..c23f1eac64 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm @@ -12,11 +12,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS @@ -231,7 +231,7 @@ sub get_job { sub _not_empty { my $ar = shift; return 1 unless 'ARRAY' eq ref $ar; - foreach (@$ar) { + for (@$ar) { return 1 if _not_empty($_); } return; diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm index 7ab68f9f67..f3a377cc1e 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm index 10af5e3369..0d43716842 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Source.pm b/cpan/Test-Harness/lib/TAP/Parser/Source.pm index 9263e9e544..62d3795f02 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Source.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Source.pm @@ -3,35 +3,49 @@ package TAP::Parser::Source; use strict; use vars qw($VERSION @ISA); -use TAP::Object (); -use TAP::Parser::IteratorFactory (); +use TAP::Object (); +use File::Basename qw( fileparse ); @ISA = qw(TAP::Object); -# Causes problem on MacOS and shouldn't be necessary anyway -#$SIG{CHLD} = sub { wait }; - =head1 NAME -TAP::Parser::Source - Stream output from some source +TAP::Parser::Source - a TAP source & meta data about it =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS use TAP::Parser::Source; my $source = TAP::Parser::Source->new; - my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream; + $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 -Takes a command and hopefully returns a stream from it. +A TAP I 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. Cs encapsulate these I sources, and +provide some useful meta data about them. They are used by +Ls, which do whatever is required to produce & +capture a stream of TAP from the I source, and package it up in a +L for the parser to consume. + +Unless you're writing a new L, a plugin or +subclassing L, you probably won't need to use this module directly. =head1 METHODS @@ -48,10 +62,9 @@ Returns a new C object. # new() implementation supplied by TAP::Object sub _initialize { - my ( $self, $args ) = @_; - $self->{switches} = []; - _autoflush( \*STDOUT ); - _autoflush( \*STDERR ); + my ($self) = @_; + $self->meta( {} ); + $self->config( {} ); return $self; } @@ -59,69 +72,86 @@ sub _initialize { =head2 Instance Methods -=head3 C +=head3 C - my $source = $source->source; - $source->source(['./some_prog some_test_file']); + my $raw = $source->raw; + $source->raw( $some_value ); - # or - $source->source(['/usr/bin/ruby', 't/ruby_test.rb']); +Chaining getter/setter for the raw TAP source. This is a reference, as it may +contain large amounts of data (eg: raw TAP). -Getter/setter for the source. The source should generally consist of an array -reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>, -should return a filehandle which returns successive rows of TAP. C if -it doesn't get an arrayref. +=head3 C -=cut + my $meta = $source->meta; + $source->meta({ %some_value }); -sub source { - my $self = shift; - return $self->{source} unless @_; - unless ( 'ARRAY' eq ref $_[0] ) { - $self->_croak('Argument to &source must be an array reference'); - } - $self->{source} = shift; - return $self; -} +Chaining getter/setter for meta data about the source. This defaults to an +empty hashref. See L for more info. -############################################################################## +=head3 C -=head3 C +True if the source has meta data. - my $stream = $source->get_stream; +=head3 C -Returns a L stream of the output generated by executing -C. Cs if there was no command found. + my $config = $source->config; + $source->config({ %some_value }); -Must be passed an object that implements a C method. -Typically this is a TAP::Parser instance. +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 for more info. -=cut +=head3 C -sub get_stream { - my ( $self, $factory ) = @_; - my @command = $self->_get_command - or $self->_croak('No command found!'); + my $merge = $source->merge; + $source->config( $bool ); - return $factory->make_iterator( - { command => \@command, - merge => $self->merge - } - ); -} +Chaining getter/setter for the flag that dictates whether STDOUT and STDERR +should be merged (where appropriate). Defaults to undef. -sub _get_command { return @{ shift->source || [] } } +=head3 C -############################################################################## + my $switches = $source->switches; + $source->config([ @switches ]); -=head3 C +Chaining getter/setter for the list of command-line switches that should be +passed to the source (where appropriate). Defaults to undef. - my $merge = $source->merge; +=head3 C + + my $test_args = $source->test_args; + $source->config([ @test_args ]); -Sets or returns the flag that dictates whether STDOUT and STDERR are merged. +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 @_; @@ -129,45 +159,227 @@ sub merge { return $self; } -# Turns on autoflush for the handle passed -sub _autoflush { - my $flushed = shift; - my $old_fh = select $flushed; - $| = 1; - select $old_fh; +sub switches { + my $self = shift; + return $self->{switches} unless @_; + $self->{switches} = shift; + return $self; } -1; +sub test_args { + my $self = shift; + return $self->{test_args} unless @_; + $self->{test_args} = shift; + return $self; +} + +=head3 C + + my $meta = $source->assemble_meta; + +Gathers meta data about the L source, stashes it in L and returns +it as a hashref. This is done so that the Ls 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, + } -=head1 SUBCLASSING + # for arrays: + size => $n, -Please see L for a subclassing overview. +=cut -=head2 Example +sub assemble_meta { + my ($self) = @_; - package MyRubySource; + return $self->meta if $self->has_meta; - use strict; - use vars '@ISA'; + my $meta = $self->meta; + my $raw = $self->raw; - use Carp qw( croak ); - use TAP::Parser::Source; + # 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->{text} and $file->{read} ) { + eval { $file->{shebang} = $self->_read_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 + +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; - @ISA = qw( TAP::Parser::Source ); + sub _read_shebang { + my ( $self, $file ) = @_; + my $shebang; + local *TEST; + if ( open( TEST, $file ) ) { + $shebang = ; + chomp $shebang; + close(TEST) or die "Can't close $file. $!\n"; + } + else { + die "Can't open $file. $!\n"; + } + return $shebang; + } + + sub shebang { + my ( $class, $file ) = @_; + $shebang_for{$file} = $class->_read_shebang($file) + unless exists $shebang_for{$file}; + return $shebang_for{$file}; + } +} + +=head3 C + + my $config = $source->config_for( $class ); + +Returns L 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' ); - # expect $source->(['mytest.rb', 'cmdline', 'args']); - sub source { - my ($self, $args) = @_; - my ($rb_file) = @$args; - croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file); - return $self->SUPER::source(['/usr/bin/ruby', @$args]); - } +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, L, -L, +L, +L =cut - diff --git a/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm b/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm deleted file mode 100644 index 1f4f2e1428..0000000000 --- a/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm +++ /dev/null @@ -1,326 +0,0 @@ -package TAP::Parser::Source::Perl; - -use strict; -use Config; -use vars qw($VERSION @ISA); - -use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); -use constant IS_VMS => ( $^O eq 'VMS' ); - -use TAP::Parser::Source; -use TAP::Parser::Utils qw( split_shell ); - -@ISA = 'TAP::Parser::Source'; - -=head1 NAME - -TAP::Parser::Source::Perl - Stream Perl output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Source::Perl; - my $perl = TAP::Parser::Source::Perl->new; - my $stream = $perl->source( [ $filename, @args ] )->get_stream; - -=head1 DESCRIPTION - -Takes a filename and hopefully returns a stream from it. The filename should -be the name of a Perl program. - -Note that this is a subclass of L. See that module for -more methods. - -=head1 METHODS - -=head2 Class Methods - -=head3 C - - my $perl = TAP::Parser::Source::Perl->new; - -Returns a new C object. - -=head2 Instance Methods - -=head3 C - -Getter/setter the name of the test program and any arguments it requires. - - my ($filename, @args) = @{ $perl->source }; - $perl->source( [ $filename, @args ] ); - -Cs if C<$filename> could not be found. - -=cut - -sub source { - my $self = shift; - $self->_croak("Cannot find ($_[0][0])") - if @_ && !-f $_[0][0]; - return $self->SUPER::source(@_); -} - -=head3 C - - my $switches = $perl->switches; - my @switches = $perl->switches; - $perl->switches( \@switches ); - -Getter/setter for the additional switches to pass to the perl executable. One -common switch would be to set an include directory: - - $perl->switches( ['-Ilib'] ); - -=cut - -sub switches { - my $self = shift; - unless (@_) { - return wantarray ? @{ $self->{switches} } : $self->{switches}; - } - my $switches = shift; - $self->{switches} = [@$switches]; # force a copy - return $self; -} - -############################################################################## - -=head3 C - - my $stream = $source->get_stream($parser); - -Returns a stream of the output generated by executing C. Must be -passed an object that implements a C method. Typically -this is a TAP::Parser instance. - -=cut - -sub get_stream { - my ( $self, $factory ) = @_; - - my @switches = $self->_switches; - my $path_sep = $Config{path_sep}; - my $path_pat = qr{$path_sep}; - - # Filter out any -I switches to be handled as libs later. - # - # Nasty kludge. It might be nicer if we got the libs separately - # although at least this way we find any -I switches that were - # supplied other then as explicit libs. - # - # We filter out any names containing colons because they will break - # PERL5LIB - my @libs; - my @filtered_switches; - for (@switches) { - if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { - push @libs, $1; - } - else { - push @filtered_switches, $_; - } - } - @switches = @filtered_switches; - - my $setup = sub { - if (@libs) { - $ENV{PERL5LIB} - = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); - } - }; - - # Cargo culted from comments seen elsewhere about VMS / environment - # variables. I don't know if this is actually necessary. - my $previous = $ENV{PERL5LIB}; - my $teardown = sub { - if ( defined $previous ) { - $ENV{PERL5LIB} = $previous; - } - else { - delete $ENV{PERL5LIB}; - } - }; - - # Taint mode ignores environment variables so we must retranslate - # PERL5LIB as -I switches and place PERL5OPT on the command line - # in order that it be seen. - if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { - push @switches, $self->_libs2switches(@libs); - push @switches, split_shell( $ENV{PERL5OPT} ); - } - - my @command = $self->_get_command_for_switches(@switches) - or $self->_croak("No command found!"); - - return $factory->make_iterator( - { command => \@command, - merge => $self->merge, - setup => $setup, - teardown => $teardown, - } - ); -} - -sub _get_command_for_switches { - my $self = shift; - my @switches = @_; - my ( $file, @args ) = @{ $self->source }; - my $command = $self->_get_perl; - -# XXX we never need to quote if we treat the parts as atoms (except maybe vms) -#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); - my @command = ( $command, @switches, $file, @args ); - return @command; -} - -sub _get_command { - my $self = shift; - return $self->_get_command_for_switches( $self->_switches ); -} - -sub _libs2switches { - my $self = shift; - return map {"-I$_"} grep {$_} @_; -} - -=head3 C - -Get the shebang line for a script file. - - my $shebang = TAP::Parser::Source::Perl->shebang( $some_script ); - -May be called as a class method - -=cut - -{ - - # Global shebang cache. - my %shebang_for; - - sub _read_shebang { - my $file = shift; - local *TEST; - my $shebang; - if ( open( TEST, $file ) ) { - $shebang = ; - close(TEST) or print "Can't close $file. $!\n"; - } - else { - print "Can't open $file. $!\n"; - } - return $shebang; - } - - sub shebang { - my ( $class, $file ) = @_; - unless ( exists $shebang_for{$file} ) { - $shebang_for{$file} = _read_shebang($file); - } - return $shebang_for{$file}; - } -} - -=head3 C - -Decode any taint switches from a Perl shebang line. - - # $taint will be 't' - my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' ); - - # $untaint will be undefined - my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' ); - -=cut - -sub get_taint { - my ( $class, $shebang ) = @_; - return - unless defined $shebang - && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; - return $1; -} - -sub _switches { - my $self = shift; - my ( $file, @args ) = @{ $self->source }; - my @switches = ( - $self->switches, - ); - - my $shebang = $self->shebang($file); - return unless defined $shebang; - - my $taint = $self->get_taint($shebang); - push @switches, "-$taint" if defined $taint; - - # Quote the argument if we're VMS, since VMS will downcase anything - # not quoted. - if (IS_VMS) { - for (@switches) { - $_ = qq["$_"]; - } - } - - return @switches; -} - -sub _get_perl { - my $self = shift; - return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; - return Win32::GetShortPathName($^X) if IS_WIN32; - return $^X; -} - -1; - -=head1 SUBCLASSING - -Please see L for a subclassing overview. - -=head2 Example - - package MyPerlSource; - - use strict; - use vars '@ISA'; - - use Carp qw( croak ); - use TAP::Parser::Source::Perl; - - @ISA = qw( TAP::Parser::Source::Perl ); - - sub source { - my ($self, $args) = @_; - if ($args) { - $self->{file} = $args->[0]; - return $self->SUPER::source($args); - } - return $self->SUPER::source; - } - - # use the version of perl from the shebang line in the test file - sub _get_perl { - my $self = shift; - if (my $shebang = $self->shebang( $self->{file} )) { - $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; - return $1 if $1; - } - return $self->SUPER::_get_perl(@_); - } - -=head1 SEE ALSO - -L, -L, -L, - -=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm new file mode 100644 index 0000000000..51cff6fe5e --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm @@ -0,0 +1,194 @@ +package TAP::Parser::SourceHandler; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Object (); +use TAP::Parser::Iterator (); + +@ISA = qw(TAP::Object); + +=head1 NAME + +TAP::Parser::SourceHandler - Base class for different TAP source handlers + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=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 qw( 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 handlers / handlers. + +A C does whatever is necessary to produce & capture +a stream of TAP from the I source, and package it up in a +L for the parser to consume. + +C must implement the I interface +used by L. At 2 methods, the interface is pretty +simple: L and L. + +Unless you're writing a new L, a plugin, or +subclassing L, you probably won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +I. + + my $vote = $class->can_handle( $source ); + +C<$source> is a L. + +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 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 + +I. + + my $iterator = $class->make_iterator( $source ); + +C<$source> is a L. + +Returns a new L object for use by the L. +Cs 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 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 and +L. L is +the easiest sub-class to use an an example. + +It's important to point out that if you want your subclass to be automatically +used by L you'll have to and make sure it gets loaded somehow. +If you're using L you can write an L plugin. If you're +using L or L directly (eg. through a custom script, +L, or L) you can use the C option +which will cause L to load your +subclass). + +Don't forget to register your class with +L. + +=head2 Example + + package MySourceHandler; + + use strict; + use vars '@ISA'; # compat with older perls + + use MySourceHandler; # see TAP::Parser::SourceHandler + use TAP::Parser::IteratorFactory; + + @ISA = qw( 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, +L, +L, +L, +L, +L, +L, +L, +L, +L + +=cut + diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm new file mode 100644 index 0000000000..abfd5c52d2 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm @@ -0,0 +1,185 @@ +package TAP::Parser::SourceHandler::Executable; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); + +@ISA = qw(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.21 + +=cut + +$VERSION = '3.21'; + +=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 L - it has 2 jobs: + +1. Figure out if the L it's given is an executable command +(L). + +2. Creates an iterator for executable commands (L). + +Unless you're writing a plugin or subclassing L, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + 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 .sh file + 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}; + + # Note: we go in low so we can be out-voted + return 0.8 if $file->{lc_ext} eq '.sh'; + return 0.8 if $file->{lc_ext} eq '.bat'; + return 0.7 if $file->{execute}; + } + elsif ( $meta->{is_hash} ) { + return 0.9 if $src->raw->{exec}; + } + + return 0; +} + +=head3 C + + my $iterator = $class->make_iterator( $source ); + +Returns a new L for the source. +C<$source-Eraw> must be in one of the following forms: + + { exec => [ @exec ] } + + [ @exec ] + + $file + +Cs 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 ); + + return $class->iterator_class->new( + { command => \@command, + merge => $source->merge + } + ); +} + +=head3 C + +The class of iterator to use, override if you're sub-classing. Defaults +to L. + +=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 for a subclassing overview. + +=head2 Example + + package MyRubySourceHandler; + + use strict; + use vars '@ISA'; + + use Carp qw( croak ); + use TAP::Parser::SourceHandler::Executable; + + @ISA = qw( 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, +L, +L, +L, +L, +L, +L, +L + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm new file mode 100644 index 0000000000..4e411631bd --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm @@ -0,0 +1,136 @@ +package TAP::Parser::SourceHandler::File; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +@ISA = qw(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.21 + +=cut + +$VERSION = '3.21'; + +=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 L - it has 2 jobs: + +1. Figure out if the I source it's given is a file containing raw TAP +output. See L 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, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + 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} ) { + return 0.9 if grep { lc($_) eq $file->{lc_ext} } @$exts; + } + + return 0; +} + +=head3 C + + my $iterator = $class->make_iterator( $source ); + +Returns a new L for the source. Cs +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 + +The class of iterator to use, override if you're sub-classing. Defaults +to L. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Stream'; + +1; + +__END__ + +=head1 CONFIGURATION + + { + extensions => [ @case_insensitive_exts_to_match ] + } + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm new file mode 100644 index 0000000000..6a71eef8a0 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm @@ -0,0 +1,125 @@ +package TAP::Parser::SourceHandler::Handle; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +@ISA = qw(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.21 + +=cut + +$VERSION = '3.21'; + +=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 L class. It +has 2 jobs: + +1. Figure out if the L it's given is an L or +GLOB containing raw TAP output (L). + +2. Creates an iterator for IO::Handle's & globs (L). + +Unless you're writing a plugin or subclassing L, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + 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 + + my $iterator = $class->make_iterator( $source ); + +Returns a new L 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 + +The class of iterator to use, override if you're sub-classing. Defaults +to L. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Stream'; + +1; + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L, +L, +L + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm new file mode 100644 index 0000000000..7ad427e1f4 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm @@ -0,0 +1,310 @@ +package TAP::Parser::SourceHandler::Perl; + +use strict; +use Config; +use vars qw($VERSION @ISA); + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => ( $^O eq 'VMS' ); + +use TAP::Parser::SourceHandler::Executable (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); +use TAP::Parser::Utils qw( split_shell ); + +@ISA = '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.21 + +=cut + +$VERSION = '3.21'; + +=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 L - it has 2 jobs: + +1. Figure out if the L it's given is actually a Perl +script (L). + +2. Creates an iterator for Perl sources (L). + +Unless you're writing a plugin or subclassing L, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + 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.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/; + } + + 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 + + my $iterator = $class->make_iterator( $source ); + +Constructs & returns a new L for the source. +Assumes C<$source-Eraw> contains a reference to the perl script. Cs +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. The command generated +is guaranteed to preserve: + + PERL5LIB + PERL5OPT + Taint Mode, if set in the script's shebang + +I the command generated will I 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 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( \*STDOUT ); + $class->_autoflush( \*STDERR ); + + my @switches = $class->_switches($source); + 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/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { + push @libs, $1; + } + else { + push @filtered_switches, $_; + } + } + @switches = @filtered_switches; + + my $setup = sub { + if (@libs) { + $ENV{PERL5LIB} + = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); + } + }; + + # Cargo culted from comments seen elsewhere about VMS / environment + # variables. I don't know if this is actually necessary. + my $previous = $ENV{PERL5LIB}; + my $teardown = sub { + if ( defined $previous ) { + $ENV{PERL5LIB} = $previous; + } + else { + delete $ENV{PERL5LIB}; + } + }; + + # Taint mode ignores environment variables so we must retranslate + # PERL5LIB as -I switches and place PERL5OPT on the command line + # in order that it be seen. + if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { + push @switches, $class->_libs2switches(@libs); + push @switches, split_shell( $ENV{PERL5OPT} ); + } + + my @command = $class->_get_command_for_switches( $source, @switches ) + or $class->_croak("No command found!"); + + 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 {$_} @_; +} + +=head3 C + +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 @args = @{ $source->test_args || [] }; + 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 + +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 Win32::GetShortPathName($^X) if IS_WIN32; + return $^X; +} + +1; + +__END__ + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +=head2 Example + + package MyPerlSourceHandler; + + use strict; + use vars '@ISA'; + + use TAP::Parser::SourceHandler::Perl; + + @ISA = qw( 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, +L, +L, +L, +L, +L, +L, +L + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm new file mode 100644 index 0000000000..9978e5c327 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm @@ -0,0 +1,131 @@ +package TAP::Parser::SourceHandler::RawTAP; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Array (); + +@ISA = qw(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.21 + +=cut + +$VERSION = '3.21'; + +=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 L - it has 2 jobs: + +1. Figure out if the L it's given is raw TAP output +(L). + +2. Creates an iterator for raw TAP output (L). + +Unless you're writing a plugin or subclassing L, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + 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 + + my $iterator = $class->make_iterator( $source ); + +Returns a new L for the source. +C<$source-Eraw> must be an array ref, or a scalar ref. + +Cs 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 for a subclassing overview. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/pgTAP.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/pgTAP.pm new file mode 100644 index 0000000000..95c6e52cfc --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/pgTAP.pm @@ -0,0 +1,253 @@ +package TAP::Parser::SourceHandler::pgTAP; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); + +@ISA = qw(TAP::Parser::SourceHandler); +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::pgTAP - Stream TAP from pgTAP test scripts + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + +In F for your application with pgTAP tests in F: + + Module::Build->new( + module_name => 'MyApp', + test_file_exts => [qw(.t .pg)], + use_tap_harness => 1, + tap_harness_args => { + sources => { + Perl => undef, + pgTAP => { + dbname => 'try', + username => 'postgres', + suffix => '.pg', + }, + } + }, + build_requires => { + 'Module::Build' => '0.30', + 'TAP::Parser::SourceHandler::pgTAP' => '3.19', + }, + )->create_build_script; + +If you're using L|prove>: + + prove --source Perl \ + --source pgTAP --pgtap-option dbname=try \ + --pgtap-option username=postgres \ + --pgtap-option suffix=.pg + +Direct use: + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::pgTAP; + + my $source = TAP::Parser::Source->new->raw(\'mytest.pg'); + $source->config({ pgTAP => { + dbname => 'testing', + username => 'postgres', + suffix => '.pg', + }); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::pgTAP'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This source handler executes pgTAP tests. It does two things: + +=over + +=item 1. + +Looks at the L passed to it to determine whether or not +the source in question is in fact a pgTAP test (L). + +=item 2. + +Creates an iterator that will call C to run the pgTAP tests +(L). + +=back + +Unless you're writing a plugin or subclassing L, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $vote = $class->can_handle( $source ); + +Looks at the source to determine whether or not it's a pgTAP test file and +returns a score for how likely it is in fact a pgTAP test file. The scores are +as follows: + + 1 if it has a suffix equal to that in the "suffix" config + 1 if its suffix is ".pg" + 0.8 if its suffix is ".sql" + 0.75 if its suffix is ".s" + +The latter two scores are subject to change, so try to name your pgTAP tests +ending in ".pg" or specify a suffix in the configuration to be sure. + +=cut + +sub can_handle { + my ( $class, $source ) = @_; + my $meta = $source->meta; + + return 0 unless $meta->{is_file}; + + my $suf = $meta->{file}{lc_ext}; + + # If the config specifies a suffix, it's required. + if ( my $config = $source->config_for('pgTAP') ) { + if ( defined $config->{suffix} ) { + return $suf eq $config->{suffix} ? 1 : 0; + } + } + + # Otherwise, return a score for our supported suffixes. + my %score_for = ( + '.pg' => 0.9, + '.sql' => 0.8, + '.s' => 0.75, + ); + return $score_for{$suf} || 0; +} + +=head3 C + + my $iterator = $class->make_iterator( $source ); + +Returns a new L for the source. C<< +$source->raw >> must be either a file name or a scalar reference to the file +name. + +The pgTAP tests are run by executing C, the PostgreSQL command-line +utility. A number of arguments are passed to it, many of which you can effect +by setting up the source source configuration. The configuration must be a +hash reference, and supports the following keys: + +=over + +=item C + +The path to the C command. Defaults to simply "psql", which should work +well enough if it's in your path. + +=item C + +The database to which to connect to run the tests. Defaults to the value of +the C<$PGDATABASE> environment variable or, if not set, to the system +username. + +=item C + +The PostgreSQL username to use to connect to PostgreSQL. If not specified, no +username will be used, in which case C will fall back on either the +C<$PGUSER> environment variable or, if not set, the system username. + +=item C + +Specifies the host name of the machine to which to connect to the PostgreSQL +server. If the value begins with a slash, it is used as the directory for the +Unix-domain socket. Defaults to the value of the C<$PGDATABASE> environment +variable or, if not set, the local host. + +=item C + +Specifies the TCP port or the local Unix-domain socket file extension on which +the server is listening for connections. Defaults to the value of the +C<$PGPORT> environment variable or, if not set, to the port specified at the +time C was compiled, usually 5432. + +=begin comment + +=item C + +The schema search path to use during the execution of the tests. Useful for +overriding the default search path and you have pgTAP installed in a schema +not included in that search path. + +=end comment + +=back + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + my $config = $source->config_for('pgTAP'); + + my @command = ( $config->{psql} || 'psql' ); + push @command, qw( + --no-psqlrc + --no-align + --quiet + --pset pager= + --pset tuples_only=true + --set ON_ERROR_ROLLBACK=1 + --set ON_ERROR_STOP=1 + ); + + for (qw(username host port dbname)) { + push @command, "--$_" => $config->{$_} if defined $config->{$_}; + } + + my $fn = ref $source->raw ? ${ $source->raw } : $source->raw; + $class->_croak( + 'No such file or directory: ' . ( defined $fn ? $fn : '' ) ) + unless $fn && -e $fn; + + push @command, '--file', $fn; + + # XXX I'd like a way to be able to specify environment variables to set when + # the iterator executes the command... + # local $ENV{PGOPTIONS} = "--search_path=$config->{search_path}" + # if $config->{search_path}; + + return TAP::Parser::Iterator::Process->new( + { command => \@command, + merge => $source->merge + } + ); +} + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L, +L + +=head1 AUTHOR + +David E. Wheeler + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Utils.pm b/cpan/Test-Harness/lib/TAP/Parser/Utils.pm index a3d2dd1ea9..e7c5345b09 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Utils.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Utils.pm @@ -13,11 +13,11 @@ TAP::Parser::Utils - Internal TAP::Parser utilities =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm index 524d7dca8d..a5771592bb 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.17'; +$VERSION = '3.21'; # TODO: # Handle blessed object syntax @@ -270,7 +270,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION -Version 3.17 +Version 3.21 =head1 SYNOPSIS @@ -294,7 +294,7 @@ C object. =head3 C - my $got = $reader->read($stream); + my $got = $reader->read($iterator); Read YAMLish from a L and return the data structure it represents. diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm index ed81f6d819..a20b6252fa 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.17'; +$VERSION = '3.21'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; @@ -147,7 +147,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION -Version 3.17 +Version 3.21 =head1 SYNOPSIS -- cgit v1.2.1