diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Parser')
32 files changed, 1783 insertions, 594 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm index 10b37ef72a3..822b0d7109e 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm @@ -14,11 +14,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm index 44f28a0491e..0646d15d292 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs -L<TAP::Parser::Result> subclasses to represent the tokens. +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 @@ -49,22 +49,24 @@ parser). =head3 C<new> my $grammar = TAP::Parser::Grammar->new({ - stream => $stream, - parser => $parser, - version => $version, + iterator => $iterator, + parser => $parser, + version => $version, }); -Returns L<TAP::Parser> grammar object that will parse the specified stream. -Both C<stream> and C<parser> are required arguments. If C<version> is not set -it defaults to C<12> (see L</set_version> for more details). +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->{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; } @@ -162,7 +164,7 @@ my %language_for; }, }, bailout => { - syntax => qr/^Bail out!\s*(.*)/, + syntax => qr/^\s*Bail out!\s*(.*)/, handler => sub { my ( $self, $line ) = @_; my $explanation = $1; @@ -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; }; @@ -502,7 +504,7 @@ stream-based protocol. In fact, it's quite legal to have an infinite stream. For the same reason that we don't apply regexes to streams, we're not using a formal grammar here. Instead, we parse the TAP in lines. -For purposes for forward compatability, any result which does not match the +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. diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm index 09d40bebccb..dd831995dcc 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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<TAP::Parser>'s iterator -API. See C<TAP::Parser::IteratorFactory> for the preferred way of creating -iterators. +API. Iterators are typically created from L<TAP::Parser::SourceHandler>s. =head1 METHODS @@ -156,7 +157,6 @@ There's not much point repeating it here. L<TAP::Object>, L<TAP::Parser>, -L<TAP::Parser::IteratorFactory>, L<TAP::Parser::Iterator::Array>, L<TAP::Parser::Iterator::Stream>, L<TAP::Parser::Iterator::Process>, diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm index 1513d5b9945..4a195849bc9 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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<TAP::Parser>. Unless you're subclassing, you probably won't need to use -this module directly. +L<TAP::Parser>. 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<Test::Harness>. L<TAP::Object>, L<TAP::Parser>, L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, =cut diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm index a0a5a8ed32e..f4332c94503 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm +++ b/Master/tlpkg/tlperl/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 process-based TAP sources =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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<TAP::Parser>. Unless you're subclassing, you probably won't need to use -this module directly. +L<TAP::Parser>. 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<Test::Harness>. L<TAP::Object>, L<TAP::Parser>, L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, =cut diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm index c92cbabe089..27d87fb9961 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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<TAP::Parser>. Unless you're subclassing, you probably won't need to use -this module directly. +L<TAP::Parser>. 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<Test::Harness>. L<TAP::Object>, L<TAP::Parser>, L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, =cut diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm index 064d7beb167..a45f08550cb 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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<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 @@ -44,128 +44,299 @@ module directly. =head3 C<new> -Creates a new factory class. -I<Note:> You currently don't need to instantiate a factory in order to use it. +Creates a new factory class: -=head3 C<make_iterator> + 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</config> and calls L</load_handlers>. - my $iter = TAP::Parser::Iterator->make_iterator( $filehandle ); +=cut + +sub _initialize { + my ( $self, $config ) = @_; + $self->config( $config || {} )->load_handlers; + return $self; +} -Creates a I<stream> iterator (see L</make_stream_iterator>). +=head3 C<register_handler> - my $iter = TAP::Parser::Iterator->make_iterator( $array_reference ); +Registers a new L<TAP::Parser::SourceHandler> with this factory. -Creates an I<array> iterator (see L</make_array_iterator>). + __PACKAGE__->register_handler( $handler_class ); - my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference ); +=head3 C<handlers> -Creates a I<process> iterator (see L</make_process_iterator>). +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<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<make_stream_iterator> +############################################################################## + +=head3 C<load_handlers> + + $sf->load_handlers; -Make a new stream iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Stream>. +Loads the handler classes defined in L</config>. For example, given a config: -=head3 C<make_array_iterator> + $sf->config({ + MySourceHandler => { some => 'config' }, + }); -Make a new array iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Array>. +C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in +C<@INC> for it in this order: -=head3 C<make_process_iterator> + TAP::Parser::SourceHandler::MySourceHandler + MySourceHandler -Make a new process iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Process>. +C<croak>s 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<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; } -1; +=head3 C<detect_source> -=head1 SUBCLASSING +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. -Please see L<TAP::Parser/SUBCLASSING> 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<ResultFactory>: + 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<may> 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<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 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<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::Iterator>, -L<TAP::Parser::Iterator::Array>, -L<TAP::Parser::Iterator::Stream>, -L<TAP::Parser::Iterator::Process>, +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 diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm index 2e5d9296888..934933cae39 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm @@ -18,11 +18,11 @@ TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm index b01e95c5d9a..c8120302f34 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm @@ -26,15 +26,15 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 SYNOPSIS - # abstract class - not meany to be used directly + # abstract class - not meant to be used directly # see TAP::Parser::ResultFactory for preferred usage # directly: diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm index 3e42f4110fd..e85d2a9a951 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm index 1e9ba13c5f2..239a3eb22be 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm index 67c01df200d..56ac06ac4ec 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm index 3eb62b3322b..b2a9709c337 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm index 11cf302de6a..dd1ecd2edfa 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION @@ -101,7 +101,7 @@ sub directive { shift->{directive} } my $explanation = $result->explanation; If a test had either a C<TODO> or C<SKIP> directive, this method will return -the accompanying explantion, if present. +the accompanying explanation, if present. not ok 17 - 'Pigs can fly' # TODO not enough acid diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm index 52e19585d9a..861de5e29fa 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm index b97681eb065..f20c7a1d0a8 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm index ada3ae445bb..28aae77a10e 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm index 46d0df29dbd..37ec96b201b 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head2 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm index f1817093af0..522194182b8 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm @@ -12,11 +12,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm index 7ab68f9f673..18c1026a9dd 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm index 10af5e33697..eb88b444011 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm index 9263e9e5442..a33fe6fdb62 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm +++ b/Master/tlpkg/tlperl/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.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =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<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 @@ -48,10 +62,9 @@ Returns a new C<TAP::Parser::Source> 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<source> +=head3 C<raw> - 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<croaks> if -it doesn't get an arrayref. +=head3 C<meta> -=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</assemble_meta> for more info. -############################################################################## +=head3 C<has_meta> -=head3 C<get_stream> +True if the source has meta data. - my $stream = $source->get_stream; +=head3 C<config> -Returns a L<TAP::Parser::Iterator> stream of the output generated by executing -C<source>. C<croak>s if there was no command found. + my $config = $source->config; + $source->config({ %some_value }); -Must be passed an object that implements a C<make_iterator> 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</config_for> for more info. -=cut +=head3 C<merge> -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<switches> -############################################################################## + my $switches = $source->switches; + $source->config([ @switches ]); -=head3 C<merge> +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<test_args> + + 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<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, + } -=head1 SUBCLASSING + # for arrays: + size => $n, -Please see L<TAP::Parser/SUBCLASSING> 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<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; - @ISA = qw( TAP::Parser::Source ); + sub _read_shebang { + my ( $self, $file ) = @_; + my $shebang; + local *TEST; + if ( open( TEST, $file ) ) { + $shebang = <TEST>; + 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<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' ); - # 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<TAP::Object>, L<TAP::Parser>, -L<TAP::Parser::Source::Perl>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler> =cut - diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm deleted file mode 100644 index 1f4f2e1428c..00000000000 --- a/Master/tlpkg/tlperl/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<TAP::Parser::Source>. See that module for -more methods. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $perl = TAP::Parser::Source::Perl->new; - -Returns a new C<TAP::Parser::Source::Perl> object. - -=head2 Instance Methods - -=head3 C<source> - -Getter/setter the name of the test program and any arguments it requires. - - my ($filename, @args) = @{ $perl->source }; - $perl->source( [ $filename, @args ] ); - -C<croak>s 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<switches> - - my $switches = $perl->switches; - my @switches = $perl->switches; - $perl->switches( \@switches ); - -Getter/setter for the additional switches to pass to the perl executable. One -common switch would be to set an include directory: - - $perl->switches( ['-Ilib'] ); - -=cut - -sub switches { - my $self = shift; - unless (@_) { - return wantarray ? @{ $self->{switches} } : $self->{switches}; - } - my $switches = shift; - $self->{switches} = [@$switches]; # force a copy - return $self; -} - -############################################################################## - -=head3 C<get_stream> - - my $stream = $source->get_stream($parser); - -Returns a stream of the output generated by executing C<source>. Must be -passed an object that implements a C<make_iterator> 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<shebang> - -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 = <TEST>; - 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<get_taint> - -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<TAP::Parser/SUBCLASSING> 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<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Source>, - -=cut diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler.pm new file mode 100644 index 00000000000..acacb0b417e --- /dev/null +++ b/Master/tlpkg/tlperl/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.23 + +=cut + +$VERSION = '3.23'; + +=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<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 an 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 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<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 + diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Executable.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Executable.pm new file mode 100644 index 00000000000..8537ba18bf5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Executable.pm @@ -0,0 +1,186 @@ +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.23 + +=cut + +$VERSION = '3.23'; + +=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 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<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 diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/File.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/File.pm new file mode 100644 index 00000000000..ab08eb2922f --- /dev/null +++ b/Master/tlpkg/tlperl/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.23 + +=cut + +$VERSION = '3.23'; + +=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} ) { + 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 diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Handle.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Handle.pm new file mode 100644 index 00000000000..fc2e65461ca --- /dev/null +++ b/Master/tlpkg/tlperl/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.23 + +=cut + +$VERSION = '3.23'; + +=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 diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Perl.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Perl.pm new file mode 100644 index 00000000000..9721acf9f11 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Perl.pm @@ -0,0 +1,362 @@ +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.23 + +=cut + +$VERSION = '3.23'; + +=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 _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 ( grep { $_ eq "-T" || $_ eq "-t" } @{$switches} ) { + return ( + $libs, + [ @{$switches}, + $class->_libs2switches($libs), + split_shell( $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 ) = @_; + + my $setup = sub { + if ( @{$libs} ) { + $ENV{PERL5LIB} = join( + $Config{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}; + } + }; + + 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 ); + + 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 Win32::GetShortPathName($^X) if IS_WIN32; + return $^X; +} + +1; + +__END__ + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> 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<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 diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/RawTAP.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/RawTAP.pm new file mode 100644 index 00000000000..0d7a4851ee8 --- /dev/null +++ b/Master/tlpkg/tlperl/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.23 + +=cut + +$VERSION = '3.23'; + +=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 diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm index a3d2dd1ea98..49a457a3783 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm @@ -13,11 +13,11 @@ TAP::Parser::Utils - Internal TAP::Parser utilities =head1 VERSION -Version 3.17 +Version 3.23 =cut -$VERSION = '3.17'; +$VERSION = '3.23'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm index 524d7dca8df..82968b42b1d 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm +++ b/Master/tlpkg/tlperl/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.23'; # 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.23 =head1 SYNOPSIS @@ -294,7 +294,7 @@ C<TAP::Parser::YAMLish::Reader> object. =head3 C<read> - my $got = $reader->read($stream); + my $got = $reader->read($iterator); Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it represents. @@ -319,7 +319,7 @@ L<http://use.perl.org/~Alias/journal/29427> =head1 COPYRIGHT -Copyright 2007-2008 Andy Armstrong. +Copyright 2007-2011 Andy Armstrong. Portions copyright 2006-2008 Adam Kennedy. diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm index ed81f6d8191..dda5f1873eb 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm +++ b/Master/tlpkg/tlperl/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.23'; 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.23 =head1 SYNOPSIS @@ -243,7 +243,7 @@ L<http://use.perl.org/~Alias/journal/29427> =head1 COPYRIGHT -Copyright 2007-2008 Andy Armstrong. +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. |