From 12679ab7d3c2a210f4123163671b532b8b55d5f9 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Fri, 15 Mar 2024 03:06:35 +0000 Subject: CTAN sync 202403150306 --- .../tlpkg/tlperl/site/lib/TAP/Parser/Aggregator.pm | 414 +++++++++++++++ .../tlpkg/tlperl/site/lib/TAP/Parser/Grammar.pm | 590 +++++++++++++++++++++ .../tlpkg/tlperl/site/lib/TAP/Parser/Iterator.pm | 162 ++++++ .../tlperl/site/lib/TAP/Parser/Iterator/Array.pm | 100 ++++ .../tlperl/site/lib/TAP/Parser/Iterator/Process.pm | 381 +++++++++++++ .../tlperl/site/lib/TAP/Parser/Iterator/Stream.pm | 116 ++++ .../tlperl/site/lib/TAP/Parser/IteratorFactory.pm | 339 ++++++++++++ .../tlperl/site/lib/TAP/Parser/Multiplexer.pm | 196 +++++++ .../tlpkg/tlperl/site/lib/TAP/Parser/Result.pm | 297 +++++++++++ .../tlperl/site/lib/TAP/Parser/Result/Bailout.pm | 62 +++ .../tlperl/site/lib/TAP/Parser/Result/Comment.pm | 60 +++ .../tlperl/site/lib/TAP/Parser/Result/Plan.pm | 119 +++++ .../tlperl/site/lib/TAP/Parser/Result/Pragma.pm | 62 +++ .../tlperl/site/lib/TAP/Parser/Result/Test.pm | 271 ++++++++++ .../tlperl/site/lib/TAP/Parser/Result/Unknown.pm | 48 ++ .../tlperl/site/lib/TAP/Parser/Result/Version.pm | 62 +++ .../tlperl/site/lib/TAP/Parser/Result/YAML.pm | 61 +++ .../tlperl/site/lib/TAP/Parser/ResultFactory.pm | 183 +++++++ .../tlpkg/tlperl/site/lib/TAP/Parser/Scheduler.pm | 448 ++++++++++++++++ .../tlperl/site/lib/TAP/Parser/Scheduler/Job.pm | 127 +++++ .../site/lib/TAP/Parser/Scheduler/Spinner.pm | 61 +++ .../tlpkg/tlperl/site/lib/TAP/Parser/Source.pm | 381 +++++++++++++ .../tlperl/site/lib/TAP/Parser/SourceHandler.pm | 191 +++++++ .../lib/TAP/Parser/SourceHandler/Executable.pm | 187 +++++++ .../site/lib/TAP/Parser/SourceHandler/File.pm | 136 +++++ .../site/lib/TAP/Parser/SourceHandler/Handle.pm | 124 +++++ .../site/lib/TAP/Parser/SourceHandler/Perl.pm | 372 +++++++++++++ .../site/lib/TAP/Parser/SourceHandler/RawTAP.pm | 130 +++++ .../tlperl/site/lib/TAP/Parser/YAMLish/Reader.pm | 347 ++++++++++++ .../tlperl/site/lib/TAP/Parser/YAMLish/Writer.pm | 263 +++++++++ 30 files changed, 6290 insertions(+) create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Aggregator.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Grammar.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Array.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Process.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Stream.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/IteratorFactory.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Multiplexer.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Bailout.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Comment.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Plan.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Pragma.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Test.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Unknown.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Version.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/YAML.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/ResultFactory.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Job.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Spinner.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Source.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Executable.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/File.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Handle.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Perl.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/RawTAP.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Reader.pm create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Writer.pm (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser') diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Aggregator.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Aggregator.pm new file mode 100755 index 0000000000..dac0f9a43e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Aggregator.pm @@ -0,0 +1,414 @@ +package TAP::Parser::Aggregator; + +use strict; +use warnings; +use Benchmark; + +use base 'TAP::Object'; + +=head1 NAME + +TAP::Parser::Aggregator - Aggregate TAP::Parser results + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Aggregator; + + my $aggregate = TAP::Parser::Aggregator->new; + $aggregate->add( 't/00-load.t', $load_parser ); + $aggregate->add( 't/10-lex.t', $lex_parser ); + + my $summary = <<'END_SUMMARY'; + Passed: %s + Failed: %s + Unexpectedly succeeded: %s + END_SUMMARY + printf $summary, + scalar $aggregate->passed, + scalar $aggregate->failed, + scalar $aggregate->todo_passed; + +=head1 DESCRIPTION + +C collects parser objects and allows +reporting/querying their aggregate results. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $aggregate = TAP::Parser::Aggregator->new; + +Returns a new C object. + +=cut + +# new() implementation supplied by TAP::Object + +my %SUMMARY_METHOD_FOR; + +BEGIN { # install summary methods + %SUMMARY_METHOD_FOR = map { $_ => $_ } qw( + failed + parse_errors + passed + skipped + todo + todo_passed + total + wait + exit + ); + $SUMMARY_METHOD_FOR{total} = 'tests_run'; + $SUMMARY_METHOD_FOR{planned} = 'tests_planned'; + + for my $method ( keys %SUMMARY_METHOD_FOR ) { + next if 'total' eq $method; + no strict 'refs'; + *$method = sub { + my $self = shift; + return wantarray + ? @{ $self->{"descriptions_for_$method"} } + : $self->{$method}; + }; + } +} # end install summary methods + +sub _initialize { + my ($self) = @_; + $self->{parser_for} = {}; + $self->{parse_order} = []; + for my $summary ( keys %SUMMARY_METHOD_FOR ) { + $self->{$summary} = 0; + next if 'total' eq $summary; + $self->{"descriptions_for_$summary"} = []; + } + return $self; +} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + $aggregate->add( $description => $parser ); + +The C<$description> is usually a test file name (but only by +convention.) It is used as a unique identifier (see e.g. +L<"parsers">.) Reusing a description is a fatal error. + +The C<$parser> is a L object. + +=cut + +sub add { + my ( $self, $description, $parser ) = @_; + if ( exists $self->{parser_for}{$description} ) { + $self->_croak( "You already have a parser for ($description)." + . " Perhaps you have run the same test twice." ); + } + push @{ $self->{parse_order} } => $description; + $self->{parser_for}{$description} = $parser; + + while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) { + + # Slightly nasty. Instead we should maybe have 'cooked' accessors + # for results that may be masked by the parser. + next + if ( $method eq 'exit' || $method eq 'wait' ) + && $parser->ignore_exit; + + if ( my $count = $parser->$method() ) { + $self->{$summary} += $count; + push @{ $self->{"descriptions_for_$summary"} } => $description; + } + } + + return $self; +} + +############################################################################## + +=head3 C + + my $count = $aggregate->parsers; + my @parsers = $aggregate->parsers; + my @parsers = $aggregate->parsers(@descriptions); + +In scalar context without arguments, this method returns the number of parsers +aggregated. In list context without arguments, returns the parsers in the +order they were added. + +If C<@descriptions> is given, these correspond to the keys used in each +call to the add() method. Returns an array of the requested parsers (in +the requested order) in list context or an array reference in scalar +context. + +Requesting an unknown identifier is a fatal error. + +=cut + +sub parsers { + my $self = shift; + return $self->_get_parsers(@_) if @_; + my $descriptions = $self->{parse_order}; + my @parsers = @{ $self->{parser_for} }{@$descriptions}; + + # Note: Because of the way context works, we must assign the parsers to + # the @parsers array or else this method does not work as documented. + return @parsers; +} + +sub _get_parsers { + my ( $self, @descriptions ) = @_; + my @parsers; + for my $description (@descriptions) { + $self->_croak("A parser for ($description) could not be found") + unless exists $self->{parser_for}{$description}; + push @parsers => $self->{parser_for}{$description}; + } + return wantarray ? @parsers : \@parsers; +} + +=head3 C + +Get an array of descriptions in the order in which they were added to +the aggregator. + +=cut + +sub descriptions { @{ shift->{parse_order} || [] } } + +=head3 C + +Call C immediately before adding any results to the aggregator. +Among other times it records the start time for the test run. + +=cut + +sub start { + my $self = shift; + $self->{start_time} = Benchmark->new; +} + +=head3 C + +Call C immediately after adding all test results to the aggregator. + +=cut + +sub stop { + my $self = shift; + $self->{end_time} = Benchmark->new; +} + +=head3 C + +Elapsed returns a L object that represents the running time +of the aggregated tests. In order for C to be valid you must +call C before running the tests and C immediately +afterwards. + +=cut + +sub elapsed { + my $self = shift; + + require Carp; + Carp::croak + q{Can't call elapsed without first calling start and then stop} + unless defined $self->{start_time} && defined $self->{end_time}; + return timediff( $self->{end_time}, $self->{start_time} ); +} + +=head3 C + +Returns a formatted string representing the runtime returned by +C. This lets the caller not worry about Benchmark. + +=cut + +sub elapsed_timestr { + my $self = shift; + + my $elapsed = $self->elapsed; + + return timestr($elapsed); +} + +=head3 C + +Return true if all the tests passed and no parse errors were detected. + +=cut + +sub all_passed { + my $self = shift; + return + $self->total + && $self->total == $self->passed + && !$self->has_errors; +} + +=head3 C + +Get a single word describing the status of the aggregated tests. +Depending on the outcome of the tests returns 'PASS', 'FAIL' or +'NOTESTS'. This token is understood by L. + +=cut + +sub get_status { + my $self = shift; + + my $total = $self->total; + my $passed = $self->passed; + + return + ( $self->has_errors || $total != $passed ) ? 'FAIL' + : $total ? 'PASS' + : 'NOTESTS'; +} + +############################################################################## + +=head2 Summary methods + +Each of the following methods will return the total number of corresponding +tests if called in scalar context. If called in list context, returns the +descriptions of the parsers which contain the corresponding tests (see C +for an explanation of description. + +=over 4 + +=item * failed + +=item * parse_errors + +=item * passed + +=item * planned + +=item * skipped + +=item * todo + +=item * todo_passed + +=item * wait + +=item * exit + +=back + +For example, to find out how many tests unexpectedly succeeded (TODO tests +which passed when they shouldn't): + + my $count = $aggregate->todo_passed; + my @descriptions = $aggregate->todo_passed; + +Note that C and C are the totals of the wait and exit +statuses of each of the tests. These values are totalled only to provide +a true value if any of them are non-zero. + +=cut + +############################################################################## + +=head3 C + + my $tests_run = $aggregate->total; + +Returns the total number of tests run. + +=cut + +sub total { shift->{total} } + +############################################################################## + +=head3 C + + if ( $parser->has_problems ) { + ... + } + +Identical to C, but also returns true if any TODO tests +unexpectedly succeeded. This is more akin to "warnings". + +=cut + +sub has_problems { + my $self = shift; + return $self->todo_passed + || $self->has_errors; +} + +############################################################################## + +=head3 C + + if ( $parser->has_errors ) { + ... + } + +Returns true if I of the parsers failed. This includes: + +=over 4 + +=item * Failed tests + +=item * Parse errors + +=item * Bad exit or wait status + +=back + +=cut + +sub has_errors { + my $self = shift; + return + $self->failed + || $self->parse_errors + || $self->exit + || $self->wait; +} + +############################################################################## + +=head3 C + + # deprecated in favor of 'todo_passed'. This method was horribly misnamed. + +This was a badly misnamed method. It indicates which TODO tests unexpectedly +succeeded. Will now issue a warning and call C. + +=cut + +sub todo_failed { + warn + '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; + goto &todo_passed; +} + +=head1 See Also + +L + +L + +=cut + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Grammar.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Grammar.pm new file mode 100755 index 0000000000..0258ad3206 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Grammar.pm @@ -0,0 +1,590 @@ +package TAP::Parser::Grammar; + +use strict; +use warnings; + +use TAP::Parser::ResultFactory (); +use TAP::Parser::YAMLish::Reader (); + +use base 'TAP::Object'; + +=head1 NAME + +TAP::Parser::Grammar - A grammar for the Test Anything Protocol. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Grammar; + my $grammar = $self->make_grammar({ + iterator => $tap_parser_iterator, + parser => $tap_parser, + version => 12, + }); + + my $result = $grammar->tokenize; + +=head1 DESCRIPTION + +C 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 +expanded at some future date (plus, this stuff was really cluttering the +parser). + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $grammar = TAP::Parser::Grammar->new({ + iterator => $iterator, + parser => $parser, + version => $version, + }); + +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->{iterator} = $args->{iterator}; # TODO: accessor + $self->{iterator} ||= $args->{stream}; # deprecated + $self->{parser} = $args->{parser}; # TODO: accessor + $self->set_version( $args->{version} || 12 ); + return $self; +} + +my %language_for; + +{ + + # XXX the 'not' and 'ok' might be on separate lines in VMS ... + my $ok = qr/(?:not )?ok\b/; + my $num = qr/\d+/; + + my %v12 = ( + version => { + syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i, + handler => sub { + my ( $self, $line ) = @_; + my $version = $1; + return $self->_make_version_token( $line, $version, ); + }, + }, + plan => { + syntax => qr/^1\.\.(\d+)\s*(.*)\z/, + handler => sub { + my ( $self, $line ) = @_; + my ( $tests_planned, $tail ) = ( $1, $2 ); + my $explanation = undef; + my $skip = ''; + + if ( $tail =~ /^todo((?:\s+\d+)+)/ ) { + my @todo = split /\s+/, _trim($1); + return $self->_make_plan_token( + $line, $tests_planned, 'TODO', + '', \@todo + ); + } + elsif ( 0 == $tests_planned ) { + $skip = 'SKIP'; + + # If we can't match # SKIP the directive should be undef. + ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i; + } + elsif ( $tail !~ /^\s*$/ ) { + return $self->_make_unknown_token($line); + } + + $explanation = '' unless defined $explanation; + + return $self->_make_plan_token( + $line, $tests_planned, $skip, + $explanation, [] + ); + + }, + }, + + # An optimization to handle the most common test lines without + # directives. + simple_test => { + syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x, + handler => sub { + my ( $self, $line ) = @_; + my ( $ok, $num, $desc ) = ( $1, $2, $3 ); + + return $self->_make_test_token( + $line, $ok, $num, + $desc + ); + }, + }, + test => { + syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x, + handler => sub { + my ( $self, $line ) = @_; + my ( $ok, $num, $desc ) = ( $1, $2, $3 ); + my ( $dir, $explanation ) = ( '', '' ); + if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* ) + \# \s* (SKIP|TODO) \b \s* (.*) $/ix + ) + { + ( $desc, $dir, $explanation ) = ( $1, $2, $3 ); + } + return $self->_make_test_token( + $line, $ok, $num, $desc, + $dir, $explanation + ); + }, + }, + comment => { + syntax => qr/^#(.*)/, + handler => sub { + my ( $self, $line ) = @_; + my $comment = $1; + return $self->_make_comment_token( $line, $comment ); + }, + }, + bailout => { + syntax => qr/^\s*Bail out!\s*(.*)/, + handler => sub { + my ( $self, $line ) = @_; + my $explanation = $1; + return $self->_make_bailout_token( + $line, + $explanation + ); + }, + }, + ); + + my %v13 = ( + %v12, + plan => { + syntax => qr/^1\.\.(\d+)\s*(?:\s*#\s*SKIP\b(.*))?\z/i, + handler => sub { + my ( $self, $line ) = @_; + my ( $tests_planned, $explanation ) = ( $1, $2 ); + my $skip + = ( 0 == $tests_planned || defined $explanation ) + ? 'SKIP' + : ''; + $explanation = '' unless defined $explanation; + return $self->_make_plan_token( + $line, $tests_planned, $skip, + $explanation, [] + ); + }, + }, + yaml => { + syntax => qr/^ (\s+) (---.*) $/x, + handler => sub { + my ( $self, $line ) = @_; + my ( $pad, $marker ) = ( $1, $2 ); + return $self->_make_yaml_token( $pad, $marker ); + }, + }, + pragma => { + syntax => + qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x, + handler => sub { + my ( $self, $line ) = @_; + my $pragmas = $1; + return $self->_make_pragma_token( $line, $pragmas ); + }, + }, + ); + + %language_for = ( + '12' => { + tokens => \%v12, + }, + '13' => { + tokens => \%v13, + setup => sub { + shift->{iterator}->handle_unicode; + }, + }, + '14' => { + tokens => \%v13, + setup => sub { + shift->{iterator}->handle_unicode; + }, + }, + ); +} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + $grammar->set_version(13); + +Tell the grammar which TAP syntax version to support. The lowest +supported version is 12. Although 'TAP version' isn't valid version 12 +syntax it is accepted so that higher version numbers may be parsed. + +=cut + +sub set_version { + my $self = shift; + my $version = shift; + + if ( my $language = $language_for{$version} ) { + $self->{version} = $version; + $self->{tokens} = $language->{tokens}; + + if ( my $setup = $language->{setup} ) { + $self->$setup(); + } + + $self->_order_tokens; + } + else { + require Carp; + Carp::croak("Unsupported syntax version: $version"); + } +} + +# Optimization to put the most frequent tokens first. +sub _order_tokens { + my $self = shift; + + my %copy = %{ $self->{tokens} }; + my @ordered_tokens = grep {defined} + map { delete $copy{$_} } qw( simple_test test comment plan ); + push @ordered_tokens, values %copy; + + $self->{ordered_tokens} = \@ordered_tokens; +} + +############################################################################## + +=head3 C + + my $token = $grammar->tokenize; + +This method will return a L object representing the +current line of TAP. + +=cut + +sub tokenize { + my $self = shift; + + my $line = $self->{iterator}->next; + unless ( defined $line ) { + delete $self->{parser}; # break circular ref + return; + } + + my $token; + + for my $token_data ( @{ $self->{ordered_tokens} } ) { + if ( $line =~ $token_data->{syntax} ) { + my $handler = $token_data->{handler}; + $token = $self->$handler($line); + last; + } + } + + $token = $self->_make_unknown_token($line) unless $token; + + return $self->{parser}->make_result($token); +} + +############################################################################## + +=head3 C + + my @types = $grammar->token_types; + +Returns the different types of tokens which this grammar can parse. + +=cut + +sub token_types { + my $self = shift; + return keys %{ $self->{tokens} }; +} + +############################################################################## + +=head3 C + + my $syntax = $grammar->syntax_for($token_type); + +Returns a pre-compiled regular expression which will match a chunk of TAP +corresponding to the token type. For example (not that you should really pay +attention to this, C<< $grammar->syntax_for('comment') >> will return +C<< qr/^#(.*)/ >>. + +=cut + +sub syntax_for { + my ( $self, $type ) = @_; + return $self->{tokens}->{$type}->{syntax}; +} + +############################################################################## + +=head3 C + + my $handler = $grammar->handler_for($token_type); + +Returns a code reference which, when passed an appropriate line of TAP, +returns the lexed token corresponding to that line. As a result, the basic +TAP parsing loop looks similar to the following: + + my @tokens; + my $grammar = TAP::Grammar->new; + LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) { + for my $type ( $grammar->token_types ) { + my $syntax = $grammar->syntax_for($type); + if ( $line =~ $syntax ) { + my $handler = $grammar->handler_for($type); + push @tokens => $grammar->$handler($line); + next LINE; + } + } + push @tokens => $grammar->_make_unknown_token($line); + } + +=cut + +sub handler_for { + my ( $self, $type ) = @_; + return $self->{tokens}->{$type}->{handler}; +} + +sub _make_version_token { + my ( $self, $line, $version ) = @_; + return { + type => 'version', + raw => $line, + version => $version, + }; +} + +sub _make_plan_token { + my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_; + + if ( $directive eq 'SKIP' + && 0 != $tests_planned + && $self->{version} < 13 ) + { + warn + "Specified SKIP directive in plan but more than 0 tests ($line)\n"; + } + + return { + type => 'plan', + raw => $line, + tests_planned => $tests_planned, + directive => $directive, + explanation => _trim($explanation), + todo_list => $todo, + }; +} + +sub _make_test_token { + my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_; + return { + ok => $ok, + + # forcing this to be an integer (and not a string) reduces memory + # consumption. RT #84939 + test_num => ( defined $num ? 0 + $num : undef ), + description => _trim($desc), + directive => ( defined $dir ? uc $dir : '' ), + explanation => _trim($explanation), + raw => $line, + type => 'test', + }; +} + +sub _make_unknown_token { + my ( $self, $line ) = @_; + return { + raw => $line, + type => 'unknown', + }; +} + +sub _make_comment_token { + my ( $self, $line, $comment ) = @_; + return { + type => 'comment', + raw => $line, + comment => _trim($comment) + }; +} + +sub _make_bailout_token { + my ( $self, $line, $explanation ) = @_; + return { + type => 'bailout', + raw => $line, + bailout => _trim($explanation) + }; +} + +sub _make_yaml_token { + my ( $self, $pad, $marker ) = @_; + + my $yaml = TAP::Parser::YAMLish::Reader->new; + + my $iterator = $self->{iterator}; + + # Construct a reader that reads from our input stripping leading + # spaces from each line. + my $leader = length($pad); + my $strip = qr{ ^ (\s{$leader}) (.*) $ }x; + my @extra = ($marker); + my $reader = sub { + return shift @extra if @extra; + my $line = $iterator->next; + return $2 if $line =~ $strip; + return; + }; + + my $data = $yaml->read($reader); + + # Reconstitute input. This is convoluted. Maybe we should just + # record it on the way in... + chomp( my $raw = $yaml->get_raw ); + $raw =~ s/^/$pad/mg; + + return { + type => 'yaml', + raw => $raw, + data => $data + }; +} + +sub _make_pragma_token { + my ( $self, $line, $pragmas ) = @_; + return { + type => 'pragma', + raw => $line, + pragmas => [ split /\s*,\s*/, _trim($pragmas) ], + }; +} + +sub _trim { + my $data = shift; + + return '' unless defined $data; + + $data =~ s/^\s+//; + $data =~ s/\s+$//; + return $data; +} + +1; + +=head1 TAP GRAMMAR + +B This grammar is slightly out of date. There's still some discussion +about it and a new one will be provided when we have things better defined. + +The L does not use a formal grammar because TAP is essentially a +stream-based protocol. In fact, it's quite legal to have an infinite stream. +For the same reason that we don't apply regexes to streams, we're not using a +formal grammar here. Instead, we parse the TAP in lines. + +For purposes for forward compatibility, any result which does not match the +following grammar is currently referred to as +L. It is I a parse error. + +A formal grammar would look similar to the following: + + (* + For the time being, I'm cheating on the EBNF by allowing + certain terms to be defined by POSIX character classes by + using the following syntax: + + digit ::= [:digit:] + + As far as I am aware, that's not valid EBNF. Sue me. I + didn't know how to write "char" otherwise (Unicode issues). + Suggestions welcome. + *) + + tap ::= version? { comment | unknown } leading_plan lines + | + lines trailing_plan {comment} + + version ::= 'TAP version ' positiveInteger {positiveInteger} "\n" + + leading_plan ::= plan skip_directive? "\n" + + trailing_plan ::= plan "\n" + + plan ::= '1..' nonNegativeInteger + + lines ::= line {line} + + line ::= (comment | test | unknown | bailout ) "\n" + + test ::= status positiveInteger? description? directive? + + status ::= 'not '? 'ok ' + + description ::= (character - (digit | '#')) {character - '#'} + + directive ::= todo_directive | skip_directive + + todo_directive ::= hash_mark 'TODO' ' ' {character} + + skip_directive ::= hash_mark 'SKIP' ' ' {character} + + comment ::= hash_mark {character} + + hash_mark ::= '#' {' '} + + bailout ::= 'Bail out!' {character} + + unknown ::= { (character - "\n") } + + (* POSIX character classes and other terminals *) + + digit ::= [:digit:] + character ::= ([:print:] - "\n") + positiveInteger ::= ( digit - '0' ) {digit} + nonNegativeInteger ::= digit {digit} + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +If you I want to subclass L's grammar the best thing to +do is read through the code. There's no easy way of summarizing it here. + +=head1 SEE ALSO + +L, +L, +L, +L, + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator.pm new file mode 100755 index 0000000000..a1d66c6ef4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator.pm @@ -0,0 +1,162 @@ +package TAP::Parser::Iterator; + +use strict; +use warnings; + +use base 'TAP::Object'; + +=head1 NAME + +TAP::Parser::Iterator - Base class for TAP source iterators + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + # to subclass: + use TAP::Parser::Iterator (); + use base 'TAP::Parser::Iterator'; + sub _initialize { + # see TAP::Object... + } + + sub next_raw { ... } + sub wait { ... } + sub exit { ... } + +=head1 DESCRIPTION + +This is a simple iterator base class that defines L's iterator +API. Iterators are typically created from Ls. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Create an iterator. Provided by L. + +=head2 Instance Methods + +=head3 C + + while ( my $item = $iter->next ) { ... } + +Iterate through it, of course. + +=head3 C + +B this method is abstract and should be overridden. + + while ( my $item = $iter->next_raw ) { ... } + +Iterate raw input without applying any fixes for quirky input syntax. + +=cut + +sub next { + my $self = shift; + my $line = $self->next_raw; + + # vms nit: When encountering 'not ok', vms often has the 'not' on a line + # by itself: + # not + # ok 1 - 'I hate VMS' + if ( defined($line) and $line =~ /^\s*not\s*$/ ) { + $line .= ( $self->next_raw || '' ); + } + + return $line; +} + +sub next_raw { + require Carp; + my $msg = Carp::longmess('abstract method called directly!'); + $_[0]->_croak($msg); +} + +=head3 C + +If necessary switch the input stream to handle unicode. This only has +any effect for I/O handle based streams. + +The default implementation does nothing. + +=cut + +sub handle_unicode { } + +=head3 C + +Return a list of filehandles that may be used upstream in a select() +call to signal that this Iterator is ready. Iterators that are not +handle-based should return an empty list. + +The default implementation does nothing. + +=cut + +sub get_select_handles { + return; +} + +=head3 C + +B this method is abstract and should be overridden. + + my $wait_status = $iter->wait; + +Return the C status for this iterator. + +=head3 C + +B this method is abstract and should be overridden. + + my $wait_status = $iter->exit; + +Return the C status for this iterator. + +=cut + +sub wait { + require Carp; + my $msg = Carp::longmess('abstract method called directly!'); + $_[0]->_croak($msg); +} + +sub exit { + require Carp; + my $msg = Carp::longmess('abstract method called directly!'); + $_[0]->_croak($msg); +} + +1; + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +You must override the abstract methods as noted above. + +=head2 Example + +L is probably the easiest example to follow. +There's not much point repeating it here. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Array.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Array.pm new file mode 100755 index 0000000000..ceb8198baf --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Array.pm @@ -0,0 +1,100 @@ +package TAP::Parser::Iterator::Array; + +use strict; +use warnings; + +use base 'TAP::Parser::Iterator'; + +=head1 NAME + +TAP::Parser::Iterator::Array - Iterator for array-based TAP sources + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Iterator::Array; + my @data = ('foo', 'bar', baz'); + my $it = TAP::Parser::Iterator::Array->new(\@data); + my $line = $it->next; + +=head1 DESCRIPTION + +This is a simple iterator wrapper for arrays of scalar content, used by +L. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Create an iterator. Takes one argument: an C<$array_ref> + +=head2 Instance Methods + +=head3 C + +Iterate through it, of course. + +=head3 C + +Iterate raw input without applying any fixes for quirky input syntax. + +=head3 C + +Get the wait status for this iterator. For an array iterator this will always +be zero. + +=head3 C + +Get the exit status for this iterator. For an array iterator this will always +be zero. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my ( $self, $thing ) = @_; + chomp @$thing; + $self->{idx} = 0; + $self->{array} = $thing; + $self->{exit} = undef; + return $self; +} + +sub wait { shift->exit } + +sub exit { + my $self = shift; + return 0 if $self->{idx} >= @{ $self->{array} }; + return; +} + +sub next_raw { + my $self = shift; + return $self->{array}->[ $self->{idx}++ ]; +} + +1; + +=head1 ATTRIBUTION + +Originally ripped off from L. + +=head1 SEE ALSO + +L, +L, +L, + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Process.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Process.pm new file mode 100755 index 0000000000..249ecde9a5 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Process.pm @@ -0,0 +1,381 @@ +package TAP::Parser::Iterator::Process; + +use strict; +use warnings; + +use Config; +use IO::Handle; + +use base 'TAP::Parser::Iterator'; + +my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); + +=head1 NAME + +TAP::Parser::Iterator::Process - Iterator for process-based TAP sources + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Iterator::Process; + my %args = ( + command => ['python', 'setup.py', 'test'], + merge => 1, + setup => sub { ... }, + teardown => sub { ... }, + ); + my $it = TAP::Parser::Iterator::Process->new(\%args); + my $line = $it->next; + +=head1 DESCRIPTION + +This is a simple iterator wrapper for executing external processes, used by +L. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Create an iterator. Expects one argument containing a hashref of the form: + + command => \@command_to_execute + merge => $attempt_merge_stderr_and_stdout? + setup => $callback_to_setup_command + teardown => $callback_to_teardown_command + +Tries to uses L & L to communicate with the spawned +process if they are available. Falls back onto C. + +=head2 Instance Methods + +=head3 C + +Iterate through the process output, of course. + +=head3 C + +Iterate raw input without applying any fixes for quirky input syntax. + +=head3 C + +Get the wait status for this iterator's process. + +=head3 C + +Get the exit status for this iterator's process. + +=cut + +{ + + no warnings 'uninitialized'; + # get around a catch22 in the test suite that causes failures on Win32: + local $SIG{__DIE__} = undef; + eval { require POSIX; &POSIX::WEXITSTATUS(0) }; + if ($@) { + *_wait2exit = sub { $_[1] >> 8 }; + } + else { + *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) } + } +} + +sub _use_open3 { + my $self = shift; + return unless $Config{d_fork} || $IS_WIN32; + for my $module (qw( IPC::Open3 IO::Select )) { + eval "use $module"; + return if $@; + } + return 1; +} + +{ + my $got_unicode; + + sub _get_unicode { + return $got_unicode if defined $got_unicode; + eval 'use Encode qw(decode_utf8);'; + $got_unicode = $@ ? 0 : 1; + + } +} + +# new() implementation supplied by TAP::Object + +sub _initialize { + my ( $self, $args ) = @_; + + my @command = @{ delete $args->{command} || [] } + or die "Must supply a command to execute"; + + $self->{command} = [@command]; + + # Private. Used to frig with chunk size during testing. + my $chunk_size = delete $args->{_chunk_size} || 65536; + + my $merge = delete $args->{merge}; + my ( $pid, $err, $sel ); + + if ( my $setup = delete $args->{setup} ) { + $setup->(@command); + } + + my $out = IO::Handle->new; + + if ( $self->_use_open3 ) { + + # HOTPATCH {{{ + my $xclose = \&IPC::Open3::xclose; + no warnings; + local *IPC::Open3::xclose = sub { + my $fh = shift; + no strict 'refs'; + return if ( fileno($fh) == fileno(STDIN) ); + $xclose->($fh); + }; + + # }}} + + if ($IS_WIN32) { + $err = $merge ? '' : '>&STDERR'; + eval { + $pid = open3( + '<&STDIN', $out, $merge ? '' : $err, + @command + ); + }; + die "Could not execute (@command): $@" if $@; + if ( $] >= 5.006 ) { + binmode($out, ":crlf"); + } + } + else { + $err = $merge ? '' : IO::Handle->new; + eval { $pid = open3( '<&STDIN', $out, $err, @command ); }; + die "Could not execute (@command): $@" if $@; + $sel = $merge ? undef : IO::Select->new( $out, $err ); + } + } + else { + $err = ''; + my $exec = shift @command; + $exec = qq{"$exec"} if $exec =~ /\s/ and -x $exec; + my $command + = join( ' ', $exec, map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command ); + open( $out, "$command|" ) + or die "Could not execute ($command): $!"; + } + + $self->{out} = $out; + $self->{err} = $err; + $self->{sel} = $sel; + $self->{pid} = $pid; + $self->{exit} = undef; + $self->{chunk_size} = $chunk_size; + + if ( my $teardown = delete $args->{teardown} ) { + $self->{teardown} = sub { + $teardown->(@command); + }; + } + + return $self; +} + +=head3 C + +Upgrade the input stream to handle UTF8. + +=cut + +sub handle_unicode { + my $self = shift; + + if ( $self->{sel} ) { + if ( _get_unicode() ) { + + # Make sure our iterator has been constructed and... + my $next = $self->{_next} ||= $self->_next; + + # ...wrap it to do UTF8 casting + $self->{_next} = sub { + my $line = $next->(); + return decode_utf8($line) if defined $line; + return; + }; + } + } + else { + if ( $] >= 5.008 ) { + eval 'binmode($self->{out}, ":utf8")'; + } + } + +} + +############################################################################## + +sub wait { shift->{wait} } +sub exit { shift->{exit} } + +sub _next { + my $self = shift; + + if ( my $out = $self->{out} ) { + if ( my $sel = $self->{sel} ) { + my $err = $self->{err}; + my @buf = (); + my $partial = ''; # Partial line + my $chunk_size = $self->{chunk_size}; + return sub { + return shift @buf if @buf; + + READ: + while ( my @ready = $sel->can_read ) { + for my $fh (@ready) { + my $got = sysread $fh, my ($chunk), $chunk_size; + + if ( $got == 0 ) { + $sel->remove($fh); + } + elsif ( $fh == $err ) { + print STDERR $chunk; # echo STDERR + } + else { + $chunk = $partial . $chunk; + $partial = ''; + + # Make sure we have a complete line + unless ( substr( $chunk, -1, 1 ) eq "\n" ) { + my $nl = rindex $chunk, "\n"; + if ( $nl == -1 ) { + $partial = $chunk; + redo READ; + } + else { + $partial = substr( $chunk, $nl + 1 ); + $chunk = substr( $chunk, 0, $nl ); + } + } + + push @buf, split /\n/, $chunk; + return shift @buf if @buf; + } + } + } + + # Return partial last line + if ( length $partial ) { + my $last = $partial; + $partial = ''; + return $last; + } + + $self->_finish; + return; + }; + } + else { + return sub { + local $/ = "\n"; # to ensure lines + if ( defined( my $line = <$out> ) ) { + chomp $line; + return $line; + } + $self->_finish; + return; + }; + } + } + else { + return sub { + $self->_finish; + return; + }; + } +} + +sub next_raw { + my $self = shift; + return ( $self->{_next} ||= $self->_next )->(); +} + +sub _finish { + my $self = shift; + + my $status = $?; + + # Avoid circular refs + $self->{_next} = sub {return} + if $] >= 5.006; + + # If we have a subprocess we need to wait for it to terminate + if ( defined $self->{pid} ) { + if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) { + $status = $?; + } + } + + ( delete $self->{out} )->close if $self->{out}; + + # If we have an IO::Select we also have an error handle to close. + if ( $self->{sel} ) { + ( delete $self->{err} )->close; + delete $self->{sel}; + } + else { + $status = $?; + } + + # Sometimes we get -1 on Windows. Presumably that means status not + # available. + $status = 0 if $IS_WIN32 && $status == -1; + + $self->{wait} = $status; + $self->{exit} = $self->_wait2exit($status); + + if ( my $teardown = $self->{teardown} ) { + $teardown->(); + } + + return $self; +} + +=head3 C + +Return a list of filehandles that may be used upstream in a select() +call to signal that this Iterator is ready. Iterators that are not +handle based should return an empty list. + +=cut + +sub get_select_handles { + my $self = shift; + return grep $_, ( $self->{out}, $self->{err} ); +} + +1; + +=head1 ATTRIBUTION + +Originally ripped off from L. + +=head1 SEE ALSO + +L, +L, +L, + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Stream.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Stream.pm new file mode 100755 index 0000000000..abee22906f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Iterator/Stream.pm @@ -0,0 +1,116 @@ +package TAP::Parser::Iterator::Stream; + +use strict; +use warnings; + +use base 'TAP::Parser::Iterator'; + +=head1 NAME + +TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Iterator::Stream; + open( TEST, 'test.tap' ); + my $it = TAP::Parser::Iterator::Stream->new(\*TEST); + my $line = $it->next; + +=head1 DESCRIPTION + +This is a simple iterator wrapper for reading from filehandles, used by +L. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Create an iterator. Expects one argument containing a filehandle. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my ( $self, $thing ) = @_; + $self->{fh} = $thing; + return $self; +} + +=head2 Instance Methods + +=head3 C + +Iterate through it, of course. + +=head3 C + +Iterate raw input without applying any fixes for quirky input syntax. + +=head3 C + +Get the wait status for this iterator. Always returns zero. + +=head3 C + +Get the exit status for this iterator. Always returns zero. + +=cut + +sub wait { shift->exit } +sub exit { shift->{fh} ? () : 0 } + +sub next_raw { + my $self = shift; + my $fh = $self->{fh}; + + if ( defined( my $line = <$fh> ) ) { + chomp $line; + return $line; + } + else { + $self->_finish; + return; + } +} + +sub _finish { + my $self = shift; + close delete $self->{fh}; +} + +sub get_select_handles { + my $self = shift; + + # return our handle in case it's a socket or pipe (select()-able) + return ( $self->{fh}, ) + if (-S $self->{fh} || -p $self->{fh}); + + return; +} + +1; + +=head1 ATTRIBUTION + +Originally ripped off from L. + +=head1 SEE ALSO + +L, +L, +L, + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/IteratorFactory.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/IteratorFactory.pm new file mode 100755 index 0000000000..4353f0aa96 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/IteratorFactory.pm @@ -0,0 +1,339 @@ +package TAP::Parser::IteratorFactory; + +use strict; +use warnings; + +use Carp qw( confess ); +use File::Basename qw( fileparse ); + +use base 'TAP::Object'; + +use constant handlers => []; + +=head1 NAME + +TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::IteratorFactory; + my $factory = TAP::Parser::IteratorFactory->new({ %config }); + my $iterator = $factory->make_iterator( $filename ); + +=head1 DESCRIPTION + +This is a factory class that takes a L 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 + +=head2 Class Methods + +=head3 C + +Creates a new factory class: + + my $sf = TAP::Parser::IteratorFactory->new( $config ); + +C<$config> is optional. If given, sets L and calls L. + +=cut + +sub _initialize { + my ( $self, $config ) = @_; + $self->config( $config || {} )->load_handlers; + return $self; +} + +=head3 C + +Registers a new L with this factory. + + __PACKAGE__->register_handler( $handler_class ); + +=head3 C + +List of handlers that have been registered. + +=cut + +sub register_handler { + my ( $class, $dclass ) = @_; + + confess("$dclass must implement can_handle & make_iterator methods!") + unless UNIVERSAL::can( $dclass, 'can_handle' ) + && UNIVERSAL::can( $dclass, 'make_iterator' ); + + my $handlers = $class->handlers; + push @{$handlers}, $dclass + unless grep { $_ eq $dclass } @{$handlers}; + + return $class; +} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + 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 + + $sf->load_handlers; + +Loads the handler classes defined in L. For example, given a config: + + $sf->config({ + MySourceHandler => { some => 'config' }, + }); + +C will attempt to load the C class by looking in +C<@INC> for it in this order: + + TAP::Parser::SourceHandler::MySourceHandler + MySourceHandler + +Cs on error. + +=cut + +sub load_handlers { + my ($self) = @_; + for my $handler ( keys %{ $self->config } ) { + my $sclass = $self->_load_handler($handler); + + # TODO: store which class we loaded anywhere? + } + return $self; +} + +sub _load_handler { + my ( $self, $handler ) = @_; + + my @errors; + for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) { + return $dclass + if UNIVERSAL::can( $dclass, 'can_handle' ) + && UNIVERSAL::can( $dclass, 'make_iterator' ); + + eval "use $dclass"; + if ( my $e = $@ ) { + push @errors, $e; + next; + } + + return $dclass + if UNIVERSAL::can( $dclass, 'can_handle' ) + && UNIVERSAL::can( $dclass, 'make_iterator' ); + push @errors, + "handler '$dclass' does not implement can_handle & make_iterator"; + } + + $self->_croak( + "Cannot load handler '$handler': " . join( "\n", @errors ) ); +} + +############################################################################## + +=head3 C + + 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; +} + +=head3 C + +Given a L, detects what kind of source it is and +returns I L (the most confident one). Dies +on error. + +The detection algorithm works something like this: + + for (@registered_handlers) { + # ask them how confident they are about handling this source + $confidence{$handler} = $handler->can_handle( $source ) + } + # choose the most confident handler + +Ties are handled by choosing the first handler. + +=cut + +sub detect_source { + my ( $self, $source ) = @_; + + confess('no raw source ref defined!') unless defined $source->raw; + + # find a list of handlers that can handle this source: + my %confidence_for; + for my $handler ( @{ $self->handlers } ) { + my $confidence = $handler->can_handle($source); + # warn "handler: $handler: $confidence\n"; + $confidence_for{$handler} = $confidence if $confidence; + } + + if ( !%confidence_for ) { + # error: can't detect source + my $raw_source_short = substr( ${ $source->raw }, 0, 50 ); + confess("Cannot detect source of '$raw_source_short'!"); + return; + } + + # if multiple handlers can handle it, choose the most confident one + my @handlers = + sort { $confidence_for{$b} <=> $confidence_for{$a} } + keys %confidence_for; + + # Check for a tie. + if( @handlers > 1 && + $confidence_for{$handlers[0]} == $confidence_for{$handlers[1]} + ) { + my $filename = $source->meta->{file}{basename}; + die("There is a tie between $handlers[0] and $handlers[1].\n". + "Both voted $confidence_for{$handlers[0]} on $filename.\n"); + } + + # this is really useful for debugging handlers: + if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) { + warn( + "votes: ", + join( ', ', map {"$_: $confidence_for{$_}"} @handlers ), + "\n" + ); + } + + # return 1st + return $handlers[0]; +} + +1; + +__END__ + +=head1 SUBCLASSING + +Please see L 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 base 'TAP::Parser::IteratorFactory'; + + # override source detection algorithm + sub detect_source { + my ($self, $raw_source_ref, $meta) = @_; + # do detective work, using $meta and whatever else... + } + + 1; + +=head1 AUTHORS + +Steve Purkis + +=head1 ATTRIBUTION + +Originally ripped off from L. + +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 + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Multiplexer.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Multiplexer.pm new file mode 100755 index 0000000000..aa3e864d79 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Multiplexer.pm @@ -0,0 +1,196 @@ +package TAP::Parser::Multiplexer; + +use strict; +use warnings; + +use IO::Select; +use Errno; + +use base 'TAP::Object'; + +use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/; +use constant IS_VMS => $^O eq 'VMS'; +use constant SELECT_OK => !( IS_VMS || IS_WIN32 ); + +=head1 NAME + +TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Multiplexer; + + my $mux = TAP::Parser::Multiplexer->new; + $mux->add( $parser1, $stash1 ); + $mux->add( $parser2, $stash2 ); + while ( my ( $parser, $stash, $result ) = $mux->next ) { + # do stuff + } + +=head1 DESCRIPTION + +C gathers input from multiple TAP::Parsers. +Internally it calls select on the input file handles for those parsers +to wait for one or more of them to have input available. + +See L for an example of its use. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $mux = TAP::Parser::Multiplexer->new; + +Returns a new C object. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my $self = shift; + $self->{select} = IO::Select->new; + $self->{avid} = []; # Parsers that can't select + $self->{count} = 0; + return $self; +} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + $mux->add( $parser, $stash ); + +Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque +reference that will be returned from C along with the parser and +the next result. + +=cut + +sub add { + my ( $self, $parser, $stash ) = @_; + + if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) { + my $sel = $self->{select}; + + # We have to turn handles into file numbers here because by + # the time we want to remove them from our IO::Select they + # will already have been closed by the iterator. + my @filenos = map { fileno $_ } @handles; + for my $h (@handles) { + $sel->add( [ $h, $parser, $stash, @filenos ] ); + } + + $self->{count}++; + } + else { + push @{ $self->{avid} }, [ $parser, $stash ]; + } +} + +=head3 C + + my $count = $mux->parsers; + +Returns the number of parsers. Parsers are removed from the multiplexer +when their input is exhausted. + +=cut + +sub parsers { + my $self = shift; + return $self->{count} + scalar @{ $self->{avid} }; +} + +sub _iter { + my $self = shift; + + my $sel = $self->{select}; + my $avid = $self->{avid}; + my @ready = (); + + return sub { + + # Drain all the non-selectable parsers first + if (@$avid) { + my ( $parser, $stash ) = @{ $avid->[0] }; + my $result = $parser->next; + shift @$avid unless defined $result; + return ( $parser, $stash, $result ); + } + + until (@ready) { + return unless $sel->count; + @ready = $sel->can_read; + last if @ready || !$!{EINTR}; + } + + my ( $h, $parser, $stash, @handles ) = @{ shift @ready }; + my $result = $parser->next; + + unless ( defined $result ) { + $sel->remove(@handles); + $self->{count}--; + + # Force another can_read - we may now have removed a handle + # thought to have been ready. + @ready = (); + } + + return ( $parser, $stash, $result ); + }; +} + +=head3 C + +Return a result from the next available parser. Returns a list +containing the parser from which the result came, the stash that +corresponds with that parser and the result. + + my ( $parser, $stash, $result ) = $mux->next; + +If C<$result> is undefined the corresponding parser has reached the end +of its input (and will automatically be removed from the multiplexer). + +When all parsers are exhausted an empty list will be returned. + + if ( my ( $parser, $stash, $result ) = $mux->next ) { + if ( ! defined $result ) { + # End of this parser + } + else { + # Process result + } + } + else { + # All parsers finished + } + +=cut + +sub next { + my $self = shift; + return ( $self->{_iter} ||= $self->_iter )->(); +} + +=head1 See Also + +L + +L + +=cut + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result.pm new file mode 100755 index 0000000000..4083a29d09 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result.pm @@ -0,0 +1,297 @@ +package TAP::Parser::Result; + +use strict; +use warnings; + +use base 'TAP::Object'; + +BEGIN { + + # make is_* methods + my @attrs = qw( plan pragma test comment bailout version unknown yaml ); + no strict 'refs'; + for my $token (@attrs) { + my $method = "is_$token"; + *$method = sub { return $token eq shift->type }; + } +} + +############################################################################## + +=head1 NAME + +TAP::Parser::Result - Base class for TAP::Parser output objects + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + # abstract class - not meant to be used directly + # see TAP::Parser::ResultFactory for preferred usage + + # directly: + use TAP::Parser::Result; + my $token = {...}; + my $result = TAP::Parser::Result->new( $token ); + +=head2 DESCRIPTION + +This is a simple base class used by L to store objects that +represent the current bit of test output data from TAP (usually a single +line). Unless you're subclassing, you probably won't need to use this module +directly. + +=head2 METHODS + +=head3 C + + # see TAP::Parser::ResultFactory for preferred usage + + # to use directly: + my $result = TAP::Parser::Result->new($token); + +Returns an instance the appropriate class for the test token passed in. + +=cut + +# new() implementation provided by TAP::Object + +sub _initialize { + my ( $self, $token ) = @_; + if ($token) { + + # assign to a hash slice to make a shallow copy of the token. + # I guess we could assign to the hash as (by default) there are not + # contents, but that seems less helpful if someone wants to subclass us + @{$self}{ keys %$token } = values %$token; + } + return $self; +} + +############################################################################## + +=head2 Boolean methods + +The following methods all return a boolean value and are to be overridden in +the appropriate subclass. + +=over 4 + +=item * C + +Indicates whether or not this is the test plan line. + + 1..3 + +=item * C + +Indicates whether or not this is a pragma line. + + pragma +strict + +=item * C + +Indicates whether or not this is a test line. + + ok 1 Is OK! + +=item * C + +Indicates whether or not this is a comment. + + # this is a comment + +=item * C + +Indicates whether or not this is bailout line. + + Bail out! We're out of dilithium crystals. + +=item * C + +Indicates whether or not this is a TAP version line. + + TAP version 4 + +=item * C + +Indicates whether or not the current line could be parsed. + + ... this line is junk ... + +=item * C + +Indicates whether or not this is a YAML chunk. + +=back + +=cut + +############################################################################## + +=head3 C + + print $result->raw; + +Returns the original line of text which was parsed. + +=cut + +sub raw { shift->{raw} } + +############################################################################## + +=head3 C + + my $type = $result->type; + +Returns the "type" of a token, such as C or C. + +=cut + +sub type { shift->{type} } + +############################################################################## + +=head3 C + + print $result->as_string; + +Prints a string representation of the token. This might not be the exact +output, however. Tests will have test numbers added if not present, TODO and +SKIP directives will be capitalized and, in general, things will be cleaned +up. If you need the original text for the token, see the C method. + +=cut + +sub as_string { shift->{raw} } + +############################################################################## + +=head3 C + + if ( $result->is_ok ) { ... } + +Reports whether or not a given result has passed. Anything which is B a +test result returns true. This is merely provided as a convenient shortcut. + +=cut + +sub is_ok {1} + +############################################################################## + +=head3 C + +Deprecated. Please use C instead. + +=cut + +sub passed { + warn 'passed() is deprecated. Please use "is_ok()"'; + shift->is_ok; +} + +############################################################################## + +=head3 C + + if ( $result->has_directive ) { + ... + } + +Indicates whether or not the given result has a TODO or SKIP directive. + +=cut + +sub has_directive { + my $self = shift; + return ( $self->has_todo || $self->has_skip ); +} + +############################################################################## + +=head3 C + + if ( $result->has_todo ) { + ... + } + +Indicates whether or not the given result has a TODO directive. + +=cut + +sub has_todo { 'TODO' eq ( shift->{directive} || '' ) } + +############################################################################## + +=head3 C + + if ( $result->has_skip ) { + ... + } + +Indicates whether or not the given result has a SKIP directive. + +=cut + +sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) } + +=head3 C + +Set the directive associated with this token. Used internally to fake +TODO tests. + +=cut + +sub set_directive { + my ( $self, $dir ) = @_; + $self->{directive} = $dir; +} + +1; + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +Remember: if you want your subclass to be automatically used by the parser, +you'll have to register it with L. + +If you're creating a completely new result I, you'll probably need to +subclass L too, or else it'll never get used. + +=head2 Example + + package MyResult; + + use strict; + + use base 'TAP::Parser::Result'; + + # register with the factory: + TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); + + sub as_string { 'My results all look the same' } + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L, +L, +L, +L, + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Bailout.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Bailout.pm new file mode 100755 index 0000000000..9f676e629a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Bailout.pm @@ -0,0 +1,62 @@ +package TAP::Parser::Result::Bailout; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::Bailout - Bailout result token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if a bail out line is encountered. + + 1..5 + ok 1 - woo hooo! + Bail out! Well, so much for "woo hooo!" + +=head1 OVERRIDDEN METHODS + +Mainly listed here to shut up the pitiful screams of the pod coverage tests. +They keep me awake at night. + +=over 4 + +=item * C + +=back + +=cut + +############################################################################## + +=head2 Instance Methods + +=head3 C + + if ( $result->is_bailout ) { + my $explanation = $result->explanation; + print "We bailed out because ($explanation)"; + } + +If, and only if, a token is a bailout token, you can get an "explanation" via +this method. The explanation is the text after the mystical "Bail out!" words +which appear in the tap output. + +=cut + +sub explanation { shift->{bailout} } +sub as_string { shift->{bailout} } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Comment.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Comment.pm new file mode 100755 index 0000000000..7e1a81ed7f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Comment.pm @@ -0,0 +1,60 @@ +package TAP::Parser::Result::Comment; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::Comment - Comment result token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if a comment line is encountered. + + 1..1 + ok 1 - woo hooo! + # this is a comment + +=head1 OVERRIDDEN METHODS + +Mainly listed here to shut up the pitiful screams of the pod coverage tests. +They keep me awake at night. + +=over 4 + +=item * C + +Note that this method merely returns the comment preceded by a '# '. + +=back + +=cut + +############################################################################## + +=head2 Instance Methods + +=head3 C + + if ( $result->is_comment ) { + my $comment = $result->comment; + print "I have something to say: $comment"; + } + +=cut + +sub comment { shift->{comment} } +sub as_string { shift->{raw} } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Plan.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Plan.pm new file mode 100755 index 0000000000..b8ae566d66 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Plan.pm @@ -0,0 +1,119 @@ +package TAP::Parser::Result::Plan; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::Plan - Plan result token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if a plan line is encountered. + + 1..1 + ok 1 - woo hooo! + +C<1..1> is the plan. Gotta have a plan. + +=head1 OVERRIDDEN METHODS + +Mainly listed here to shut up the pitiful screams of the pod coverage tests. +They keep me awake at night. + +=over 4 + +=item * C + +=item * C + +=back + +=cut + +############################################################################## + +=head2 Instance Methods + +=head3 C + + if ( $result->is_plan ) { + print $result->plan; + } + +This is merely a synonym for C. + +=cut + +sub plan { '1..' . shift->{tests_planned} } + +############################################################################## + +=head3 C + + my $planned = $result->tests_planned; + +Returns the number of tests planned. For example, a plan of C<1..17> will +cause this method to return '17'. + +=cut + +sub tests_planned { shift->{tests_planned} } + +############################################################################## + +=head3 C + + my $directive = $plan->directive; + +If a SKIP directive is included with the plan, this method will return it. + + 1..0 # SKIP: why bother? + +=cut + +sub directive { shift->{directive} } + +############################################################################## + +=head3 C + + if ( $result->has_skip ) { ... } + +Returns a boolean value indicating whether or not this test has a SKIP +directive. + +=head3 C + + my $explanation = $plan->explanation; + +If a SKIP directive was included with the plan, this method will return the +explanation, if any. + +=cut + +sub explanation { shift->{explanation} } + +=head3 C + + my $todo = $result->todo_list; + for ( @$todo ) { + ... + } + +=cut + +sub todo_list { shift->{todo_list} } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Pragma.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Pragma.pm new file mode 100755 index 0000000000..debc8a7626 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Pragma.pm @@ -0,0 +1,62 @@ +package TAP::Parser::Result::Pragma; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::Pragma - TAP pragma token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if a pragma is encountered. + + TAP version 13 + pragma +strict, -foo + +Pragmas are only supported from TAP version 13 onwards. + +=head1 OVERRIDDEN METHODS + +Mainly listed here to shut up the pitiful screams of the pod coverage tests. +They keep me awake at night. + +=over 4 + +=item * C + +=item * C + +=back + +=cut + +############################################################################## + +=head2 Instance Methods + +=head3 C + +if ( $result->is_pragma ) { + @pragmas = $result->pragmas; +} + +=cut + +sub pragmas { + my @pragmas = @{ shift->{pragmas} }; + return wantarray ? @pragmas : \@pragmas; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Test.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Test.pm new file mode 100755 index 0000000000..5e5ea395a2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Test.pm @@ -0,0 +1,271 @@ +package TAP::Parser::Result::Test; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::Test - Test result token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if a test line is encountered. + + 1..1 + ok 1 - woo hooo! + +=head1 OVERRIDDEN METHODS + +This class is the workhorse of the L system. Most TAP lines will +be test lines and if C<< $result->is_test >>, then you have a bunch of methods +at your disposal. + +=head2 Instance Methods + +=cut + +############################################################################## + +=head3 C + + my $ok = $result->ok; + +Returns the literal text of the C or C status. + +=cut + +sub ok { shift->{ok} } + +############################################################################## + +=head3 C + + my $test_number = $result->number; + +Returns the number of the test, even if the original TAP output did not supply +that number. + +=cut + +sub number { shift->{test_num} } + +sub _number { + my ( $self, $number ) = @_; + $self->{test_num} = $number; +} + +############################################################################## + +=head3 C + + my $description = $result->description; + +Returns the description of the test, if any. This is the portion after the +test number but before the directive. + +=cut + +sub description { shift->{description} } + +############################################################################## + +=head3 C + + my $directive = $result->directive; + +Returns either C or C if either directive was present for a test +line. + +=cut + +sub directive { shift->{directive} } + +############################################################################## + +=head3 C + + my $explanation = $result->explanation; + +If a test had either a C or C directive, this method will return +the accompanying explanation, if present. + + not ok 17 - 'Pigs can fly' # TODO not enough acid + +For the above line, the explanation is I. + +=cut + +sub explanation { shift->{explanation} } + +############################################################################## + +=head3 C + + if ( $result->is_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed. Remember +that for TODO tests, the test always passes. + +If the test is unplanned, this method will always return false. See +C. + +=cut + +sub is_ok { + my $self = shift; + + return if $self->is_unplanned; + + # TODO directives reverse the sense of a test. + return $self->has_todo ? 1 : $self->ok !~ /not/; +} + +############################################################################## + +=head3 C + + if ( $result->is_actual_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed, regardless +of its TODO status. + +=cut + +sub is_actual_ok { + my $self = shift; + return $self->{ok} !~ /not/; +} + +############################################################################## + +=head3 C + +Deprecated. Please use C instead. + +=cut + +sub actual_passed { + warn 'actual_passed() is deprecated. Please use "is_actual_ok()"'; + goto &is_actual_ok; +} + +############################################################################## + +=head3 C + + if ( $test->todo_passed ) { + # test unexpectedly succeeded + } + +If this is a TODO test and an 'ok' line, this method returns true. +Otherwise, it will always return false (regardless of passing status on +non-todo tests). + +This is used to track which tests unexpectedly succeeded. + +=cut + +sub todo_passed { + my $self = shift; + return $self->has_todo && $self->is_actual_ok; +} + +############################################################################## + +=head3 C + + # deprecated in favor of 'todo_passed'. This method was horribly misnamed. + +This was a badly misnamed method. It indicates which TODO tests unexpectedly +succeeded. Will now issue a warning and call C. + +=cut + +sub todo_failed { + warn 'todo_failed() is deprecated. Please use "todo_passed()"'; + goto &todo_passed; +} + +############################################################################## + +=head3 C + + if ( $result->has_skip ) { ... } + +Returns a boolean value indicating whether or not this test has a SKIP +directive. + +=head3 C + + if ( $result->has_todo ) { ... } + +Returns a boolean value indicating whether or not this test has a TODO +directive. + +=head3 C + + print $result->as_string; + +This method prints the test as a string. It will probably be similar, but +not necessarily identical, to the original test line. Directives are +capitalized, some whitespace may be trimmed and a test number will be added if +it was not present in the original line. If you need the original text of the +test line, use the C method. + +=cut + +sub as_string { + my $self = shift; + my $string = $self->ok . " " . $self->number; + if ( my $description = $self->description ) { + $string .= " $description"; + } + if ( my $directive = $self->directive ) { + my $explanation = $self->explanation; + $string .= " # $directive $explanation"; + } + return $string; +} + +############################################################################## + +=head3 C + + if ( $test->is_unplanned ) { ... } + $test->is_unplanned(1); + +If a test number is greater than the number of planned tests, this method will +return true. Unplanned tests will I return false for C, +regardless of whether or not the test C. + +Note that if tests have a trailing plan, it is not possible to set this +property for unplanned tests as we do not know it's unplanned until the plan +is reached: + + print <<'END'; + ok 1 + ok 2 + 1..1 + END + +=cut + +sub is_unplanned { + my $self = shift; + return ( $self->{unplanned} || '' ) unless @_; + $self->{unplanned} = !!shift; + return $self; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Unknown.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Unknown.pm new file mode 100755 index 0000000000..c46e8d9566 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Unknown.pm @@ -0,0 +1,48 @@ +package TAP::Parser::Result::Unknown; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::Unknown - Unknown result token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if the parser does not recognize the token line. For example: + + 1..5 + VERSION 7 + ok 1 - woo hooo! + ... woo hooo! is cool! + +In the above "TAP", the second and fourth lines will generate "Unknown" +tokens. + +=head1 OVERRIDDEN METHODS + +Mainly listed here to shut up the pitiful screams of the pod coverage tests. +They keep me awake at night. + +=over 4 + +=item * C + +=item * C + +=back + +=cut + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Version.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Version.pm new file mode 100755 index 0000000000..497c10d567 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/Version.pm @@ -0,0 +1,62 @@ +package TAP::Parser::Result::Version; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::Version - TAP syntax version token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if a version line is encountered. + + TAP version 13 + ok 1 + not ok 2 + +The first version of TAP to include an explicit version number is 13. + +=head1 OVERRIDDEN METHODS + +Mainly listed here to shut up the pitiful screams of the pod coverage tests. +They keep me awake at night. + +=over 4 + +=item * C + +=item * C + +=back + +=cut + +############################################################################## + +=head2 Instance Methods + +=head3 C + + if ( $result->is_version ) { + print $result->version; + } + +This is merely a synonym for C. + +=cut + +sub version { shift->{version} } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/YAML.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/YAML.pm new file mode 100755 index 0000000000..e6ca7466e9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Result/YAML.pm @@ -0,0 +1,61 @@ +package TAP::Parser::Result::YAML; + +use strict; +use warnings; + +use base 'TAP::Parser::Result'; + +=head1 NAME + +TAP::Parser::Result::YAML - YAML result token. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This is a subclass of L. A token of this class will be +returned if a YAML block is encountered. + + 1..1 + ok 1 - woo hooo! + +C<1..1> is the plan. Gotta have a plan. + +=head1 OVERRIDDEN METHODS + +Mainly listed here to shut up the pitiful screams of the pod coverage tests. +They keep me awake at night. + +=over 4 + +=item * C + +=item * C + +=back + +=cut + +############################################################################## + +=head2 Instance Methods + +=head3 C + + if ( $result->is_yaml ) { + print $result->data; + } + +Return the parsed YAML data for this result + +=cut + +sub data { shift->{data} } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/ResultFactory.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/ResultFactory.pm new file mode 100755 index 0000000000..ff7ef4addb --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/ResultFactory.pm @@ -0,0 +1,183 @@ +package TAP::Parser::ResultFactory; + +use strict; +use warnings; + +use TAP::Parser::Result::Bailout (); +use TAP::Parser::Result::Comment (); +use TAP::Parser::Result::Plan (); +use TAP::Parser::Result::Pragma (); +use TAP::Parser::Result::Test (); +use TAP::Parser::Result::Unknown (); +use TAP::Parser::Result::Version (); +use TAP::Parser::Result::YAML (); + +use base 'TAP::Object'; + +############################################################################## + +=head1 NAME + +TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects + +=head1 SYNOPSIS + + use TAP::Parser::ResultFactory; + my $token = {...}; + my $factory = TAP::Parser::ResultFactory->new; + my $result = $factory->make_result( $token ); + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head2 DESCRIPTION + +This is a simple factory class which returns a L subclass +representing the current bit of test data from TAP (usually a single line). +It is used primarily by L. Unless you're subclassing, +you probably won't need to use this module directly. + +=head2 METHODS + +=head2 Class Methods + +=head3 C + +Creates a new factory class. +I You currently don't need to instantiate a factory in order to use it. + +=head3 C + +Returns an instance the appropriate class for the test token passed in. + + my $result = TAP::Parser::ResultFactory->make_result($token); + +Can also be called as an instance method. + +=cut + +sub make_result { + my ( $proto, $token ) = @_; + my $type = $token->{type}; + return $proto->class_for($type)->new($token); +} + +=head3 C + +Takes one argument: C<$type>. Returns the class for this $type, or Cs +with an error. + +=head3 C + +Takes two arguments: C<$type>, C<$class> + +This lets you override an existing type with your own custom type, or register +a completely new type, eg: + + # create a custom result type: + package MyResult; + use strict; + use base 'TAP::Parser::Result'; + + # register with the factory: + TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); + + # use it: + my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } ); + +Your custom type should then be picked up automatically by the L. + +=cut + +our %CLASS_FOR = ( + plan => 'TAP::Parser::Result::Plan', + pragma => 'TAP::Parser::Result::Pragma', + test => 'TAP::Parser::Result::Test', + comment => 'TAP::Parser::Result::Comment', + bailout => 'TAP::Parser::Result::Bailout', + version => 'TAP::Parser::Result::Version', + unknown => 'TAP::Parser::Result::Unknown', + yaml => 'TAP::Parser::Result::YAML', +); + +sub class_for { + my ( $class, $type ) = @_; + + # return target class: + return $CLASS_FOR{$type} if exists $CLASS_FOR{$type}; + + # or complain: + require Carp; + Carp::croak("Could not determine class for result type '$type'"); +} + +sub register_type { + my ( $class, $type, $rclass ) = @_; + + # register it blindly, assume they know what they're doing + $CLASS_FOR{$type} = $rclass; + return $class; +} + +1; + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +There are a few things to bear in mind when creating your own +C: + +=over 4 + +=item 1 + +The factory itself is never instantiated (this I change in the future). +This means that C<_initialize> is never called. + +=item 2 + +Cnew> is never called, $tokens are reblessed. +This I change in a future version! + +=item 3 + +L subclasses will register themselves with +L directly: + + package MyFooResult; + TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ ); + +Of course, it's up to you to decide whether or not to ignore them. + +=back + +=head2 Example + + package MyResultFactory; + + use strict; + + use MyResult; + + use base 'TAP::Parser::ResultFactory'; + + # force all results to be 'MyResult' + sub class_for { + return 'MyResult'; + } + + 1; + +=head1 SEE ALSO + +L, +L, +L + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler.pm new file mode 100755 index 0000000000..e7afbf6d62 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler.pm @@ -0,0 +1,448 @@ +package TAP::Parser::Scheduler; + +use strict; +use warnings; + +use Carp; +use TAP::Parser::Scheduler::Job; +use TAP::Parser::Scheduler::Spinner; + +=head1 NAME + +TAP::Parser::Scheduler - Schedule tests during parallel testing + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Scheduler; + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $sched = TAP::Parser::Scheduler->new(tests => \@tests); + my $sched = TAP::Parser::Scheduler->new( + tests => [ ['t/test_name.t','Test Description'], ... ], + rules => \%rules, + ); + +Given 'tests' and optional 'rules' as input, returns a new +C object. Each member of C<@tests> should be either a +a test file name, or a two element arrayref, where the first element is a test +file name, and the second element is a test description. By default, we'll use +the test name as the description. + +The optional C attribute provides direction on which tests should be run +in parallel and which should be run sequentially. If no rule data structure is +provided, a default data structure is used which makes every test eligible to +be run in parallel: + + { par => '**' }, + +The rules data structure is documented more in the next section. + +=head2 Rules data structure + +The "C" data structure is the the heart of the scheduler. It allows you +to express simple rules like "run all tests in sequence" or "run all tests in +parallel except these five tests.". However, the rules structure also supports +glob-style pattern matching and recursive definitions, so you can also express +arbitarily complicated patterns. + +The rule must only have one top level key: either 'par' for "parallel" or 'seq' +for "sequence". + +Values must be either strings with possible glob-style matching, or arrayrefs +of strings or hashrefs which follow this pattern recursively. + +Every element in an arrayref directly below a 'par' key is eligible to be run +in parallel, while vavalues directly below a 'seq' key must be run in sequence. + +=head3 Rules examples + +Here are some examples: + + # All tests be run in parallel (the default rule) + { par => '**' }, + + # Run all tests in sequence, except those starting with "p" + { par => 't/p*.t' }, + + # Run all tests in parallel, except those starting with "p" + { + seq => [ + { seq => 't/p*.t' }, + { par => '**' }, + ], + } + + # Run some startup tests in sequence, then some parallel tests then some + # teardown tests in sequence. + { + seq => [ + { seq => 't/startup/*.t' }, + { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } + { seq => 't/shutdown/*.t' }, + ], + }, + + +=head3 Rules resolution + +=over 4 + +=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one. + +=item * "First match wins". The first rule that matches a test will be the one that applies. + +=item * Any test which does not match a rule will be run in sequence at the end of the run. + +=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run. + +=item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C in your Harness object. + +=back + +=head3 Glob-style pattern matching for rules + +We implement our own glob-style pattern matching. Here are the patterns it supports: + + ** is any number of characters, including /, within a pathname + * is zero or more characters within a filename/directory name + ? is exactly one character within a filename/directory name + {foo,bar,baz} is any of foo, bar or baz. + \ is an escape character + +=cut + +sub new { + my $class = shift; + + croak "Need a number of key, value pairs" if @_ % 2; + + my %args = @_; + my $tests = delete $args{tests} || croak "Need a 'tests' argument"; + my $rules = delete $args{rules} || { par => '**' }; + + croak "Unknown arg(s): ", join ', ', sort keys %args + if keys %args; + + # Turn any simple names into a name, description pair. TODO: Maybe + # construct jobs here? + my $self = bless {}, $class; + + $self->_set_rules( $rules, $tests ); + + return $self; +} + +# Build the scheduler data structure. +# +# SCHEDULER-DATA ::= JOB +# || ARRAY OF ARRAY OF SCHEDULER-DATA +# +# The nested arrays are the key to scheduling. The outer array contains +# a list of things that may be executed in parallel. Whenever an +# eligible job is sought any element of the outer array that is ready to +# execute can be selected. The inner arrays represent sequential +# execution. They can only proceed when the first job is ready to run. + +sub _set_rules { + my ( $self, $rules, $tests ) = @_; + + # Convert all incoming tests to job objects. + # If no test description is provided use the file name as the description. + my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) } + map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests; + my $schedule = $self->_rule_clause( $rules, \@tests ); + + # If any tests are left add them as a sequential block at the end of + # the run. + $schedule = [ [ $schedule, @tests ] ] if @tests; + + $self->{schedule} = $schedule; +} + +sub _rule_clause { + my ( $self, $rule, $tests ) = @_; + croak 'Rule clause must be a hash' + unless 'HASH' eq ref $rule; + + my @type = keys %$rule; + croak 'Rule clause must have exactly one key' + unless @type == 1; + + my %handlers = ( + par => sub { + [ map { [$_] } @_ ]; + }, + seq => sub { [ [@_] ] }, + ); + + my $handler = $handlers{ $type[0] } + || croak 'Unknown scheduler type: ', $type[0]; + my $val = $rule->{ $type[0] }; + + return $handler->( + map { + 'HASH' eq ref $_ + ? $self->_rule_clause( $_, $tests ) + : $self->_expand( $_, $tests ) + } 'ARRAY' eq ref $val ? @$val : $val + ); +} + +sub _glob_to_regexp { + my ( $self, $glob ) = @_; + my $nesting; + my $pattern; + + while (1) { + if ( $glob =~ /\G\*\*/gc ) { + + # ** is any number of characters, including /, within a pathname + $pattern .= '.*?'; + } + elsif ( $glob =~ /\G\*/gc ) { + + # * is zero or more characters within a filename/directory name + $pattern .= '[^/]*'; + } + elsif ( $glob =~ /\G\?/gc ) { + + # ? is exactly one character within a filename/directory name + $pattern .= '[^/]'; + } + elsif ( $glob =~ /\G\{/gc ) { + + # {foo,bar,baz} is any of foo, bar or baz. + $pattern .= '(?:'; + ++$nesting; + } + elsif ( $nesting and $glob =~ /\G,/gc ) { + + # , is only special inside {} + $pattern .= '|'; + } + elsif ( $nesting and $glob =~ /\G\}/gc ) { + + # } that matches { is special. But unbalanced } are not. + $pattern .= ')'; + --$nesting; + } + elsif ( $glob =~ /\G(\\.)/gc ) { + + # A quoted literal + $pattern .= $1; + } + elsif ( $glob =~ /\G([\},])/gc ) { + + # Sometimes meta characters + $pattern .= '\\' . $1; + } + else { + + # Eat everything that is not a meta character. + $glob =~ /\G([^{?*\\\},]*)/gc; + $pattern .= quotemeta $1; + } + return $pattern if pos $glob == length $glob; + } +} + +sub _expand { + my ( $self, $name, $tests ) = @_; + + my $pattern = $self->_glob_to_regexp($name); + $pattern = qr/^ $pattern $/x; + my @match = (); + + for ( my $ti = 0; $ti < @$tests; $ti++ ) { + if ( $tests->[$ti]->filename =~ $pattern ) { + push @match, splice @$tests, $ti, 1; + $ti--; + } + } + + return @match; +} + +=head2 Instance Methods + +=head3 C + +Get a list of all remaining tests. + +=cut + +sub get_all { + my $self = shift; + my @all = $self->_gather( $self->{schedule} ); + $self->{count} = @all; + @all; +} + +sub _gather { + my ( $self, $rule ) = @_; + return unless defined $rule; + return $rule unless 'ARRAY' eq ref $rule; + return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule; +} + +=head3 C + +Return the next available job as L object or +C if none are available. Returns a L if +the scheduler still has pending jobs but none are available to run right now. + +=cut + +sub get_job { + my $self = shift; + $self->{count} ||= $self->get_all; + my @jobs = $self->_find_next_job( $self->{schedule} ); + if (@jobs) { + --$self->{count}; + return $jobs[0]; + } + + return TAP::Parser::Scheduler::Spinner->new + if $self->{count}; + + return; +} + +sub _not_empty { + my $ar = shift; + return 1 unless 'ARRAY' eq ref $ar; + for (@$ar) { + return 1 if _not_empty($_); + } + return; +} + +sub _is_empty { !_not_empty(@_) } + +sub _find_next_job { + my ( $self, $rule ) = @_; + + my @queue = (); + my $index = 0; + while ( $index < @$rule ) { + my $seq = $rule->[$index]; + + # Prune any exhausted items. + shift @$seq while @$seq && _is_empty( $seq->[0] ); + if (@$seq) { + if ( defined $seq->[0] ) { + if ( 'ARRAY' eq ref $seq->[0] ) { + push @queue, $seq; + } + else { + my $job = splice @$seq, 0, 1, undef; + $job->on_finish( sub { shift @$seq } ); + return $job; + } + } + ++$index; + } + else { + + # Remove the empty sub-array from the array + splice @$rule, $index, 1; + } + } + + for my $seq (@queue) { + if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) { + return @jobs; + } + } + + return; +} + +=head3 C + +Return a human readable representation of the scheduling tree. +For example: + + my @tests = (qw{ + t/startup/foo.t + t/shutdown/foo.t + + t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t + }); + my $sched = TAP::Parser::Scheduler->new( + tests => \@tests, + rules => { + seq => [ + { seq => 't/startup/*.t' }, + { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] }, + { seq => 't/shutdown/*.t' }, + ], + }, + ); + +Produces: + + par: + seq: + par: + seq: + par: + seq: + 't/startup/foo.t' + par: + seq: + 't/a/foo.t' + seq: + 't/b/foo.t' + seq: + 't/c/foo.t' + par: + seq: + 't/shutdown/foo.t' + 't/d/foo.t' + + +=cut + + +sub as_string { + my $self = shift; + return $self->_as_string( $self->{schedule} ); +} + +sub _as_string { + my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 ); + my $pad = ' ' x 2; + my $indent = $pad x $depth; + if ( !defined $rule ) { + return "$indent(undef)\n"; + } + elsif ( 'ARRAY' eq ref $rule ) { + return unless @$rule; + my $type = ( 'par', 'seq' )[ $depth % 2 ]; + return join( + '', "$indent$type:\n", + map { $self->_as_string( $_, $depth + 1 ) } @$rule + ); + } + else { + return "$indent'" . $rule->filename . "'\n"; + } +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Job.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Job.pm new file mode 100755 index 0000000000..e05661d719 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Job.pm @@ -0,0 +1,127 @@ +package TAP::Parser::Scheduler::Job; + +use strict; +use warnings; +use Carp; + +=head1 NAME + +TAP::Parser::Scheduler::Job - A single testing job. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Scheduler::Job; + +=head1 DESCRIPTION + +Represents a single test 'job'. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $job = TAP::Parser::Scheduler::Job->new( + $filename, $description + ); + +Given the filename and description of a test as scalars, returns a new +L object. + +=cut + +sub new { + my ( $class, $name, $desc, @ctx ) = @_; + return bless { + filename => $name, + description => $desc, + @ctx ? ( context => \@ctx ) : (), + }, $class; +} + +=head2 Instance Methods + +=head3 C + + $self->on_finish(\&method). + +Register a closure to be called when this job is destroyed. The callback +will be passed the C object as it's only argument. + +=cut + +sub on_finish { + my ( $self, $cb ) = @_; + $self->{on_finish} = $cb; +} + +=head3 C + + $self->finish; + +Called when a job is complete to unlock it. If a callback has been registered +with C, it calls it. Otherwise, it does nothing. + +=cut + +sub finish { + my $self = shift; + if ( my $cb = $self->{on_finish} ) { + $cb->($self); + } +} + +=head2 Attributes + + $self->filename; + $self->description; + $self->context; + +These are all "getters" which return the data set for these attributes during object construction. + + +=head3 C + +=head3 C + +=head3 C + +=cut + +sub filename { shift->{filename} } +sub description { shift->{description} } +sub context { @{ shift->{context} || [] } } + +=head3 C + +For backwards compatibility in callbacks. + +=cut + +sub as_array_ref { + my $self = shift; + return [ $self->filename, $self->description, $self->{context} ||= [] ]; +} + +=head3 C + + $self->is_spinner; + +Returns false indicating that this is a real job rather than a +'spinner'. Spinners are returned when the scheduler still has pending +jobs but can't (because of locking) return one right now. + +=cut + +sub is_spinner {0} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Spinner.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Spinner.pm new file mode 100755 index 0000000000..3d8be9ee4d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Scheduler/Spinner.pm @@ -0,0 +1,61 @@ +package TAP::Parser::Scheduler::Spinner; + +use strict; +use warnings; +use Carp; + +=head1 NAME + +TAP::Parser::Scheduler::Spinner - A no-op job. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Scheduler::Spinner; + +=head1 DESCRIPTION + +A no-op job. Returned by C as an instruction to +the harness to spin (keep executing tests) while the scheduler can't +return a real job. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $job = TAP::Parser::Scheduler::Spinner->new; + +Ignores any arguments and returns a new C object. + +=cut + +sub new { bless {}, shift } + +=head2 Instance Methods + +=head3 C + +Returns true indicating that is a 'spinner' job. Spinners are returned +when the scheduler still has pending jobs but can't (because of locking) +return one right now. + +=cut + +sub is_spinner {1} + +=head1 SEE ALSO + +L, L + +=cut + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Source.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Source.pm new file mode 100755 index 0000000000..bed0e80d1f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/Source.pm @@ -0,0 +1,381 @@ +package TAP::Parser::Source; + +use strict; +use warnings; + +use File::Basename qw( fileparse ); +use base 'TAP::Object'; + +use constant BLK_SIZE => 512; + +=head1 NAME + +TAP::Parser::Source - a TAP source & meta data about it + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + my $source = TAP::Parser::Source->new; + $source->raw( \'reference to raw TAP source' ) + ->config( \%config ) + ->merge( $boolean ) + ->switches( \@switches ) + ->test_args( \@args ) + ->assemble_meta; + + do { ... } if $source->meta->{is_file}; + # see assemble_meta for a full list of data available + +=head1 DESCRIPTION + +A TAP I 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 + +=head2 Class Methods + +=head3 C + + my $source = TAP::Parser::Source->new; + +Returns a new C object. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my ($self) = @_; + $self->meta( {} ); + $self->config( {} ); + return $self; +} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + my $raw = $source->raw; + $source->raw( $some_value ); + +Chaining getter/setter for the raw TAP source. This is a reference, as it may +contain large amounts of data (eg: raw TAP). + +=head3 C + + my $meta = $source->meta; + $source->meta({ %some_value }); + +Chaining getter/setter for meta data about the source. This defaults to an +empty hashref. See L for more info. + +=head3 C + +True if the source has meta data. + +=head3 C + + my $config = $source->config; + $source->config({ %some_value }); + +Chaining getter/setter for the source's configuration, if any has been provided +by the user. How it's used is up to you. This defaults to an empty hashref. +See L for more info. + +=head3 C + + my $merge = $source->merge; + $source->config( $bool ); + +Chaining getter/setter for the flag that dictates whether STDOUT and STDERR +should be merged (where appropriate). Defaults to undef. + +=head3 C + + my $switches = $source->switches; + $source->config([ @switches ]); + +Chaining getter/setter for the list of command-line switches that should be +passed to the source (where appropriate). Defaults to undef. + +=head3 C + + my $test_args = $source->test_args; + $source->config([ @test_args ]); + +Chaining getter/setter for the list of command-line arguments that should be +passed to the source (where appropriate). Defaults to undef. + +=cut + +sub raw { + my $self = shift; + return $self->{raw} unless @_; + $self->{raw} = shift; + return $self; +} + +sub meta { + my $self = shift; + return $self->{meta} unless @_; + $self->{meta} = shift; + return $self; +} + +sub has_meta { + return scalar %{ shift->meta } ? 1 : 0; +} + +sub config { + my $self = shift; + return $self->{config} unless @_; + $self->{config} = shift; + return $self; +} + +sub merge { + my $self = shift; + return $self->{merge} unless @_; + $self->{merge} = shift; + return $self; +} + +sub switches { + my $self = shift; + return $self->{switches} unless @_; + $self->{switches} = shift; + return $self; +} + +sub test_args { + my $self = shift; + return $self->{test_args} unless @_; + $self->{test_args} = shift; + return $self; +} + +=head3 C + + 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, + } + + # for arrays: + size => $n, + +=cut + +sub assemble_meta { + my ($self) = @_; + + return $self->meta if $self->has_meta; + + my $meta = $self->meta; + my $raw = $self->raw; + + # rudimentary is object test - if it's blessed it'll + # inherit from UNIVERSAL + $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0; + + if ( $meta->{is_object} ) { + $meta->{class} = ref($raw); + } + else { + my $ref = lc( ref($raw) ); + $meta->{"is_$ref"} = 1; + } + + if ( $meta->{is_scalar} ) { + my $source = $$raw; + $meta->{length} = length($$raw); + $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0; + + # only do file checks if it looks like a filename + if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) { + my $file = {}; + $file->{exists} = -e $source ? 1 : 0; + if ( $file->{exists} ) { + $meta->{file} = $file; + + # avoid extra system calls (see `perldoc -f -X`) + $file->{stat} = [ stat(_) ]; + $file->{empty} = -z _ ? 1 : 0; + $file->{size} = -s _; + $file->{text} = -T _ ? 1 : 0; + $file->{binary} = -B _ ? 1 : 0; + $file->{read} = -r _ ? 1 : 0; + $file->{write} = -w _ ? 1 : 0; + $file->{execute} = -x _ ? 1 : 0; + $file->{setuid} = -u _ ? 1 : 0; + $file->{setgid} = -g _ ? 1 : 0; + $file->{sticky} = -k _ ? 1 : 0; + + $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0; + $meta->{is_dir} = $file->{is_dir} = -d _ ? 1 : 0; + + # symlink check requires another system call + $meta->{is_symlink} = $file->{is_symlink} + = -l $source ? 1 : 0; + if ( $file->{is_symlink} ) { + $file->{lstat} = [ lstat(_) ]; + } + + # put together some common info about the file + ( $file->{basename}, $file->{dir}, $file->{ext} ) + = map { defined $_ ? $_ : '' } + fileparse( $source, qr/\.[^.]*/ ); + $file->{lc_ext} = lc( $file->{ext} ); + $file->{basename} .= $file->{ext} if $file->{ext}; + + if ( !$file->{is_dir} && $file->{read} ) { + eval { $file->{shebang} = $self->shebang($$raw); }; + if ( my $e = $@ ) { + warn $e; + } + } + } + } + } + elsif ( $meta->{is_array} ) { + $meta->{size} = $#$raw + 1; + } + elsif ( $meta->{is_hash} ) { + ; # do nothing + } + + return $meta; +} + +=head3 C + +Get the shebang line for a script file. + + my $shebang = TAP::Parser::Source->shebang( $some_script ); + +May be called as a class method + +=cut + +{ + + # Global shebang cache. + my %shebang_for; + + sub _read_shebang { + my ( $class, $file ) = @_; + open my $fh, '<', $file or die "Can't read $file: $!\n"; + + # Might be a binary file - so read a fixed number of bytes. + my $got = read $fh, my ($buf), BLK_SIZE; + defined $got or die "I/O error: $!\n"; + return $1 if $buf =~ /(.*)/; + return; + } + + sub shebang { + my ( $class, $file ) = @_; + $shebang_for{$file} = $class->_read_shebang($file) + unless exists $shebang_for{$file}; + return $shebang_for{$file}; + } +} + +=head3 C + + 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' ); + +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 + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler.pm new file mode 100755 index 0000000000..4d537550c2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler.pm @@ -0,0 +1,191 @@ +package TAP::Parser::SourceHandler; + +use strict; +use warnings; + +use TAP::Parser::Iterator (); +use base 'TAP::Object'; + +=head1 NAME + +TAP::Parser::SourceHandler - Base class for different TAP source handlers + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 SYNOPSIS + + # abstract class - don't use directly! + # see TAP::Parser::IteratorFactory for general usage + + # must be sub-classed for use + package MySourceHandler; + use base 'TAP::Parser::SourceHandler'; + sub can_handle { return $confidence_level } + sub make_iterator { return $iterator } + + # see example below for more details + +=head1 DESCRIPTION + +This is an abstract base class for L 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 as 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 (e.g. 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 MySourceHandler; # see TAP::Parser::SourceHandler + use TAP::Parser::IteratorFactory; + + use base 'TAP::Parser::SourceHandler'; + + TAP::Parser::IteratorFactory->register_handler( __PACKAGE__ ); + + sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + my $config = $src->config_for( $class ); + + if ($config->{accept_all}) { + return 1.0; + } elsif (my $file = $meta->{file}) { + return 0.0 unless $file->{exists}; + return 1.0 if $file->{lc_ext} eq '.tap'; + return 0.9 if $file->{shebang} && $file->{shebang} =~ /^#!.+tap/; + return 0.5 if $file->{text}; + return 0.1 if $file->{binary}; + } elsif ($meta->{scalar}) { + return 0.8 if $$raw_source_ref =~ /\d\.\.\d/; + return 0.6 if $meta->{has_newlines}; + } elsif ($meta->{array}) { + return 0.8 if $meta->{size} < 5; + return 0.6 if $raw_source_ref->[0] =~ /foo/; + return 0.5; + } elsif ($meta->{hash}) { + return 0.6 if $raw_source_ref->{foo}; + return 0.2; + } + + return 0; + } + + sub make_iterator { + my ($class, $source) = @_; + # this is where you manipulate the source and + # capture the stream of TAP in an iterator + # either pick a TAP::Parser::Iterator::* or write your own... + my $iterator = TAP::Parser::Iterator::Array->new([ 'foo', 'bar' ]); + return $iterator; + } + + 1; + +=head1 AUTHORS + +TAPx Developers. + +Source detection stuff added by Steve Purkis + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L, +L, +L + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Executable.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Executable.pm new file mode 100755 index 0000000000..e191545732 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Executable.pm @@ -0,0 +1,187 @@ +package TAP::Parser::SourceHandler::Executable; + +use strict; +use warnings; + +use File::Spec; + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); + +use base 'TAP::Parser::SourceHandler'; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP source + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=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 .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 + + 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 = File::Spec->rel2abs( ${ $source->raw } ) + if ${ $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 + +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 Carp qw( croak ); + use TAP::Parser::SourceHandler::Executable; + + use base 'TAP::Parser::SourceHandler::Executable'; + + # expect $handler->(['mytest.rb', 'cmdline', 'args']); + sub make_iterator { + my ($self, $source) = @_; + my @test_args = @{ $source->test_args }; + my $rb_file = $test_args[0]; + croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file); + return $self->SUPER::raw_source(['/usr/bin/ruby', @test_args]); + } + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/File.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/File.pm new file mode 100755 index 0000000000..9e9684e71f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/File.pm @@ -0,0 +1,136 @@ +package TAP::Parser::SourceHandler::File; + +use strict; +use warnings; + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +use base 'TAP::Parser::SourceHandler'; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::File - Stream TAP from a text file. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=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} ) { + my @exts = ref $exts eq 'ARRAY' ? @$exts : $exts; + 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/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Handle.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Handle.pm new file mode 100755 index 0000000000..e01f8afa5b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Handle.pm @@ -0,0 +1,124 @@ +package TAP::Parser::SourceHandler::Handle; + +use strict; +use warnings; + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +use base 'TAP::Parser::SourceHandler'; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=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/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Perl.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Perl.pm new file mode 100755 index 0000000000..6d9e91d0bd --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/Perl.pm @@ -0,0 +1,372 @@ +package TAP::Parser::SourceHandler::Perl; + +use strict; +use warnings; +use Config; + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => ( $^O eq 'VMS' ); + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); +use Text::ParseWords qw(shellwords); + +use base 'TAP::Parser::SourceHandler::Executable'; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=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.3 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}; + + my $shebang = $file->{shebang} || ''; + + if ( $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 + + 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 _autoflush_stdhandles { + my ($class) = @_; + + $class->_autoflush( \*STDOUT ); + $class->_autoflush( \*STDERR ); +} + +sub make_iterator { + my ( $class, $source ) = @_; + my $meta = $source->meta; + my $perl_script = ${ $source->raw }; + + $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file}; + + # TODO: does this really need to be done here? + $class->_autoflush_stdhandles; + + my ( $libs, $switches ) + = $class->_mangle_switches( + $class->_filter_libs( $class->_switches($source) ) ); + + $class->_run( $source, $libs, $switches ); +} + + +sub _has_taint_switch { + my( $class, $switches ) = @_; + + my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches}; + return $has_taint ? 1 : 0; +} + +sub _mangle_switches { + my ( $class, $libs, $switches ) = @_; + + # Taint mode ignores environment variables so we must retranslate + # PERL5LIB as -I switches and place PERL5OPT on the command line + # in order that it be seen. + if ( $class->_has_taint_switch($switches) ) { + my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : (); + return ( + $libs, + [ @{$switches}, + $class->_libs2switches([@$libs, @perl5lib]), + defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : () + ], + ); + } + + return ( $libs, $switches ); +} + +sub _filter_libs { + my ( $class, @switches ) = @_; + + my $path_sep = $Config{path_sep}; + my $path_re = qr{$path_sep}; + + # Filter out any -I switches to be handled as libs later. + # + # Nasty kludge. It might be nicer if we got the libs separately + # although at least this way we find any -I switches that were + # supplied other then as explicit libs. + # + # We filter out any names containing colons because they will break + # PERL5LIB + my @libs; + my @filtered_switches; + for (@switches) { + if ( !/$path_re/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { + push @libs, $1; + } + else { + push @filtered_switches, $_; + } + } + + return \@libs, \@filtered_switches; +} + +sub _iterator_hooks { + my ( $class, $source, $libs, $switches ) = @_; + + my $setup = sub { + if ( @{$libs} and !$class->_has_taint_switch($switches) ) { + $ENV{PERL5LIB} = join( + $Config{path_sep}, grep {defined} @{$libs}, + $ENV{PERL5LIB} + ); + } + }; + + # VMS environment variables aren't guaranteed to reset at the end of + # the process, so we need to put PERL5LIB back. + my $previous = $ENV{PERL5LIB}; + my $teardown = sub { + if ( defined $previous ) { + $ENV{PERL5LIB} = $previous; + } + else { + delete $ENV{PERL5LIB}; + } + }; + + return ( $setup, $teardown ); +} + +sub _run { + my ( $class, $source, $libs, $switches ) = @_; + + my @command = $class->_get_command_for_switches( $source, $switches ) + or $class->_croak("No command found!"); + + my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches ); + + return $class->_create_iterator( $source, \@command, $setup, $teardown ); +} + +sub _create_iterator { + my ( $class, $source, $command, $setup, $teardown ) = @_; + + return TAP::Parser::Iterator::Process->new( + { command => $command, + merge => $source->merge, + setup => $setup, + teardown => $teardown, + } + ); +} + +sub _get_command_for_switches { + my ( $class, $source, $switches ) = @_; + my $file = ${ $source->raw }; + my @args = @{ $source->test_args || [] }; + my $command = $class->get_perl; + + # XXX don't need to quote if we treat the parts as atoms (except maybe vms) + #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); + my @command = ( $command, @{$switches}, $file, @args ); + return @command; +} + +sub _libs2switches { + my $class = shift; + return map {"-I$_"} grep {$_} @{ $_[0] }; +} + +=head3 C + +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 + +Gets the version of Perl currently running the test suite. + +=cut + +sub get_perl { + my $class = shift; + return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; + return qq["$^X"] if IS_WIN32 && ( $^X =~ /[^\w\.\/\\]/ ); + return $^X; +} + +1; + +__END__ + +=head1 SUBCLASSING + +Please see L for a subclassing overview. + +=head2 Example + + package MyPerlSourceHandler; + + use strict; + + use TAP::Parser::SourceHandler::Perl; + + use base 'TAP::Parser::SourceHandler::Perl'; + + # use the version of perl from the shebang line in the test file + sub get_perl { + my $self = shift; + if (my $shebang = $self->shebang( $self->{file} )) { + $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; + return $1 if $1; + } + return $self->SUPER::get_perl(@_); + } + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/RawTAP.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/RawTAP.pm new file mode 100755 index 0000000000..c861de2717 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/SourceHandler/RawTAP.pm @@ -0,0 +1,130 @@ +package TAP::Parser::SourceHandler::RawTAP; + +use strict; +use warnings; + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Array (); + +use base 'TAP::Parser::SourceHandler'; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/array ref. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=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/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Reader.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Reader.pm new file mode 100755 index 0000000000..0250ad2983 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Reader.pm @@ -0,0 +1,347 @@ +package TAP::Parser::YAMLish::Reader; + +use strict; +use warnings; + +use base 'TAP::Object'; + +our $VERSION = '3.48'; + + # No EBCDIC support on early perls +*to_native = (ord "A" == 65 || $] < 5.008) + ? sub { return shift } + : sub { utf8::unicode_to_native(shift) }; + +# TODO: +# Handle blessed object syntax + +# Printable characters for escapes +my %UNESCAPES = ( + z => "\x00", a => "\a", t => "\t", + n => "\n", v => "\cK", f => "\f", + r => "\r", e => "\e", '\\' => '\\', +); + +my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x; +my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x; +my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x; +my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x; +my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x; +my $IS_ARRAY_LINE = qr{ ^ - \s* ($QQ_STRING|\S+) }x; + +# new() implementation supplied by TAP::Object + +sub read { + my $self = shift; + my $obj = shift; + + die "Must have a code reference to read input from" + unless ref $obj eq 'CODE'; + + $self->{reader} = $obj; + $self->{capture} = []; + + # Prime the reader + $self->_next; + return unless $self->{next}; + + my $doc = $self->_read; + + # The terminator is mandatory otherwise we'd consume a line from the + # iterator that doesn't belong to us. If we want to remove this + # restriction we'll have to implement look-ahead in the iterators. + # Which might not be a bad idea. + my $dots = $self->_peek; + die "Missing '...' at end of YAMLish" + unless defined $dots + and $dots =~ $IS_END_YAML; + + delete $self->{reader}; + delete $self->{next}; + + return $doc; +} + +sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" } + +sub _peek { + my $self = shift; + return $self->{next} unless wantarray; + my $line = $self->{next}; + $line =~ /^ (\s*) (.*) $ /x; + return ( $2, length $1 ); +} + +sub _next { + my $self = shift; + die "_next called with no reader" + unless $self->{reader}; + my $line = $self->{reader}->(); + $self->{next} = $line; + push @{ $self->{capture} }, $line; +} + +sub _read { + my $self = shift; + + my $line = $self->_peek; + + # Do we have a document header? + if ( $line =~ /^ --- (?: \s* (.+?)? \s* )? $/x ) { + $self->_next; + + return $self->_read_scalar($1) if defined $1; # Inline? + + my ( $next, $indent ) = $self->_peek; + + if ( $next =~ /^ - /x ) { + return $self->_read_array($indent); + } + elsif ( $next =~ $IS_HASH_KEY ) { + return $self->_read_hash( $next, $indent ); + } + elsif ( $next =~ $IS_END_YAML ) { + die "Premature end of YAMLish"; + } + else { + die "Unsupported YAMLish syntax: '$next'"; + } + } + else { + die "YAMLish document header not found"; + } +} + +# Parse a double quoted string +sub _read_qq { + my $self = shift; + my $str = shift; + + unless ( $str =~ s/^ " (.*?) " $/$1/x ) { + die "Internal: not a quoted string"; + } + + $str =~ s/\\"/"/gx; + $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) + / (length($1) > 1) ? pack("H2", to_native($2)) + : $UNESCAPES{$1} /gex; + return $str; +} + +# Parse a scalar string to the actual scalar +sub _read_scalar { + my $self = shift; + my $string = shift; + + return undef if $string eq '~'; + return {} if $string eq '{}'; + return [] if $string eq '[]'; + + if ( $string eq '>' || $string eq '|' ) { + + my ( $line, $indent ) = $self->_peek; + die "Multi-line scalar content missing" unless defined $line; + + my @multiline = ($line); + + while (1) { + $self->_next; + my ( $next, $ind ) = $self->_peek; + last if $ind < $indent; + + my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : ''; + push @multiline, $pad . $next; + } + + return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n"; + } + + if ( $string =~ /^ ' (.*) ' $/x ) { + ( my $rv = $1 ) =~ s/''/'/g; + return $rv; + } + + if ( $string =~ $IS_QQ_STRING ) { + return $self->_read_qq($string); + } + + if ( $string =~ /^['"]/ ) { + + # A quote with folding... we don't support that + die __PACKAGE__ . " does not support multi-line quoted scalars"; + } + + # Regular unquoted string + return $string; +} + +sub _read_nested { + my $self = shift; + + my ( $line, $indent ) = $self->_peek; + + if ( $line =~ /^ -/x ) { + return $self->_read_array($indent); + } + elsif ( $line =~ $IS_HASH_KEY ) { + return $self->_read_hash( $line, $indent ); + } + else { + die "Unsupported YAMLish syntax: '$line'"; + } +} + +# Parse an array +sub _read_array { + my ( $self, $limit ) = @_; + + my $ar = []; + + while (1) { + my ( $line, $indent ) = $self->_peek; + last + if $indent < $limit + || !defined $line + || $line =~ $IS_END_YAML; + + if ( $indent > $limit ) { + die "Array line over-indented"; + } + + if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) { + $indent += length $1; + $line =~ s/-\s+//; + push @$ar, $self->_read_hash( $line, $indent ); + } + elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) { + die "Unexpected start of YAMLish" if $line =~ /^---/; + $self->_next; + push @$ar, $self->_read_scalar($1); + } + elsif ( $line =~ /^ - \s* $/x ) { + $self->_next; + push @$ar, $self->_read_nested; + } + elsif ( $line =~ $IS_HASH_KEY ) { + $self->_next; + push @$ar, $self->_read_hash( $line, $indent, ); + } + else { + die "Unsupported YAMLish syntax: '$line'"; + } + } + + return $ar; +} + +sub _read_hash { + my ( $self, $line, $limit ) = @_; + + my $indent; + my $hash = {}; + + while (1) { + die "Badly formed hash line: '$line'" + unless $line =~ $HASH_LINE; + + my ( $key, $value ) = ( $self->_read_scalar($1), $2 ); + $self->_next; + + my ( $next_line, $next_indent ) = $self->_peek; + + if ( defined $value ) { + $hash->{$key} = $self->_read_scalar($value); + } + elsif (not defined $value # no explicit undef ("~") given + and $next_indent <= $limit # next line is same or less indentation + and $next_line !~ $IS_ARRAY_LINE) # arrays can start at same indent + { + $hash->{$key} = undef; + } + else { + $hash->{$key} = $self->_read_nested; + } + + ( $line, $indent ) = $self->_peek; + last + if $indent < $limit + || !defined $line + || $line =~ $IS_END_YAML; + } + + return $hash; +} + +1; + +__END__ + +=pod + +=head1 NAME + +TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator + +=head1 VERSION + +Version 3.48 + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Note that parts of this code were derived from L with the +permission of Adam Kennedy. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +The constructor C creates and returns an empty +C object. + + my $reader = TAP::Parser::YAMLish::Reader->new; + +=head2 Instance Methods + +=head3 C + + my $got = $reader->read($iterator); + +Read YAMLish from a L and return the data structure it +represents. + +=head3 C + + my $source = $reader->get_source; + +Return the raw YAMLish source from the most recent C. + +=head1 AUTHOR + +Andy Armstrong, + +Adam Kennedy wrote L which provided the template and many of +the YAML matching regular expressions for this module. + +=head1 SEE ALSO + +L, L, L, L, L, +L + +=head1 COPYRIGHT + +Copyright 2007-2011 Andy Armstrong. + +Portions copyright 2006-2008 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Writer.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Writer.pm new file mode 100755 index 0000000000..a11a02a285 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser/YAMLish/Writer.pm @@ -0,0 +1,263 @@ +package TAP::Parser::YAMLish::Writer; + +use strict; +use warnings; + +use base 'TAP::Object'; + +our $VERSION = '3.48'; + + # No EBCDIC support on early perls +*from_native = (ord "A" == 65 || $] < 5.008) + ? sub { return shift } + : sub { utf8::native_to_unicode(shift) }; + +my $ESCAPE_CHAR = qr{ [ [:cntrl:] \" ] }x; +my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; + +my @UNPRINTABLE; +$UNPRINTABLE[$_] = sprintf("x%02x", from_native($_)) for 0 .. ord(" ") - 1; +$UNPRINTABLE[ord "\0"] = 'z'; +$UNPRINTABLE[ord "\a"] = 'a'; +$UNPRINTABLE[ord "\t"] = 't'; +$UNPRINTABLE[ord "\n"] = 'n'; +$UNPRINTABLE[ord "\cK"] = 'v'; +$UNPRINTABLE[ord "\f"] = 'f'; +$UNPRINTABLE[ord "\r"] = 'r'; +$UNPRINTABLE[ord "\e"] = 'e'; + +# new() implementation supplied by TAP::Object + +sub write { + my $self = shift; + + die "Need something to write" + unless @_; + + my $obj = shift; + my $out = shift || \*STDOUT; + + die "Need a reference to something I can write to" + unless ref $out; + + $self->{writer} = $self->_make_writer($out); + + $self->_write_obj( '---', $obj ); + $self->_put('...'); + + delete $self->{writer}; +} + +sub _make_writer { + my $self = shift; + my $out = shift; + + my $ref = ref $out; + + if ( 'CODE' eq $ref ) { + return $out; + } + elsif ( 'ARRAY' eq $ref ) { + return sub { push @$out, shift }; + } + elsif ( 'SCALAR' eq $ref ) { + return sub { $$out .= shift() . "\n" }; + } + elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) { + return sub { print $out shift(), "\n" }; + } + + die "Can't write to $out"; +} + +sub _put { + my $self = shift; + $self->{writer}->( join '', @_ ); +} + +sub _enc_scalar { + my $self = shift; + my $val = shift; + my $rule = shift; + + return '~' unless defined $val; + + if ( $val =~ /$rule/ ) { + $val =~ s/\\/\\\\/g; + $val =~ s/"/\\"/g; + $val =~ s/ ( [[:cntrl:]] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex; + return qq{"$val"}; + } + + if ( length($val) == 0 or $val =~ /\s/ ) { + $val =~ s/'/''/; + return "'$val'"; + } + + return $val; +} + +sub _write_obj { + my $self = shift; + my $prefix = shift; + my $obj = shift; + my $indent = shift || 0; + + if ( my $ref = ref $obj ) { + my $pad = ' ' x $indent; + if ( 'HASH' eq $ref ) { + if ( keys %$obj ) { + $self->_put($prefix); + for my $key ( sort keys %$obj ) { + my $value = $obj->{$key}; + $self->_write_obj( + $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':', + $value, $indent + 1 + ); + } + } + else { + $self->_put( $prefix, ' {}' ); + } + } + elsif ( 'ARRAY' eq $ref ) { + if (@$obj) { + $self->_put($prefix); + for my $value (@$obj) { + $self->_write_obj( + $pad . '-', $value, + $indent + 1 + ); + } + } + else { + $self->_put( $prefix, ' []' ); + } + } + else { + die "Don't know how to encode $ref"; + } + } + else { + $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) ); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +TAP::Parser::YAMLish::Writer - Write YAMLish data + +=head1 VERSION + +Version 3.48 + +=head1 SYNOPSIS + + use TAP::Parser::YAMLish::Writer; + + my $data = { + one => 1, + two => 2, + three => [ 1, 2, 3 ], + }; + + my $yw = TAP::Parser::YAMLish::Writer->new; + + # Write to an array... + $yw->write( $data, \@some_array ); + + # ...an open file handle... + $yw->write( $data, $some_file_handle ); + + # ...a string ... + $yw->write( $data, \$some_string ); + + # ...or a closure + $yw->write( $data, sub { + my $line = shift; + print "$line\n"; + } ); + +=head1 DESCRIPTION + +Encodes a scalar, hash reference or array reference as YAMLish. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $writer = TAP::Parser::YAMLish::Writer->new; + +The constructor C creates and returns an empty +C object. + +=head2 Instance Methods + +=head3 C + + $writer->write($obj, $output ); + +Encode a scalar, hash reference or array reference as YAML. + + my $writer = sub { + my $line = shift; + print SOMEFILE "$line\n"; + }; + + my $data = { + one => 1, + two => 2, + three => [ 1, 2, 3 ], + }; + + my $yw = TAP::Parser::YAMLish::Writer->new; + $yw->write( $data, $writer ); + + +The C< $output > argument may be: + +=over + +=item * a reference to a scalar to append YAML to + +=item * the handle of an open file + +=item * a reference to an array into which YAML will be pushed + +=item * a code reference + +=back + +If you supply a code reference the subroutine will be called once for +each line of output with the line as its only argument. Passed lines +will have no trailing newline. + +=head1 AUTHOR + +Andy Armstrong, + +=head1 SEE ALSO + +L, L, L, L, L, +L + +=head1 COPYRIGHT + +Copyright 2007-2011 Andy Armstrong. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut + -- cgit v1.2.3