Initial Commit

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Aggregator;
+
+    my $aggregate = TAP::Parser::Aggregator->new;
+    $aggregate->add( 't/00-load.t', $load_parser );
+    $aggregate->add( 't/10-lex.t',  $lex_parser  );
+
+    my $summary = <<'END_SUMMARY';
+    Passed:  %s
+    Failed:  %s
+    Unexpectedly succeeded: %s
+    END_SUMMARY
+    printf $summary,
+           scalar $aggregate->passed,
+           scalar $aggregate->failed,
+           scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN {    # install summary methods
+    %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+      failed
+      parse_errors
+      passed
+      skipped
+      todo
+      todo_passed
+      total
+      wait
+      exit
+    );
+    $SUMMARY_METHOD_FOR{total}   = 'tests_run';
+    $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
+
+    for my $method ( keys %SUMMARY_METHOD_FOR ) {
+        next if 'total' eq $method;
+        no strict 'refs';
+        *$method = sub {
+            my $self = shift;
+            return wantarray
+              ? @{ $self->{"descriptions_for_$method"} }
+              : $self->{$method};
+        };
+    }
+}    # end install summary methods
+
+sub _initialize {
+    my ($self) = @_;
+    $self->{parser_for}  = {};
+    $self->{parse_order} = [];
+    for my $summary ( keys %SUMMARY_METHOD_FOR ) {
+        $self->{$summary} = 0;
+        next if 'total' eq $summary;
+        $self->{"descriptions_for_$summary"} = [];
+    }
+    return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+  $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.)  It is used as a unique identifier (see e.g.
+L<"parsers">.)  Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+    my ( $self, $description, $parser ) = @_;
+    if ( exists $self->{parser_for}{$description} ) {
+        $self->_croak( "You already have a parser for ($description)."
+              . " Perhaps you have run the same test twice." );
+    }
+    push @{ $self->{parse_order} } => $description;
+    $self->{parser_for}{$description} = $parser;
+
+    while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+
+        # Slightly nasty. Instead we should maybe have 'cooked' accessors
+        # for results that may be masked by the parser.
+        next
+          if ( $method eq 'exit' || $method eq 'wait' )
+          && $parser->ignore_exit;
+
+        if ( my $count = $parser->$method() ) {
+            $self->{$summary} += $count;
+            push @{ $self->{"descriptions_for_$summary"} } => $description;
+        }
+    }
+
+    return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+  my $count   = $aggregate->parsers;
+  my @parsers = $aggregate->parsers;
+  my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated.  In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method.  Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+    my $self = shift;
+    return $self->_get_parsers(@_) if @_;
+    my $descriptions = $self->{parse_order};
+    my @parsers      = @{ $self->{parser_for} }{@$descriptions};
+
+    # Note:  Because of the way context works, we must assign the parsers to
+    # the @parsers array or else this method does not work as documented.
+    return @parsers;
+}
+
+sub _get_parsers {
+    my ( $self, @descriptions ) = @_;
+    my @parsers;
+    for my $description (@descriptions) {
+        $self->_croak("A parser for ($description) could not be found")
+          unless exists $self->{parser_for}{$description};
+        push @parsers => $self->{parser_for}{$description};
+    }
+    return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to
+the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+    my $self = shift;
+    $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+    my $self = shift;
+    $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+    my $self = shift;
+
+    require Carp;
+    Carp::croak
+      q{Can't call elapsed without first calling start and then stop}
+      unless defined $self->{start_time} && defined $self->{end_time};
+    return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>.  This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+    my $self = shift;
+
+    my $elapsed = $self->elapsed;
+
+    return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+    my $self = shift;
+    return
+         $self->total
+      && $self->total == $self->passed
+      && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+    my $self = shift;
+
+    my $total  = $self->total;
+    my $passed = $self->passed;
+
+    return
+        ( $self->has_errors || $total != $passed ) ? 'FAIL'
+      : $total ? 'PASS'
+      :          'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context.  If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * planned
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count        = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+  my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+  if ( $parser->has_problems ) {
+      ...
+  }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded.  This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+    my $self = shift;
+    return $self->todo_passed
+      || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+  if ( $parser->has_errors ) {
+      ...
+  }
+
+Returns true if I<any> of the parsers failed.  This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse errors
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+    my $self = shift;
+    return
+         $self->failed
+      || $self->parse_errors
+      || $self->exit
+      || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+  # deprecated in favor of 'todo_passed'.  This method was horribly misnamed.
+
+This was a badly misnamed method.  It indicates which TODO tests unexpectedly
+succeeded.  Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+    warn
+      '"todo_failed" is deprecated.  Please use "todo_passed".  See the docs.';
+    goto &todo_passed;
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;

database/perl/lib/TAP/Parser/Grammar.pm

@@ -0,0 +1,584 @@
+package TAP::Parser::Grammar;
+
+use strict;
+use warnings;
+
+use TAP::Parser::ResultFactory   ();
+use TAP::Parser::YAMLish::Reader ();
+
+use base 'TAP::Object';
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Grammar;
+  my $grammar = $self->make_grammar({
+    iterator => $tap_parser_iterator,
+    parser   => $tap_parser,
+    version  => 12,
+  });
+
+  my $result = $grammar->tokenize;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a L<TAP::Parser::Iterator> and
+constructs L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly.  It won't make sense.  It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+  my $grammar = TAP::Parser::Grammar->new({
+      iterator => $iterator,
+      parser   => $parser,
+      version  => $version,
+  });
+
+Returns L<TAP::Parser> grammar object that will parse the TAP stream from the
+specified iterator.  Both C<iterator> and C<parser> are required arguments.
+If C<version> is not set it defaults to C<12> (see L</set_version> for more
+details).
+
+=cut
+
+# new() implementation supplied by TAP::Object
+sub _initialize {
+    my ( $self, $args ) = @_;
+    $self->{iterator} = $args->{iterator};    # TODO: accessor
+    $self->{iterator} ||= $args->{stream};    # deprecated
+    $self->{parser} = $args->{parser};        # TODO: accessor
+    $self->set_version( $args->{version} || 12 );
+    return $self;
+}
+
+my %language_for;
+
+{
+
+    # XXX the 'not' and 'ok' might be on separate lines in VMS ...
+    my $ok  = qr/(?:not )?ok\b/;
+    my $num = qr/\d+/;
+
+    my %v12 = (
+        version => {
+            syntax  => qr/^TAP\s+version\s+(\d+)\s*\z/i,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my $version = $1;
+                return $self->_make_version_token( $line, $version, );
+            },
+        },
+        plan => {
+            syntax  => qr/^1\.\.(\d+)\s*(.*)\z/,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my ( $tests_planned, $tail ) = ( $1, $2 );
+                my $explanation = undef;
+                my $skip        = '';
+
+                if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
+                    my @todo = split /\s+/, _trim($1);
+                    return $self->_make_plan_token(
+                        $line, $tests_planned, 'TODO',
+                        '',    \@todo
+                    );
+                }
+                elsif ( 0 == $tests_planned ) {
+                    $skip = 'SKIP';
+
+                    # If we can't match # SKIP the directive should be undef.
+                    ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i;
+                }
+                elsif ( $tail !~ /^\s*$/ ) {
+                    return $self->_make_unknown_token($line);
+                }
+
+                $explanation = '' unless defined $explanation;
+
+                return $self->_make_plan_token(
+                    $line, $tests_planned, $skip,
+                    $explanation, []
+                );
+
+            },
+        },
+
+        # An optimization to handle the most common test lines without
+        # directives.
+        simple_test => {
+            syntax  => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+
+                return $self->_make_test_token(
+                    $line, $ok, $num,
+                    $desc
+                );
+            },
+        },
+        test => {
+            syntax  => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+                my ( $dir, $explanation ) = ( '', '' );
+                if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
+                       \# \s* (SKIP|TODO) \b \s* (.*) $/ix
+                  )
+                {
+                    ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
+                }
+                return $self->_make_test_token(
+                    $line, $ok, $num, $desc,
+                    $dir,  $explanation
+                );
+            },
+        },
+        comment => {
+            syntax  => qr/^#(.*)/,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my $comment = $1;
+                return $self->_make_comment_token( $line, $comment );
+            },
+        },
+        bailout => {
+            syntax  => qr/^\s*Bail out!\s*(.*)/,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my $explanation = $1;
+                return $self->_make_bailout_token(
+                    $line,
+                    $explanation
+                );
+            },
+        },
+    );
+
+    my %v13 = (
+        %v12,
+        plan => {
+            syntax  => qr/^1\.\.(\d+)\s*(?:\s*#\s*SKIP\b(.*))?\z/i,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my ( $tests_planned, $explanation ) = ( $1, $2 );
+                my $skip
+                  = ( 0 == $tests_planned || defined $explanation )
+                  ? 'SKIP'
+                  : '';
+                $explanation = '' unless defined $explanation;
+                return $self->_make_plan_token(
+                    $line, $tests_planned, $skip,
+                    $explanation, []
+                );
+            },
+        },
+        yaml => {
+            syntax  => qr/^ (\s+) (---.*) $/x,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my ( $pad, $marker ) = ( $1, $2 );
+                return $self->_make_yaml_token( $pad, $marker );
+            },
+        },
+        pragma => {
+            syntax =>
+              qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
+            handler => sub {
+                my ( $self, $line ) = @_;
+                my $pragmas = $1;
+                return $self->_make_pragma_token( $line, $pragmas );
+            },
+        },
+    );
+
+    %language_for = (
+        '12' => {
+            tokens => \%v12,
+        },
+        '13' => {
+            tokens => \%v13,
+            setup  => sub {
+                shift->{iterator}->handle_unicode;
+            },
+        },
+    );
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<set_version>
+
+  $grammar->set_version(13);
+
+Tell the grammar which TAP syntax version to support. The lowest
+supported version is 12. Although 'TAP version' isn't valid version 12
+syntax it is accepted so that higher version numbers may be parsed.
+
+=cut
+
+sub set_version {
+    my $self    = shift;
+    my $version = shift;
+
+    if ( my $language = $language_for{$version} ) {
+        $self->{version} = $version;
+        $self->{tokens}  = $language->{tokens};
+
+        if ( my $setup = $language->{setup} ) {
+            $self->$setup();
+        }
+
+        $self->_order_tokens;
+    }
+    else {
+        require Carp;
+        Carp::croak("Unsupported syntax version: $version");
+    }
+}
+
+# Optimization to put the most frequent tokens first.
+sub _order_tokens {
+    my $self = shift;
+
+    my %copy = %{ $self->{tokens} };
+    my @ordered_tokens = grep {defined}
+      map { delete $copy{$_} } qw( simple_test test comment plan );
+    push @ordered_tokens, values %copy;
+
+    $self->{ordered_tokens} = \@ordered_tokens;
+}
+
+##############################################################################
+
+=head3 C<tokenize>
+
+  my $token = $grammar->tokenize;
+
+This method will return a L<TAP::Parser::Result> object representing the
+current line of TAP.
+
+=cut
+
+sub tokenize {
+    my $self = shift;
+
+    my $line = $self->{iterator}->next;
+    unless ( defined $line ) {
+        delete $self->{parser};    # break circular ref
+        return;
+    }
+
+    my $token;
+
+    for my $token_data ( @{ $self->{ordered_tokens} } ) {
+        if ( $line =~ $token_data->{syntax} ) {
+            my $handler = $token_data->{handler};
+            $token = $self->$handler($line);
+            last;
+        }
+    }
+
+    $token = $self->_make_unknown_token($line) unless $token;
+
+    return $self->{parser}->make_result($token);
+}
+
+##############################################################################
+
+=head3 C<token_types>
+
+  my @types = $grammar->token_types;
+
+Returns the different types of tokens which this grammar can parse.
+
+=cut
+
+sub token_types {
+    my $self = shift;
+    return keys %{ $self->{tokens} };
+}
+
+##############################################################################
+
+=head3 C<syntax_for>
+
+  my $syntax = $grammar->syntax_for($token_type);
+
+Returns a pre-compiled regular expression which will match a chunk of TAP
+corresponding to the token type.  For example (not that you should really pay
+attention to this, C<< $grammar->syntax_for('comment') >> will return
+C<< qr/^#(.*)/ >>.
+
+=cut
+
+sub syntax_for {
+    my ( $self, $type ) = @_;
+    return $self->{tokens}->{$type}->{syntax};
+}
+
+##############################################################################
+
+=head3 C<handler_for>
+
+  my $handler = $grammar->handler_for($token_type);
+
+Returns a code reference which, when passed an appropriate line of TAP,
+returns the lexed token corresponding to that line.  As a result, the basic
+TAP parsing loop looks similar to the following:
+
+ my @tokens;
+ my $grammar = TAP::Grammar->new;
+ LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
+     for my $type ( $grammar->token_types ) {
+         my $syntax  = $grammar->syntax_for($type);
+         if ( $line =~ $syntax ) {
+             my $handler = $grammar->handler_for($type);
+             push @tokens => $grammar->$handler($line);
+             next LINE;
+         }
+     }
+     push @tokens => $grammar->_make_unknown_token($line);
+ }
+
+=cut
+
+sub handler_for {
+    my ( $self, $type ) = @_;
+    return $self->{tokens}->{$type}->{handler};
+}
+
+sub _make_version_token {
+    my ( $self, $line, $version ) = @_;
+    return {
+        type    => 'version',
+        raw     => $line,
+        version => $version,
+    };
+}
+
+sub _make_plan_token {
+    my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
+
+    if (   $directive eq 'SKIP'
+        && 0 != $tests_planned
+        && $self->{version} < 13 )
+    {
+        warn
+          "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+    }
+
+    return {
+        type          => 'plan',
+        raw           => $line,
+        tests_planned => $tests_planned,
+        directive     => $directive,
+        explanation   => _trim($explanation),
+        todo_list     => $todo,
+    };
+}
+
+sub _make_test_token {
+    my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+    return {
+        ok          => $ok,
+
+        # forcing this to be an integer (and not a string) reduces memory
+        # consumption. RT #84939
+        test_num    => ( defined $num ? 0 + $num : undef ),
+        description => _trim($desc),
+        directive   => ( defined $dir ? uc $dir : '' ),
+        explanation => _trim($explanation),
+        raw         => $line,
+        type        => 'test',
+    };
+}
+
+sub _make_unknown_token {
+    my ( $self, $line ) = @_;
+    return {
+        raw  => $line,
+        type => 'unknown',
+    };
+}
+
+sub _make_comment_token {
+    my ( $self, $line, $comment ) = @_;
+    return {
+        type    => 'comment',
+        raw     => $line,
+        comment => _trim($comment)
+    };
+}
+
+sub _make_bailout_token {
+    my ( $self, $line, $explanation ) = @_;
+    return {
+        type    => 'bailout',
+        raw     => $line,
+        bailout => _trim($explanation)
+    };
+}
+
+sub _make_yaml_token {
+    my ( $self, $pad, $marker ) = @_;
+
+    my $yaml = TAP::Parser::YAMLish::Reader->new;
+
+    my $iterator = $self->{iterator};
+
+    # Construct a reader that reads from our input stripping leading
+    # spaces from each line.
+    my $leader = length($pad);
+    my $strip  = qr{ ^ (\s{$leader}) (.*) $ }x;
+    my @extra  = ($marker);
+    my $reader = sub {
+        return shift @extra if @extra;
+        my $line = $iterator->next;
+        return $2 if $line =~ $strip;
+        return;
+    };
+
+    my $data = $yaml->read($reader);
+
+    # Reconstitute input. This is convoluted. Maybe we should just
+    # record it on the way in...
+    chomp( my $raw = $yaml->get_raw );
+    $raw =~ s/^/$pad/mg;
+
+    return {
+        type => 'yaml',
+        raw  => $raw,
+        data => $data
+    };
+}
+
+sub _make_pragma_token {
+    my ( $self, $line, $pragmas ) = @_;
+    return {
+        type    => 'pragma',
+        raw     => $line,
+        pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
+    };
+}
+
+sub _trim {
+    my $data = shift;
+
+    return '' unless defined $data;
+
+    $data =~ s/^\s+//;
+    $data =~ s/\s+$//;
+    return $data;
+}
+
+1;
+
+=head1 TAP GRAMMAR
+
+B<NOTE:>  This grammar is slightly out of date.  There's still some discussion
+about it and a new one will be provided when we have things better defined.
+
+The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
+stream-based protocol.  In fact, it's quite legal to have an infinite stream.
+For the same reason that we don't apply regexes to streams, we're not using a
+formal grammar here.  Instead, we parse the TAP in lines.
+
+For purposes for forward compatibility, any result which does not match the
+following grammar is currently referred to as
+L<TAP::Parser::Result::Unknown>.  It is I<not> a parse error.
+
+A formal grammar would look similar to the following:
+
+ (*
+     For the time being, I'm cheating on the EBNF by allowing
+     certain terms to be defined by POSIX character classes by
+     using the following syntax:
+
+       digit ::= [:digit:]
+
+     As far as I am aware, that's not valid EBNF.  Sue me.  I
+     didn't know how to write "char" otherwise (Unicode issues).
+     Suggestions welcome.
+ *)
+
+ tap            ::= version? { comment | unknown } leading_plan lines
+                    |
+                    lines trailing_plan {comment}
+
+ version        ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
+
+ leading_plan   ::= plan skip_directive? "\n"
+
+ trailing_plan  ::= plan "\n"
+
+ plan           ::= '1..' nonNegativeInteger
+
+ lines          ::= line {line}
+
+ line           ::= (comment | test | unknown | bailout ) "\n"
+
+ test           ::= status positiveInteger? description? directive?
+
+ status         ::= 'not '? 'ok '
+
+ description    ::= (character - (digit | '#')) {character - '#'}
+
+ directive      ::= todo_directive | skip_directive
+
+ todo_directive ::= hash_mark 'TODO' ' ' {character}
+
+ skip_directive ::= hash_mark 'SKIP' ' ' {character}
+
+ comment        ::= hash_mark {character}
+
+ hash_mark      ::= '#' {' '}
+
+ bailout        ::= 'Bail out!' {character}
+
+ unknown        ::= { (character - "\n") }
+
+ (* POSIX character classes and other terminals *)
+
+ digit              ::= [:digit:]
+ character          ::= ([:print:] - "\n")
+ positiveInteger    ::= ( digit - '0' ) {digit}
+ nonNegativeInteger ::= digit {digit}
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
+do is read through the code.  There's no easy way of summarizing it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Result>,
+
+=cut

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  # to subclass:
+  use TAP::Parser::Iterator ();
+  use base 'TAP::Parser::Iterator';
+  sub _initialize {
+    # see TAP::Object...
+  }
+
+  sub next_raw { ... }
+  sub wait     { ... }
+  sub exit     { ... }
+
+=head1 DESCRIPTION
+
+This is a simple iterator base class that defines L<TAP::Parser>'s iterator
+API.  Iterators are typically created from L<TAP::Parser::SourceHandler>s.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.  Provided by L<TAP::Object>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+B<Note:> this method is abstract and should be overridden.
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub next {
+    my $self = shift;
+    my $line = $self->next_raw;
+
+    # vms nit:  When encountering 'not ok', vms often has the 'not' on a line
+    # by itself:
+    #   not
+    #   ok 1 - 'I hate VMS'
+    if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
+        $line .= ( $self->next_raw || '' );
+    }
+
+    return $line;
+}
+
+sub next_raw {
+    require Carp;
+    my $msg = Carp::longmess('abstract method called directly!');
+    $_[0]->_croak($msg);
+}
+
+=head3 C<handle_unicode>
+
+If necessary switch the input stream to handle unicode. This only has
+any effect for I/O handle based streams.
+
+The default implementation does nothing.
+
+=cut
+
+sub handle_unicode { }
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle-based should return an empty list.
+
+The default implementation does nothing.
+
+=cut
+
+sub get_select_handles {
+    return;
+}
+
+=head3 C<wait>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->wait;
+
+Return the C<wait> status for this iterator.
+
+=head3 C<exit>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->exit;
+
+Return the C<exit> status for this iterator.
+
+=cut
+
+sub wait {
+    require Carp;
+    my $msg = Carp::longmess('abstract method called directly!');
+    $_[0]->_croak($msg);
+}
+
+sub exit {
+    require Carp;
+    my $msg = Carp::longmess('abstract method called directly!');
+    $_[0]->_croak($msg);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+You must override the abstract methods as noted above.
+
+=head2 Example
+
+L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
+There's not much point repeating it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Iterator::Array;
+  my @data = ('foo', 'bar', baz');
+  my $it   = TAP::Parser::Iterator::Array->new(\@data);
+  my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for arrays of scalar content, used by
+L<TAP::Parser>.  Unless you're writing a plugin or subclassing, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.  Takes one argument: an C<$array_ref>
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. For an array iterator this will always
+be zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. For an array iterator this will always
+be zero.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ( $self, $thing ) = @_;
+    chomp @$thing;
+    $self->{idx}   = 0;
+    $self->{array} = $thing;
+    $self->{exit}  = undef;
+    return $self;
+}
+
+sub wait { shift->exit }
+
+sub exit {
+    my $self = shift;
+    return 0 if $self->{idx} >= @{ $self->{array} };
+    return;
+}
+
+sub next_raw {
+    my $self = shift;
+    return $self->{array}->[ $self->{idx}++ ];
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+
+=cut
+

database/perl/lib/TAP/Parser/Iterator/Process.pm

@@ -0,0 +1,378 @@
+package TAP::Parser::Iterator::Process;
+
+use strict;
+use warnings;
+
+use Config;
+use IO::Handle;
+
+use base 'TAP::Parser::Iterator';
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Iterator for process-based TAP sources
+
+=head1 VERSION
+
+Version 3.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Iterator::Process;
+  my %args = (
+   command  => ['python', 'setup.py', 'test'],
+   merge    => 1,
+   setup    => sub { ... },
+   teardown => sub { ... },
+  );
+  my $it   = TAP::Parser::Iterator::Process->new(\%args);
+  my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for executing external processes, used by
+L<TAP::Parser>.  Unless you're writing a plugin or subclassing, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.  Expects one argument containing a hashref of the form:
+
+   command  => \@command_to_execute
+   merge    => $attempt_merge_stderr_and_stdout?
+   setup    => $callback_to_setup_command
+   teardown => $callback_to_teardown_command
+
+Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
+process if they are available.  Falls back onto C<open()>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through the process output, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator's process.
+
+=head3 C<exit>
+
+Get the exit status for this iterator's process.
+
+=cut
+
+{
+
+    no warnings 'uninitialized';
+       # get around a catch22 in the test suite that causes failures on Win32:
+    local $SIG{__DIE__} = undef;
+    eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+    if ($@) {
+        *_wait2exit = sub { $_[1] >> 8 };
+    }
+    else {
+        *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
+    }
+}
+
+sub _use_open3 {
+    my $self = shift;
+    return unless $Config{d_fork} || $IS_WIN32;
+    for my $module (qw( IPC::Open3 IO::Select )) {
+        eval "use $module";
+        return if $@;
+    }
+    return 1;
+}
+
+{
+    my $got_unicode;
+
+    sub _get_unicode {
+        return $got_unicode if defined $got_unicode;
+        eval 'use Encode qw(decode_utf8);';
+        $got_unicode = $@ ? 0 : 1;
+
+    }
+}
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ( $self, $args ) = @_;
+
+    my @command = @{ delete $args->{command} || [] }
+      or die "Must supply a command to execute";
+
+    $self->{command} = [@command];
+
+    # Private. Used to frig with chunk size during testing.
+    my $chunk_size = delete $args->{_chunk_size} || 65536;
+
+    my $merge = delete $args->{merge};
+    my ( $pid, $err, $sel );
+
+    if ( my $setup = delete $args->{setup} ) {
+        $setup->(@command);
+    }
+
+    my $out = IO::Handle->new;
+
+    if ( $self->_use_open3 ) {
+
+        # HOTPATCH {{{
+        my $xclose = \&IPC::Open3::xclose;
+        no warnings;
+        local *IPC::Open3::xclose = sub {
+            my $fh = shift;
+            no strict 'refs';
+            return if ( fileno($fh) == fileno(STDIN) );
+            $xclose->($fh);
+        };
+
+        # }}}
+
+        if ($IS_WIN32) {
+            $err = $merge ? '' : '>&STDERR';
+            eval {
+                $pid = open3(
+                    '<&STDIN', $out, $merge ? '' : $err,
+                    @command
+                );
+            };
+            die "Could not execute (@command): $@" if $@;
+            if ( $] >= 5.006 ) {
+                binmode($out, ":crlf");
+            }
+        }
+        else {
+            $err = $merge ? '' : IO::Handle->new;
+            eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
+            die "Could not execute (@command): $@" if $@;
+            $sel = $merge ? undef : IO::Select->new( $out, $err );
+        }
+    }
+    else {
+        $err = '';
+        my $command
+          = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
+        open( $out, "$command|" )
+          or die "Could not execute ($command): $!";
+    }
+
+    $self->{out}        = $out;
+    $self->{err}        = $err;
+    $self->{sel}        = $sel;
+    $self->{pid}        = $pid;
+    $self->{exit}       = undef;
+    $self->{chunk_size} = $chunk_size;
+
+    if ( my $teardown = delete $args->{teardown} ) {
+        $self->{teardown} = sub {
+            $teardown->(@command);
+        };
+    }
+
+    return $self;
+}
+
+=head3 C<handle_unicode>
+
+Upgrade the input stream to handle UTF8.
+
+=cut
+
+sub handle_unicode {
+    my $self = shift;
+
+    if ( $self->{sel} ) {
+        if ( _get_unicode() ) {
+
+            # Make sure our iterator has been constructed and...
+            my $next = $self->{_next} ||= $self->_next;
+
+            # ...wrap it to do UTF8 casting
+            $self->{_next} = sub {
+                my $line = $next->();
+                return decode_utf8($line) if defined $line;
+                return;
+            };
+        }
+    }
+    else {
+        if ( $] >= 5.008 ) {
+            eval 'binmode($self->{out}, ":utf8")';
+        }
+    }
+
+}
+
+##############################################################################
+
+sub wait { shift->{wait} }
+sub exit { shift->{exit} }
+
+sub _next {
+    my $self = shift;
+
+    if ( my $out = $self->{out} ) {
+        if ( my $sel = $self->{sel} ) {
+            my $err        = $self->{err};
+            my @buf        = ();
+            my $partial    = '';                    # Partial line
+            my $chunk_size = $self->{chunk_size};
+            return sub {
+                return shift @buf if @buf;
+
+                READ:
+                while ( my @ready = $sel->can_read ) {
+                    for my $fh (@ready) {
+                        my $got = sysread $fh, my ($chunk), $chunk_size;
+
+                        if ( $got == 0 ) {
+                            $sel->remove($fh);
+                        }
+                        elsif ( $fh == $err ) {
+                            print STDERR $chunk;    # echo STDERR
+                        }
+                        else {
+                            $chunk   = $partial . $chunk;
+                            $partial = '';
+
+                            # Make sure we have a complete line
+                            unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
+                                my $nl = rindex $chunk, "\n";
+                                if ( $nl == -1 ) {
+                                    $partial = $chunk;
+                                    redo READ;
+                                }
+                                else {
+                                    $partial = substr( $chunk, $nl + 1 );
+                                    $chunk = substr( $chunk, 0, $nl );
+                                }
+                            }
+
+                            push @buf, split /\n/, $chunk;
+                            return shift @buf if @buf;
+                        }
+                    }
+                }
+
+                # Return partial last line
+                if ( length $partial ) {
+                    my $last = $partial;
+                    $partial = '';
+                    return $last;
+                }
+
+                $self->_finish;
+                return;
+            };
+        }
+        else {
+            return sub {
+                if ( defined( my $line = <$out> ) ) {
+                    chomp $line;
+                    return $line;
+                }
+                $self->_finish;
+                return;
+            };
+        }
+    }
+    else {
+        return sub {
+            $self->_finish;
+            return;
+        };
+    }
+}
+
+sub next_raw {
+    my $self = shift;
+    return ( $self->{_next} ||= $self->_next )->();
+}
+
+sub _finish {
+    my $self = shift;
+
+    my $status = $?;
+
+    # Avoid circular refs
+    $self->{_next} = sub {return}
+      if $] >= 5.006;
+
+    # If we have a subprocess we need to wait for it to terminate
+    if ( defined $self->{pid} ) {
+        if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+            $status = $?;
+        }
+    }
+
+    ( delete $self->{out} )->close if $self->{out};
+
+    # If we have an IO::Select we also have an error handle to close.
+    if ( $self->{sel} ) {
+        ( delete $self->{err} )->close;
+        delete $self->{sel};
+    }
+    else {
+        $status = $?;
+    }
+
+    # Sometimes we get -1 on Windows. Presumably that means status not
+    # available.
+    $status = 0 if $IS_WIN32 && $status == -1;
+
+    $self->{wait} = $status;
+    $self->{exit} = $self->_wait2exit($status);
+
+    if ( my $teardown = $self->{teardown} ) {
+        $teardown->();
+    }
+
+    return $self;
+}
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {
+    my $self = shift;
+    return grep $_, ( $self->{out}, $self->{err} );
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+
+=cut
+

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Iterator::Stream;
+  open( TEST, 'test.tap' );
+  my $it   = TAP::Parser::Iterator::Stream->new(\*TEST);
+  my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for reading from filehandles, used by
+L<TAP::Parser>.  Unless you're writing a plugin or subclassing, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.  Expects one argument containing a filehandle.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ( $self, $thing ) = @_;
+    $self->{fh} = $thing;
+    return $self;
+}
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. Always returns zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. Always returns zero.
+
+=cut
+
+sub wait { shift->exit }
+sub exit { shift->{fh} ? () : 0 }
+
+sub next_raw {
+    my $self = shift;
+    my $fh   = $self->{fh};
+
+    if ( defined( my $line = <$fh> ) ) {
+        chomp $line;
+        return $line;
+    }
+    else {
+        $self->_finish;
+        return;
+    }
+}
+
+sub _finish {
+    my $self = shift;
+    close delete $self->{fh};
+}
+
+sub get_select_handles {
+    my $self = shift;
+
+    # return our handle in case it's a socket or pipe (select()-able)
+    return ( $self->{fh}, )
+        if (-S $self->{fh} || -p $self->{fh});
+
+    return;
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+
+=cut
+

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::IteratorFactory;
+  my $factory = TAP::Parser::IteratorFactory->new({ %config });
+  my $iterator  = $factory->make_iterator( $filename );
+
+=head1 DESCRIPTION
+
+This is a factory class that takes a L<TAP::Parser::Source> and runs it through all the
+registered L<TAP::Parser::SourceHandler>s to see which one should handle the source.
+
+If you're a plugin author, you'll be interested in how to L</register_handler>s,
+how L</detect_source> works.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class:
+
+  my $sf = TAP::Parser::IteratorFactory->new( $config );
+
+C<$config> is optional.  If given, sets L</config> and calls L</load_handlers>.
+
+=cut
+
+sub _initialize {
+    my ( $self, $config ) = @_;
+    $self->config( $config || {} )->load_handlers;
+    return $self;
+}
+
+=head3 C<register_handler>
+
+Registers a new L<TAP::Parser::SourceHandler> with this factory.
+
+  __PACKAGE__->register_handler( $handler_class );
+
+=head3 C<handlers>
+
+List of handlers that have been registered.
+
+=cut
+
+sub register_handler {
+    my ( $class, $dclass ) = @_;
+
+    confess("$dclass must implement can_handle & make_iterator methods!")
+      unless UNIVERSAL::can( $dclass, 'can_handle' )
+          && UNIVERSAL::can( $dclass, 'make_iterator' );
+
+    my $handlers = $class->handlers;
+    push @{$handlers}, $dclass
+      unless grep { $_ eq $dclass } @{$handlers};
+
+    return $class;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<config>
+
+ my $cfg = $sf->config;
+ $sf->config({ Perl => { %config } });
+
+Chaining getter/setter for the configuration of the available source handlers.
+This is a hashref keyed on handler class whose values contain config to be passed
+onto the handlers during detection & creation.  Class names may be fully qualified
+or abbreviated, eg:
+
+  # these are equivalent
+  $sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } });
+  $sf->config({ 'Perl' => { %config } });
+
+=cut
+
+sub config {
+    my $self = shift;
+    return $self->{config} unless @_;
+    unless ( 'HASH' eq ref $_[0] ) {
+        $self->_croak('Argument to &config must be a hash reference');
+    }
+    $self->{config} = shift;
+    return $self;
+}
+
+sub _last_handler {
+    my $self = shift;
+    return $self->{last_handler} unless @_;
+    $self->{last_handler} = shift;
+    return $self;
+}
+
+sub _testing {
+    my $self = shift;
+    return $self->{testing} unless @_;
+    $self->{testing} = shift;
+    return $self;
+}
+
+##############################################################################
+
+=head3 C<load_handlers>
+
+ $sf->load_handlers;
+
+Loads the handler classes defined in L</config>.  For example, given a config:
+
+  $sf->config({
+    MySourceHandler => { some => 'config' },
+  });
+
+C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in
+C<@INC> for it in this order:
+
+  TAP::Parser::SourceHandler::MySourceHandler
+  MySourceHandler
+
+C<croak>s on error.
+
+=cut
+
+sub load_handlers {
+    my ($self) = @_;
+    for my $handler ( keys %{ $self->config } ) {
+        my $sclass = $self->_load_handler($handler);
+
+        # TODO: store which class we loaded anywhere?
+    }
+    return $self;
+}
+
+sub _load_handler {
+    my ( $self, $handler ) = @_;
+
+    my @errors;
+    for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) {
+        return $dclass
+          if UNIVERSAL::can( $dclass, 'can_handle' )
+              && UNIVERSAL::can( $dclass, 'make_iterator' );
+
+        eval "use $dclass";
+        if ( my $e = $@ ) {
+            push @errors, $e;
+            next;
+        }
+
+        return $dclass
+          if UNIVERSAL::can( $dclass, 'can_handle' )
+              && UNIVERSAL::can( $dclass, 'make_iterator' );
+        push @errors,
+          "handler '$dclass' does not implement can_handle & make_iterator";
+    }
+
+    $self->_croak(
+        "Cannot load handler '$handler': " . join( "\n", @errors ) );
+}
+
+##############################################################################
+
+=head3 C<make_iterator>
+
+  my $iterator = $src_factory->make_iterator( $source );
+
+Given a L<TAP::Parser::Source>, finds the most suitable L<TAP::Parser::SourceHandler>
+to use to create a L<TAP::Parser::Iterator> (see L</detect_source>).  Dies on error.
+
+=cut
+
+sub make_iterator {
+    my ( $self, $source ) = @_;
+
+    $self->_croak('no raw source defined!') unless defined $source->raw;
+
+    $source->config( $self->config )->assemble_meta;
+
+    # is the raw source already an object?
+    return $source->raw
+      if ( $source->meta->{is_object}
+        && UNIVERSAL::isa( $source->raw, 'TAP::Parser::SourceHandler' ) );
+
+    # figure out what kind of source it is
+    my $sd_class = $self->detect_source($source);
+    $self->_last_handler($sd_class);
+
+    return if $self->_testing;
+
+    # create it
+    my $iterator = $sd_class->make_iterator($source);
+
+    return $iterator;
+}
+
+=head3 C<detect_source>
+
+Given a L<TAP::Parser::Source>, detects what kind of source it is and
+returns I<one> L<TAP::Parser::SourceHandler> (the most confident one).  Dies
+on error.
+
+The detection algorithm works something like this:
+
+  for (@registered_handlers) {
+    # ask them how confident they are about handling this source
+    $confidence{$handler} = $handler->can_handle( $source )
+  }
+  # choose the most confident handler
+
+Ties are handled by choosing the first handler.
+
+=cut
+
+sub detect_source {
+    my ( $self, $source ) = @_;
+
+    confess('no raw source ref defined!') unless defined $source->raw;
+
+    # find a list of handlers that can handle this source:
+    my %confidence_for;
+    for my $handler ( @{ $self->handlers } ) {
+        my $confidence = $handler->can_handle($source);
+        # warn "handler: $handler: $confidence\n";
+        $confidence_for{$handler} = $confidence if $confidence;
+    }
+
+    if ( !%confidence_for ) {
+        # error: can't detect source
+        my $raw_source_short = substr( ${ $source->raw }, 0, 50 );
+        confess("Cannot detect source of '$raw_source_short'!");
+        return;
+    }
+
+    # if multiple handlers can handle it, choose the most confident one
+    my @handlers =
+          sort { $confidence_for{$b} <=> $confidence_for{$a} }
+          keys %confidence_for;
+
+    # Check for a tie.
+    if( @handlers > 1 &&
+        $confidence_for{$handlers[0]} == $confidence_for{$handlers[1]}
+    ) {
+        my $filename = $source->meta->{file}{basename};
+        die("There is a tie between $handlers[0] and $handlers[1].\n".
+            "Both voted $confidence_for{$handlers[0]} on $filename.\n");
+    }
+
+    # this is really useful for debugging handlers:
+    if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) {
+        warn(
+            "votes: ",
+            join( ', ', map {"$_: $confidence_for{$_}"} @handlers ),
+            "\n"
+        );
+    }
+
+    # return 1st
+    return $handlers[0];
+}
+
+1;
+
+__END__
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+If we've done things right, you'll probably want to write a new source,
+rather than sub-classing this (see L<TAP::Parser::SourceHandler> for that).
+
+But in case you find the need to...
+
+  package MyIteratorFactory;
+
+  use strict;
+
+  use base 'TAP::Parser::IteratorFactory';
+
+  # override source detection algorithm
+  sub detect_source {
+    my ($self, $raw_source_ref, $meta) = @_;
+    # do detective work, using $meta and whatever else...
+  }
+
+  1;
+
+=head1 AUTHORS
+
+Steve Purkis
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+Moved out of L<TAP::Parser> & converted to a factory class to support
+extensible TAP source detective work by Steve Purkis.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::RawTAP>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::Executable>
+
+=cut
+

database/perl/lib/TAP/Parser/Multiplexer.pm

@@ -0,0 +1,194 @@
+package TAP::Parser::Multiplexer;
+
+use strict;
+use warnings;
+
+use IO::Select;
+
+use base 'TAP::Object';
+
+use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
+use constant IS_VMS => $^O eq 'VMS';
+use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+
+=head1 NAME
+
+TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
+
+=head1 VERSION
+
+Version 3.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Multiplexer;
+
+    my $mux = TAP::Parser::Multiplexer->new;
+    $mux->add( $parser1, $stash1 );
+    $mux->add( $parser2, $stash2 );
+    while ( my ( $parser, $stash, $result ) = $mux->next ) {
+        # do stuff
+    }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
+Internally it calls select on the input file handles for those parsers
+to wait for one or more of them to have input available.
+
+See L<TAP::Harness> for an example of its use.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+    my $mux = TAP::Parser::Multiplexer->new;
+
+Returns a new C<TAP::Parser::Multiplexer> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my $self = shift;
+    $self->{select} = IO::Select->new;
+    $self->{avid}   = [];                # Parsers that can't select
+    $self->{count}  = 0;
+    return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+  $mux->add( $parser, $stash );
+
+Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
+reference that will be returned from C<next> along with the parser and
+the next result.
+
+=cut
+
+sub add {
+    my ( $self, $parser, $stash ) = @_;
+
+    if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
+        my $sel = $self->{select};
+
+        # We have to turn handles into file numbers here because by
+        # the time we want to remove them from our IO::Select they
+        # will already have been closed by the iterator.
+        my @filenos = map { fileno $_ } @handles;
+        for my $h (@handles) {
+            $sel->add( [ $h, $parser, $stash, @filenos ] );
+        }
+
+        $self->{count}++;
+    }
+    else {
+        push @{ $self->{avid} }, [ $parser, $stash ];
+    }
+}
+
+=head3 C<parsers>
+
+  my $count   = $mux->parsers;
+
+Returns the number of parsers. Parsers are removed from the multiplexer
+when their input is exhausted.
+
+=cut
+
+sub parsers {
+    my $self = shift;
+    return $self->{count} + scalar @{ $self->{avid} };
+}
+
+sub _iter {
+    my $self = shift;
+
+    my $sel   = $self->{select};
+    my $avid  = $self->{avid};
+    my @ready = ();
+
+    return sub {
+
+        # Drain all the non-selectable parsers first
+        if (@$avid) {
+            my ( $parser, $stash ) = @{ $avid->[0] };
+            my $result = $parser->next;
+            shift @$avid unless defined $result;
+            return ( $parser, $stash, $result );
+        }
+
+        unless (@ready) {
+            return unless $sel->count;
+            @ready = $sel->can_read;
+        }
+
+        my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
+        my $result = $parser->next;
+
+        unless ( defined $result ) {
+            $sel->remove(@handles);
+            $self->{count}--;
+
+            # Force another can_read - we may now have removed a handle
+            # thought to have been ready.
+            @ready = ();
+        }
+
+        return ( $parser, $stash, $result );
+    };
+}
+
+=head3 C<next>
+
+Return a result from the next available parser. Returns a list
+containing the parser from which the result came, the stash that
+corresponds with that parser and the result.
+
+    my ( $parser, $stash, $result ) = $mux->next;
+
+If C<$result> is undefined the corresponding parser has reached the end
+of its input (and will automatically be removed from the multiplexer).
+
+When all parsers are exhausted an empty list will be returned.
+
+    if ( my ( $parser, $stash, $result ) = $mux->next ) {
+        if ( ! defined $result ) {
+            # End of this parser
+        }
+        else {
+            # Process result
+        }
+    }
+    else {
+        # All parsers finished
+    }
+
+=cut
+
+sub next {
+    my $self = shift;
+    return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  # abstract class - not meant to be used directly
+  # see TAP::Parser::ResultFactory for preferred usage
+
+  # directly:
+  use TAP::Parser::Result;
+  my $token  = {...};
+  my $result = TAP::Parser::Result->new( $token );
+
+=head2 DESCRIPTION
+
+This is a simple base class used by L<TAP::Parser> to store objects that
+represent the current bit of test output data from TAP (usually a single
+line).  Unless you're subclassing, you probably won't need to use this module
+directly.
+
+=head2 METHODS
+
+=head3 C<new>
+
+  # see TAP::Parser::ResultFactory for preferred usage
+
+  # to use directly:
+  my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+# new() implementation provided by TAP::Object
+
+sub _initialize {
+    my ( $self, $token ) = @_;
+    if ($token) {
+
+       # assign to a hash slice to make a shallow copy of the token.
+       # I guess we could assign to the hash as (by default) there are not
+       # contents, but that seems less helpful if someone wants to subclass us
+        @{$self}{ keys %$token } = values %$token;
+    }
+    return $self;
+}
+
+##############################################################################
+
+=head2 Boolean methods
+
+The following methods all return a boolean value and are to be overridden in
+the appropriate subclass.
+
+=over 4
+
+=item * C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+ 1..3
+
+=item * C<is_pragma>
+
+Indicates whether or not this is a pragma line.
+
+ pragma +strict
+
+=item * C<is_test>
+
+Indicates whether or not this is a test line.
+
+ ok 1 Is OK!
+
+=item * C<is_comment>
+
+Indicates whether or not this is a comment.
+
+ # this is a comment
+
+=item * C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+ Bail out! We're out of dilithium crystals.
+
+=item * C<is_version>
+
+Indicates whether or not this is a TAP version line.
+
+ TAP version 4
+
+=item * C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+ ... this line is junk ...
+
+=item * C<is_yaml>
+
+Indicates whether or not this is a YAML chunk.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head3 C<raw>
+
+  print $result->raw;
+
+Returns the original line of text which was parsed.
+
+=cut
+
+sub raw { shift->{raw} }
+
+##############################################################################
+
+=head3 C<type>
+
+  my $type = $result->type;
+
+Returns the "type" of a token, such as C<comment> or C<test>.
+
+=cut
+
+sub type { shift->{type} }
+
+##############################################################################
+
+=head3 C<as_string>
+
+  print $result->as_string;
+
+Prints a string representation of the token.  This might not be the exact
+output, however.  Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up.  If you need the original text for the token, see the C<raw> method.
+
+=cut
+
+sub as_string { shift->{raw} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+  if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed.  Anything which is B<not> a
+test result returns true.  This is merely provided as a convenient shortcut.
+
+=cut
+
+sub is_ok {1}
+
+##############################################################################
+
+=head3 C<passed>
+
+Deprecated.  Please use C<is_ok> instead.
+
+=cut
+
+sub passed {
+    warn 'passed() is deprecated.  Please use "is_ok()"';
+    shift->is_ok;
+}
+
+##############################################################################
+
+=head3 C<has_directive>
+
+  if ( $result->has_directive ) {
+     ...
+  }
+
+Indicates whether or not the given result has a TODO or SKIP directive.
+
+=cut
+
+sub has_directive {
+    my $self = shift;
+    return ( $self->has_todo || $self->has_skip );
+}
+
+##############################################################################
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) {
+     ...
+ }
+
+Indicates whether or not the given result has a TODO directive.
+
+=cut
+
+sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) {
+     ...
+ }
+
+Indicates whether or not the given result has a SKIP directive.
+
+=cut
+
+sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
+
+=head3 C<set_directive>
+
+Set the directive associated with this token. Used internally to fake
+TODO tests.
+
+=cut
+
+sub set_directive {
+    my ( $self, $dir ) = @_;
+    $self->{directive} = $dir;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+Remember: if you want your subclass to be automatically used by the parser,
+you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
+
+If you're creating a completely new result I<type>, you'll probably need to
+subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
+
+=head2 Example
+
+  package MyResult;
+
+  use strict;
+
+  use base 'TAP::Parser::Result';
+
+  # register with the factory:
+  TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+  sub as_string { 'My results all look the same' }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::ResultFactory>,
+L<TAP::Parser::Result::Bailout>,
+L<TAP::Parser::Result::Comment>,
+L<TAP::Parser::Result::Plan>,
+L<TAP::Parser::Result::Pragma>,
+L<TAP::Parser::Result::Test>,
+L<TAP::Parser::Result::Unknown>,
+L<TAP::Parser::Result::Version>,
+L<TAP::Parser::Result::YAML>,
+
+=cut

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a bail out line is encountered.
+
+ 1..5
+ ok 1 - woo hooo!
+ Bail out! Well, so much for "woo hooo!"
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<explanation>
+
+  if ( $result->is_bailout ) {
+      my $explanation = $result->explanation;
+      print "We bailed out because ($explanation)";
+  }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method.  The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=cut
+
+sub explanation { shift->{bailout} }
+sub as_string   { shift->{bailout} }
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a comment line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+ # this is a comment
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+Note that this method merely returns the comment preceded by a '# '.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<comment> 
+
+  if ( $result->is_comment ) {
+      my $comment = $result->comment;
+      print "I have something to say:  $comment";
+  }
+
+=cut
+
+sub comment   { shift->{comment} }
+sub as_string { shift->{raw} }
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a plan line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan.  Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<plan> 
+
+  if ( $result->is_plan ) {
+     print $result->plan;
+  }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub plan { '1..' . shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<tests_planned>
+
+  my $planned = $result->tests_planned;
+
+Returns the number of tests planned.  For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=cut
+
+sub tests_planned { shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $plan->directive; 
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+  if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<explanation>
+
+ my $explanation = $plan->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+=head3 C<todo_list>
+
+  my $todo = $result->todo_list;
+  for ( @$todo ) {
+      ...
+  }
+
+=cut
+
+sub todo_list { shift->{todo_list} }
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a pragma is encountered.
+
+ TAP version 13
+ pragma +strict, -foo
+
+Pragmas are only supported from TAP version 13 onwards.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<pragmas> 
+
+if ( $result->is_pragma ) {
+    @pragmas = $result->pragmas;
+}
+
+=cut
+
+sub pragmas {
+    my @pragmas = @{ shift->{pragmas} };
+    return wantarray ? @pragmas : \@pragmas;
+}
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system.  Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+  my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+  my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+    my ( $self, $number ) = @_;
+    $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+  my $description = $result->description;
+
+Returns the description of the test, if any.  This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+  my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+  my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explanation, if present.
+
+  not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+  if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed.  Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false.  See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+    my $self = shift;
+
+    return if $self->is_unplanned;
+
+    # TODO directives reverse the sense of a test.
+    return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+  if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+    my $self = shift;
+    return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated.  Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+    warn 'actual_passed() is deprecated.  Please use "is_actual_ok()"';
+    goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+  if ( $test->todo_passed ) {
+     # test unexpectedly succeeded
+  }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+    my $self = shift;
+    return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+  # deprecated in favor of 'todo_passed'.  This method was horribly misnamed.
+
+This was a badly misnamed method.  It indicates which TODO tests unexpectedly
+succeeded.  Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+    warn 'todo_failed() is deprecated.  Please use "todo_passed()"';
+    goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+  if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+  if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+  print $result->as_string;
+
+This method prints the test as a string.  It will probably be similar, but
+not necessarily identical, to the original test line.  Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line.  If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+    my $self   = shift;
+    my $string = $self->ok . " " . $self->number;
+    if ( my $description = $self->description ) {
+        $string .= " $description";
+    }
+    if ( my $directive = $self->directive ) {
+        my $explanation = $self->explanation;
+        $string .= " # $directive $explanation";
+    }
+    return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+  if ( $test->is_unplanned ) { ... }
+  $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true.  Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+  print <<'END';
+  ok 1
+  ok 2
+  1..1
+  END
+
+=cut
+
+sub is_unplanned {
+    my $self = shift;
+    return ( $self->{unplanned} || '' ) unless @_;
+    $self->{unplanned} = !!shift;
+    return $self;
+}
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if the parser does not recognize the token line.  For example:
+
+ 1..5
+ VERSION 7
+ ok 1 - woo hooo!
+ ... woo hooo! is cool!
+
+In the above "TAP", the second and fourth lines will generate "Unknown"
+tokens.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a version line is encountered.
+
+ TAP version 13
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 13.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<version> 
+
+  if ( $result->is_version ) {
+     print $result->version;
+  }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub version { shift->{version} }
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a YAML block is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan.  Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<data> 
+
+  if ( $result->is_yaml ) {
+     print $result->data;
+  }
+
+Return the parsed YAML data for this result
+
+=cut
+
+sub data { shift->{data} }
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head2 DESCRIPTION
+
+This is a simple factory class which returns a L<TAP::Parser::Result> subclass
+representing the current bit of test data from TAP (usually a single line).
+It is used primarily by L<TAP::Parser::Grammar>.  Unless you're subclassing,
+you probably won't need to use this module directly.
+
+=head2 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_result>
+
+Returns an instance the appropriate class for the test token passed in.
+
+  my $result = TAP::Parser::ResultFactory->make_result($token);
+
+Can also be called as an instance method.
+
+=cut
+
+sub make_result {
+    my ( $proto, $token ) = @_;
+    my $type = $token->{type};
+    return $proto->class_for($type)->new($token);
+}
+
+=head3 C<class_for>
+
+Takes one argument: C<$type>.  Returns the class for this $type, or C<croak>s
+with an error.
+
+=head3 C<register_type>
+
+Takes two arguments: C<$type>, C<$class>
+
+This lets you override an existing type with your own custom type, or register
+a completely new type, eg:
+
+  # create a custom result type:
+  package MyResult;
+  use strict;
+  use base 'TAP::Parser::Result';
+
+  # register with the factory:
+  TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+  # use it:
+  my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
+
+Your custom type should then be picked up automatically by the L<TAP::Parser>.
+
+=cut
+
+our %CLASS_FOR = (
+	plan    => 'TAP::Parser::Result::Plan',
+	pragma  => 'TAP::Parser::Result::Pragma',
+	test    => 'TAP::Parser::Result::Test',
+	comment => 'TAP::Parser::Result::Comment',
+	bailout => 'TAP::Parser::Result::Bailout',
+	version => 'TAP::Parser::Result::Version',
+	unknown => 'TAP::Parser::Result::Unknown',
+	yaml    => 'TAP::Parser::Result::YAML',
+);
+
+sub class_for {
+    my ( $class, $type ) = @_;
+
+    # return target class:
+    return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
+
+    # or complain:
+    require Carp;
+    Carp::croak("Could not determine class for result type '$type'");
+}
+
+sub register_type {
+    my ( $class, $type, $rclass ) = @_;
+
+    # register it blindly, assume they know what they're doing
+    $CLASS_FOR{$type} = $rclass;
+    return $class;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=item 2
+
+C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
+This I<will> change in a future version!
+
+=item 3
+
+L<TAP::Parser::Result> subclasses will register themselves with
+L<TAP::Parser::ResultFactory> directly:
+
+  package MyFooResult;
+  TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
+
+Of course, it's up to you to decide whether or not to ignore them.
+
+=back
+
+=head2 Example
+
+  package MyResultFactory;
+
+  use strict;
+
+  use MyResult;
+
+  use base 'TAP::Parser::ResultFactory';
+
+  # force all results to be 'MyResult'
+  sub class_for {
+    return 'MyResult';
+  }
+
+  1;
+
+=head1 SEE ALSO
+
+L<TAP::Parser>,
+L<TAP::Parser::Result>,
+L<TAP::Parser::Grammar>
+
+=cut

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Scheduler;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+    my $sched = TAP::Parser::Scheduler->new(tests => \@tests);
+    my $sched = TAP::Parser::Scheduler->new(
+        tests => [ ['t/test_name.t','Test Description'], ... ],
+        rules => \%rules,
+    );
+
+Given 'tests' and optional 'rules' as input, returns a new
+C<TAP::Parser::Scheduler> object.  Each member of C<@tests> should be either a
+a test file name, or a two element arrayref, where the first element is a test
+file name, and the second element is a test description. By default, we'll use
+the test name as the description.
+
+The optional C<rules> attribute provides direction on which tests should be run
+in parallel and which should be run sequentially. If no rule data structure is
+provided, a default data structure is used which makes every test eligible to
+be run in parallel:
+
+    { par => '**' },
+
+The rules data structure is documented more in the next section.
+
+=head2 Rules data structure
+
+The "C<rules>" data structure is the the heart of the scheduler. It allows you
+to express simple rules like "run all tests in sequence" or "run all tests in
+parallel except these five tests.". However, the rules structure also supports
+glob-style pattern matching and recursive definitions, so you can also express
+arbitarily complicated patterns.
+
+The rule must only have one top level key: either 'par' for "parallel" or 'seq'
+for "sequence".
+
+Values must be either strings with possible glob-style matching, or arrayrefs
+of strings or hashrefs which follow this pattern recursively.
+
+Every element in an arrayref directly below a 'par' key is eligible to be run
+in parallel, while vavalues directly below a 'seq' key must be run in sequence.
+
+=head3 Rules examples
+
+Here are some examples:
+
+    # All tests be run in parallel (the default rule)
+    { par => '**' },
+
+    # Run all tests in sequence, except those starting with "p"
+    { par => 't/p*.t' },
+
+    # Run all tests in parallel, except those starting with "p"
+    {
+        seq => [
+                  { seq => 't/p*.t' },
+                  { par => '**'     },
+               ],
+    }
+
+    # Run some  startup tests in sequence, then some parallel tests then some
+    # teardown tests in sequence.
+    {
+        seq => [
+            { seq => 't/startup/*.t' },
+            { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
+            { seq => 't/shutdown/*.t' },
+        ],
+    },
+
+
+=head3 Rules resolution
+
+=over 4
+
+=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
+
+=item * "First match wins". The first rule that matches a test will be the one that applies.
+
+=item * Any test which does not match a rule will be run in sequence at the end of the run.
+
+=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
+
+=item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
+
+=back
+
+=head3 Glob-style pattern matching for rules
+
+We implement our own glob-style pattern matching. Here are the patterns it supports:
+
+    ** is any number of characters, including /, within a pathname
+    * is zero or more characters within a filename/directory name
+    ? is exactly one character within a filename/directory name
+    {foo,bar,baz} is any of foo, bar or baz.
+    \ is an escape character
+
+=cut
+
+sub new {
+    my $class = shift;
+
+    croak "Need a number of key, value pairs" if @_ % 2;
+
+    my %args  = @_;
+    my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+    my $rules = delete $args{rules} || { par => '**' };
+
+    croak "Unknown arg(s): ", join ', ', sort keys %args
+      if keys %args;
+
+    # Turn any simple names into a name, description pair. TODO: Maybe
+    # construct jobs here?
+    my $self = bless {}, $class;
+
+    $self->_set_rules( $rules, $tests );
+
+    return $self;
+}
+
+# Build the scheduler data structure.
+#
+# SCHEDULER-DATA ::= JOB
+#                ||  ARRAY OF ARRAY OF SCHEDULER-DATA
+#
+# The nested arrays are the key to scheduling. The outer array contains
+# a list of things that may be executed in parallel. Whenever an
+# eligible job is sought any element of the outer array that is ready to
+# execute can be selected. The inner arrays represent sequential
+# execution. They can only proceed when the first job is ready to run.
+
+sub _set_rules {
+    my ( $self, $rules, $tests ) = @_;
+
+    # Convert all incoming tests to job objects. 
+    # If no test description is provided use the file name as the description. 
+    my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
+      map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+    my $schedule = $self->_rule_clause( $rules, \@tests );
+
+    # If any tests are left add them as a sequential block at the end of
+    # the run.
+    $schedule = [ [ $schedule, @tests ] ] if @tests;
+
+    $self->{schedule} = $schedule;
+}
+
+sub _rule_clause {
+    my ( $self, $rule, $tests ) = @_;
+    croak 'Rule clause must be a hash'
+      unless 'HASH' eq ref $rule;
+
+    my @type = keys %$rule;
+    croak 'Rule clause must have exactly one key'
+      unless @type == 1;
+
+    my %handlers = (
+        par => sub {
+            [ map { [$_] } @_ ];
+        },
+        seq => sub { [ [@_] ] },
+    );
+
+    my $handler = $handlers{ $type[0] }
+      || croak 'Unknown scheduler type: ', $type[0];
+    my $val = $rule->{ $type[0] };
+
+    return $handler->(
+        map {
+            'HASH' eq ref $_
+              ? $self->_rule_clause( $_, $tests )
+              : $self->_expand( $_, $tests )
+          } 'ARRAY' eq ref $val ? @$val : $val
+    );
+}
+
+sub _glob_to_regexp {
+    my ( $self, $glob ) = @_;
+    my $nesting;
+    my $pattern;
+
+    while (1) {
+        if ( $glob =~ /\G\*\*/gc ) {
+
+            # ** is any number of characters, including /, within a pathname
+            $pattern .= '.*?';
+        }
+        elsif ( $glob =~ /\G\*/gc ) {
+
+            # * is zero or more characters within a filename/directory name
+            $pattern .= '[^/]*';
+        }
+        elsif ( $glob =~ /\G\?/gc ) {
+
+            # ? is exactly one character within a filename/directory name
+            $pattern .= '[^/]';
+        }
+        elsif ( $glob =~ /\G\{/gc ) {
+
+            # {foo,bar,baz} is any of foo, bar or baz.
+            $pattern .= '(?:';
+            ++$nesting;
+        }
+        elsif ( $nesting and $glob =~ /\G,/gc ) {
+
+            # , is only special inside {}
+            $pattern .= '|';
+        }
+        elsif ( $nesting and $glob =~ /\G\}/gc ) {
+
+            # } that matches { is special. But unbalanced } are not.
+            $pattern .= ')';
+            --$nesting;
+        }
+        elsif ( $glob =~ /\G(\\.)/gc ) {
+
+            # A quoted literal
+            $pattern .= $1;
+        }
+        elsif ( $glob =~ /\G([\},])/gc ) {
+
+            # Sometimes meta characters
+            $pattern .= '\\' . $1;
+        }
+        else {
+
+            # Eat everything that is not a meta character.
+            $glob =~ /\G([^{?*\\\},]*)/gc;
+            $pattern .= quotemeta $1;
+        }
+        return $pattern if pos $glob == length $glob;
+    }
+}
+
+sub _expand {
+    my ( $self, $name, $tests ) = @_;
+
+    my $pattern = $self->_glob_to_regexp($name);
+    $pattern = qr/^ $pattern $/x;
+    my @match = ();
+
+    for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+        if ( $tests->[$ti]->filename =~ $pattern ) {
+            push @match, splice @$tests, $ti, 1;
+            $ti--;
+        }
+    }
+
+    return @match;
+}
+
+=head2 Instance Methods
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+    my $self = shift;
+    my @all  = $self->_gather( $self->{schedule} );
+    $self->{count} = @all;
+    @all;
+}
+
+sub _gather {
+    my ( $self, $rule ) = @_;
+    return unless defined $rule;
+    return $rule unless 'ARRAY' eq ref $rule;
+    return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job as L<TAP::Parser::Scheduler::Job> object or
+C<undef> if none are available. Returns a L<TAP::Parser::Scheduler::Spinner> if
+the scheduler still has pending jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+    my $self = shift;
+    $self->{count} ||= $self->get_all;
+    my @jobs = $self->_find_next_job( $self->{schedule} );
+    if (@jobs) {
+        --$self->{count};
+        return $jobs[0];
+    }
+
+    return TAP::Parser::Scheduler::Spinner->new
+      if $self->{count};
+
+    return;
+}
+
+sub _not_empty {
+    my $ar = shift;
+    return 1 unless 'ARRAY' eq ref $ar;
+    for (@$ar) {
+        return 1 if _not_empty($_);
+    }
+    return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+    my ( $self, $rule ) = @_;
+
+    my @queue = ();
+    my $index = 0;
+    while ( $index < @$rule ) {
+        my $seq = $rule->[$index];
+
+        # Prune any exhausted items.
+        shift @$seq while @$seq && _is_empty( $seq->[0] );
+        if (@$seq) {
+            if ( defined $seq->[0] ) {
+                if ( 'ARRAY' eq ref $seq->[0] ) {
+                    push @queue, $seq;
+                }
+                else {
+                    my $job = splice @$seq, 0, 1, undef;
+                    $job->on_finish( sub { shift @$seq } );
+                    return $job;
+                }
+            }
+            ++$index;
+        }
+        else {
+
+            # Remove the empty sub-array from the array
+            splice @$rule, $index, 1;
+        }
+    }
+
+    for my $seq (@queue) {
+        if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
+            return @jobs;
+        }
+    }
+
+    return;
+}
+
+=head3 C<as_string>
+
+Return a human readable representation of the scheduling tree.
+For example:
+
+    my @tests = (qw{
+        t/startup/foo.t 
+        t/shutdown/foo.t
+    
+        t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t
+    });
+    my $sched = TAP::Parser::Scheduler->new(
+        tests => \@tests,
+        rules => {
+            seq => [
+                { seq => 't/startup/*.t' },
+                { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] },
+                { seq => 't/shutdown/*.t' },
+            ],
+        },
+    );
+
+Produces:
+
+    par:
+      seq:
+        par:
+          seq:
+            par:
+              seq:
+                't/startup/foo.t'
+            par:
+              seq:
+                't/a/foo.t'
+              seq:
+                't/b/foo.t'
+              seq:
+                't/c/foo.t'
+            par:
+              seq:
+                't/shutdown/foo.t'
+        't/d/foo.t'
+
+
+=cut
+
+
+sub as_string {
+    my $self = shift;
+    return $self->_as_string( $self->{schedule} );
+}
+
+sub _as_string {
+    my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
+    my $pad    = ' ' x 2;
+    my $indent = $pad x $depth;
+    if ( !defined $rule ) {
+        return "$indent(undef)\n";
+    }
+    elsif ( 'ARRAY' eq ref $rule ) {
+        return unless @$rule;
+        my $type = ( 'par', 'seq' )[ $depth % 2 ];
+        return join(
+            '', "$indent$type:\n",
+            map { $self->_as_string( $_, $depth + 1 ) } @$rule
+        );
+    }
+    else {
+        return "$indent'" . $rule->filename . "'\n";
+    }
+}
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Scheduler::Job;
+
+=head1 DESCRIPTION
+
+Represents a single test 'job'.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+    my $job = TAP::Parser::Scheduler::Job->new(
+        $filename, $description
+    );
+
+Given the filename and description of a test as scalars, returns a new
+L<TAP::Parser::Scheduler::Job> object.
+
+=cut
+
+sub new {
+    my ( $class, $name, $desc, @ctx ) = @_;
+    return bless {
+        filename    => $name,
+        description => $desc,
+        @ctx ? ( context => \@ctx ) : (),
+    }, $class;
+}
+
+=head2 Instance Methods
+
+=head3 C<on_finish>
+
+    $self->on_finish(\&method).
+
+Register a closure to be called when this job is destroyed. The callback
+will be passed the C<TAP::Parser::Scheduler::Job> object as it's only argument.
+
+=cut
+
+sub on_finish {
+    my ( $self, $cb ) = @_;
+    $self->{on_finish} = $cb;
+}
+
+=head3 C<finish>
+
+   $self->finish;
+
+Called when a job is complete to unlock it. If a callback has been registered
+with C<on_finish>, it calls it. Otherwise, it does nothing. 
+
+=cut
+
+sub finish {
+    my $self = shift;
+    if ( my $cb = $self->{on_finish} ) {
+        $cb->($self);
+    }
+}
+
+=head2 Attributes
+
+  $self->filename;
+  $self->description;
+  $self->context;
+
+These are all "getters" which return the data set for these attributes during object construction.
+
+
+=head3 C<filename>
+
+=head3 C<description>
+
+=head3 C<context>
+
+=cut
+
+sub filename    { shift->{filename} }
+sub description { shift->{description} }
+sub context     { @{ shift->{context} || [] } }
+
+=head3 C<as_array_ref>
+
+For backwards compatibility in callbacks.
+
+=cut
+
+sub as_array_ref {
+    my $self = shift;
+    return [ $self->filename, $self->description, $self->{context} ||= [] ];
+}
+
+=head3 C<is_spinner>
+
+  $self->is_spinner;
+
+Returns false indicating that this is a real job rather than a
+'spinner'. Spinners are returned when the scheduler still has pending
+jobs but can't (because of locking) return one right now.
+
+=cut
+
+sub is_spinner {0}
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Scheduler::Spinner;
+
+=head1 DESCRIPTION
+
+A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
+the harness to spin (keep executing tests) while the scheduler can't
+return a real job.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+    my $job = TAP::Parser::Scheduler::Spinner->new;
+
+Ignores any arguments and returns a new C<TAP::Parser::Scheduler::Spinner> object.
+
+=cut
+
+sub new { bless {}, shift }
+
+=head2 Instance Methods
+
+=head3 C<is_spinner>
+
+Returns true indicating that is a 'spinner' job. Spinners are returned
+when the scheduler still has pending jobs but can't (because of locking)
+return one right now.
+
+=cut
+
+sub is_spinner {1}
+
+=head1 SEE ALSO
+
+L<TAP::Parser::Scheduler>, L<TAP::Parser::Scheduler::Job>
+
+=cut
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source;
+  my $source = TAP::Parser::Source->new;
+  $source->raw( \'reference to raw TAP source' )
+         ->config( \%config )
+         ->merge( $boolean )
+         ->switches( \@switches )
+         ->test_args( \@args )
+         ->assemble_meta;
+
+  do { ... } if $source->meta->{is_file};
+  # see assemble_meta for a full list of data available
+
+=head1 DESCRIPTION
+
+A TAP I<source> is something that produces a stream of TAP for the parser to
+consume, such as an executable file, a text file, an archive, an IO handle, a
+database, etc.  C<TAP::Parser::Source>s encapsulate these I<raw> sources, and
+provide some useful meta data about them.  They are used by
+L<TAP::Parser::SourceHandler>s, which do whatever is required to produce &
+capture a stream of TAP from the I<raw> source, and package it up in a
+L<TAP::Parser::Iterator> for the parser to consume.
+
+Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or
+subclassing L<TAP::Parser>, you probably won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ($self) = @_;
+    $self->meta(   {} );
+    $self->config( {} );
+    return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<raw>
+
+  my $raw = $source->raw;
+  $source->raw( $some_value );
+
+Chaining getter/setter for the raw TAP source.  This is a reference, as it may
+contain large amounts of data (eg: raw TAP).
+
+=head3 C<meta>
+
+  my $meta = $source->meta;
+  $source->meta({ %some_value });
+
+Chaining getter/setter for meta data about the source.  This defaults to an
+empty hashref.  See L</assemble_meta> for more info.
+
+=head3 C<has_meta>
+
+True if the source has meta data.
+
+=head3 C<config>
+
+  my $config = $source->config;
+  $source->config({ %some_value });
+
+Chaining getter/setter for the source's configuration, if any has been provided
+by the user.  How it's used is up to you.  This defaults to an empty hashref.
+See L</config_for> for more info.
+
+=head3 C<merge>
+
+  my $merge = $source->merge;
+  $source->config( $bool );
+
+Chaining getter/setter for the flag that dictates whether STDOUT and STDERR
+should be merged (where appropriate).  Defaults to undef.
+
+=head3 C<switches>
+
+  my $switches = $source->switches;
+  $source->config([ @switches ]);
+
+Chaining getter/setter for the list of command-line switches that should be
+passed to the source (where appropriate).  Defaults to undef.
+
+=head3 C<test_args>
+
+  my $test_args = $source->test_args;
+  $source->config([ @test_args ]);
+
+Chaining getter/setter for the list of command-line arguments that should be
+passed to the source (where appropriate).  Defaults to undef.
+
+=cut
+
+sub raw {
+    my $self = shift;
+    return $self->{raw} unless @_;
+    $self->{raw} = shift;
+    return $self;
+}
+
+sub meta {
+    my $self = shift;
+    return $self->{meta} unless @_;
+    $self->{meta} = shift;
+    return $self;
+}
+
+sub has_meta {
+    return scalar %{ shift->meta } ? 1 : 0;
+}
+
+sub config {
+    my $self = shift;
+    return $self->{config} unless @_;
+    $self->{config} = shift;
+    return $self;
+}
+
+sub merge {
+    my $self = shift;
+    return $self->{merge} unless @_;
+    $self->{merge} = shift;
+    return $self;
+}
+
+sub switches {
+    my $self = shift;
+    return $self->{switches} unless @_;
+    $self->{switches} = shift;
+    return $self;
+}
+
+sub test_args {
+    my $self = shift;
+    return $self->{test_args} unless @_;
+    $self->{test_args} = shift;
+    return $self;
+}
+
+=head3 C<assemble_meta>
+
+  my $meta = $source->assemble_meta;
+
+Gathers meta data about the L</raw> source, stashes it in L</meta> and returns
+it as a hashref.  This is done so that the L<TAP::Parser::SourceHandler>s don't
+have to repeat common checks.  Currently this includes:
+
+    is_scalar => $bool,
+    is_hash   => $bool,
+    is_array  => $bool,
+
+    # for scalars:
+    length => $n
+    has_newlines => $bool
+
+    # only done if the scalar looks like a filename
+    is_file => $bool,
+    is_dir  => $bool,
+    is_symlink => $bool,
+    file => {
+        # only done if the scalar looks like a filename
+        basename => $string, # including ext
+        dir      => $string,
+        ext      => $string,
+        lc_ext   => $string,
+        # system checks
+        exists  => $bool,
+        stat    => [ ... ], # perldoc -f stat
+        empty   => $bool,
+        size    => $n,
+        text    => $bool,
+        binary  => $bool,
+        read    => $bool,
+        write   => $bool,
+        execute => $bool,
+        setuid  => $bool,
+        setgid  => $bool,
+        sticky  => $bool,
+        is_file => $bool,
+        is_dir  => $bool,
+        is_symlink => $bool,
+        # only done if the file's a symlink
+        lstat      => [ ... ], # perldoc -f lstat
+        # only done if the file's a readable text file
+        shebang => $first_line,
+    }
+
+  # for arrays:
+  size => $n,
+
+=cut
+
+sub assemble_meta {
+    my ($self) = @_;
+
+    return $self->meta if $self->has_meta;
+
+    my $meta = $self->meta;
+    my $raw  = $self->raw;
+
+    # rudimentary is object test - if it's blessed it'll
+    # inherit from UNIVERSAL
+    $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0;
+
+    if ( $meta->{is_object} ) {
+        $meta->{class} = ref($raw);
+    }
+    else {
+        my $ref = lc( ref($raw) );
+        $meta->{"is_$ref"} = 1;
+    }
+
+    if ( $meta->{is_scalar} ) {
+        my $source = $$raw;
+        $meta->{length} = length($$raw);
+        $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0;
+
+        # only do file checks if it looks like a filename
+        if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) {
+            my $file = {};
+            $file->{exists} = -e $source ? 1 : 0;
+            if ( $file->{exists} ) {
+                $meta->{file} = $file;
+
+                # avoid extra system calls (see `perldoc -f -X`)
+                $file->{stat}    = [ stat(_) ];
+                $file->{empty}   = -z _ ? 1 : 0;
+                $file->{size}    = -s _;
+                $file->{text}    = -T _ ? 1 : 0;
+                $file->{binary}  = -B _ ? 1 : 0;
+                $file->{read}    = -r _ ? 1 : 0;
+                $file->{write}   = -w _ ? 1 : 0;
+                $file->{execute} = -x _ ? 1 : 0;
+                $file->{setuid}  = -u _ ? 1 : 0;
+                $file->{setgid}  = -g _ ? 1 : 0;
+                $file->{sticky}  = -k _ ? 1 : 0;
+
+                $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0;
+                $meta->{is_dir}  = $file->{is_dir}  = -d _ ? 1 : 0;
+
+                # symlink check requires another system call
+                $meta->{is_symlink} = $file->{is_symlink}
+                  = -l $source ? 1 : 0;
+                if ( $file->{is_symlink} ) {
+                    $file->{lstat} = [ lstat(_) ];
+                }
+
+                # put together some common info about the file
+                ( $file->{basename}, $file->{dir}, $file->{ext} )
+                  = map { defined $_ ? $_ : '' }
+                  fileparse( $source, qr/\.[^.]*/ );
+                $file->{lc_ext} = lc( $file->{ext} );
+                $file->{basename} .= $file->{ext} if $file->{ext};
+
+                if ( !$file->{is_dir} && $file->{read} ) {
+                    eval { $file->{shebang} = $self->shebang($$raw); };
+                    if ( my $e = $@ ) {
+                        warn $e;
+                    }
+                }
+            }
+        }
+    }
+    elsif ( $meta->{is_array} ) {
+        $meta->{size} = $#$raw + 1;
+    }
+    elsif ( $meta->{is_hash} ) {
+        ;    # do nothing
+    }
+
+    return $meta;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+  my $shebang = TAP::Parser::Source->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+    # Global shebang cache.
+    my %shebang_for;
+
+    sub _read_shebang {
+        my ( $class, $file ) = @_;
+        open my $fh, '<', $file or die "Can't read $file: $!\n";
+
+        # Might be a binary file - so read a fixed number of bytes.
+        my $got = read $fh, my ($buf), BLK_SIZE;
+        defined $got or die "I/O error: $!\n";
+        return $1 if $buf =~ /(.*)/;
+        return;
+    }
+
+    sub shebang {
+        my ( $class, $file ) = @_;
+        $shebang_for{$file} = $class->_read_shebang($file)
+          unless exists $shebang_for{$file};
+        return $shebang_for{$file};
+    }
+}
+
+=head3 C<config_for>
+
+  my $config = $source->config_for( $class );
+
+Returns L</config> for the $class given.  Class names may be fully qualified
+or abbreviated, eg:
+
+  # these are equivalent
+  $source->config_for( 'Perl' );
+  $source->config_for( 'TAP::Parser::SourceHandler::Perl' );
+
+If a fully qualified $class is given, its abbreviated version is checked first.
+
+=cut
+
+sub config_for {
+    my ( $self, $class ) = @_;
+    my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ );
+    my $config = $self->config->{$abbrv_class} || $self->config->{$class};
+    return $config;
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Steve Purkis.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>
+
+=cut

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  # abstract class - don't use directly!
+  # see TAP::Parser::IteratorFactory for general usage
+
+  # must be sub-classed for use
+  package MySourceHandler;
+  use base 'TAP::Parser::SourceHandler';
+  sub can_handle    { return $confidence_level }
+  sub make_iterator { return $iterator }
+
+  # see example below for more details
+
+=head1 DESCRIPTION
+
+This is an abstract base class for L<TAP::Parser::Source> handlers / handlers.
+
+A C<TAP::Parser::SourceHandler> does whatever is necessary to produce & capture
+a stream of TAP from the I<raw> source, and package it up in a
+L<TAP::Parser::Iterator> for the parser to consume.
+
+C<SourceHandlers> must implement the I<source detection & handling> interface
+used by L<TAP::Parser::IteratorFactory>.  At 2 methods, the interface is pretty
+simple: L</can_handle> and L</make_source>.
+
+Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin, or
+subclassing L<TAP::Parser>, you probably won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+I<Abstract method>.
+
+  my $vote = $class->can_handle( $source );
+
+C<$source> is a L<TAP::Parser::Source>.
+
+Returns a number between C<0> & C<1> reflecting how confidently the raw source
+can be handled.  For example, C<0> means the source cannot handle it, C<0.5>
+means it may be able to, and C<1> means it definitely can.  See
+L<TAP::Parser::IteratorFactory/detect_source> for details on how this is used.
+
+=cut
+
+sub can_handle {
+    my ( $class, $args ) = @_;
+    $class->_croak(
+        "Abstract method 'can_handle' not implemented for $class!");
+    return;
+}
+
+=head3 C<make_iterator>
+
+I<Abstract method>.
+
+  my $iterator = $class->make_iterator( $source );
+
+C<$source> is a L<TAP::Parser::Source>.
+
+Returns a new L<TAP::Parser::Iterator> object for use by the L<TAP::Parser>.
+C<croak>s on error.
+
+=cut
+
+sub make_iterator {
+    my ( $class, $args ) = @_;
+    $class->_croak(
+        "Abstract method 'make_iterator' not implemented for $class!");
+    return;
+}
+1;
+
+__END__
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview, and any
+of the subclasses that ship with this module as an example.  What follows is
+a quick overview.
+
+Start by familiarizing yourself with L<TAP::Parser::Source> and
+L<TAP::Parser::IteratorFactory>.  L<TAP::Parser::SourceHandler::RawTAP> is
+the easiest sub-class to use as an example.
+
+It's important to point out that if you want your subclass to be automatically
+used by L<TAP::Parser> you'll have to and make sure it gets loaded somehow.
+If you're using L<prove> you can write an L<App::Prove> plugin.  If you're
+using L<TAP::Parser> or L<TAP::Harness> directly (e.g. through a custom script,
+L<ExtUtils::MakeMaker>, or L<Module::Build>) you can use the C<config> option
+which will cause L<TAP::Parser::IteratorFactory/load_sources> to load your
+subclass).
+
+Don't forget to register your class with
+L<TAP::Parser::IteratorFactory/register_handler>.
+
+=head2 Example
+
+  package MySourceHandler;
+
+  use strict;
+
+  use MySourceHandler; # see TAP::Parser::SourceHandler
+  use TAP::Parser::IteratorFactory;
+
+  use base 'TAP::Parser::SourceHandler';
+
+  TAP::Parser::IteratorFactory->register_handler( __PACKAGE__ );
+
+  sub can_handle {
+      my ( $class, $src ) = @_;
+      my $meta   = $src->meta;
+      my $config = $src->config_for( $class );
+
+      if ($config->{accept_all}) {
+          return 1.0;
+      } elsif (my $file = $meta->{file}) {
+          return 0.0 unless $file->{exists};
+          return 1.0 if $file->{lc_ext} eq '.tap';
+          return 0.9 if $file->{shebang} && $file->{shebang} =~ /^#!.+tap/;
+          return 0.5 if $file->{text};
+          return 0.1 if $file->{binary};
+      } elsif ($meta->{scalar}) {
+          return 0.8 if $$raw_source_ref =~ /\d\.\.\d/;
+          return 0.6 if $meta->{has_newlines};
+      } elsif ($meta->{array}) {
+          return 0.8 if $meta->{size} < 5;
+          return 0.6 if $raw_source_ref->[0] =~ /foo/;
+          return 0.5;
+      } elsif ($meta->{hash}) {
+          return 0.6 if $raw_source_ref->{foo};
+          return 0.2;
+      }
+
+      return 0;
+  }
+
+  sub make_iterator {
+      my ($class, $source) = @_;
+      # this is where you manipulate the source and
+      # capture the stream of TAP in an iterator
+      # either pick a TAP::Parser::Iterator::* or write your own...
+      my $iterator = TAP::Parser::Iterator::Array->new([ 'foo', 'bar' ]);
+      return $iterator;
+  }
+
+  1;
+
+=head1 AUTHORS
+
+TAPx Developers.
+
+Source detection stuff added by Steve Purkis
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut
+

database/perl/lib/TAP/Parser/SourceHandler/Executable.pm

@@ -0,0 +1,184 @@
+package TAP::Parser::SourceHandler::Executable;
+
+use strict;
+use warnings;
+
+use TAP::Parser::IteratorFactory   ();
+use TAP::Parser::Iterator::Process ();
+
+use base 'TAP::Parser::SourceHandler';
+
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP source
+
+=head1 VERSION
+
+Version 3.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source;
+  use TAP::Parser::SourceHandler::Executable;
+
+  my $source = TAP::Parser::Source->new->raw(['/usr/bin/ruby', 'mytest.rb']);
+  $source->assemble_meta;
+
+  my $class = 'TAP::Parser::SourceHandler::Executable';
+  my $vote  = $class->can_handle( $source );
+  my $iter  = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is an I<executable> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is an executable
+   command (L</can_handle>).
+
+2. Creates an iterator for executable commands (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you
+probably won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+  my $vote = $class->can_handle( $source );
+
+Only votes if $source looks like an executable file. Casts the
+following votes:
+
+  0.9  if it's a hash with an 'exec' key
+  0.8  if it's a .bat file
+  0.75 if it's got an execute bit set
+
+=cut
+
+sub can_handle {
+    my ( $class, $src ) = @_;
+    my $meta = $src->meta;
+
+    if ( $meta->{is_file} ) {
+        my $file = $meta->{file};
+
+        return 0.85 if $file->{execute} && $file->{binary};
+        return 0.8 if $file->{lc_ext} eq '.bat';
+        return 0.25 if $file->{execute};
+    }
+    elsif ( $meta->{is_hash} ) {
+        return 0.9 if $src->raw->{exec};
+    }
+
+    return 0;
+}
+
+=head3 C<make_iterator>
+
+  my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Process> for the source.
+C<$source-E<gt>raw> must be in one of the following forms:
+
+  { exec => [ @exec ] }
+
+  [ @exec ]
+
+  $file
+
+C<croak>s on error.
+
+=cut
+
+sub make_iterator {
+    my ( $class, $source ) = @_;
+    my $meta = $source->meta;
+
+    my @command;
+    if ( $meta->{is_hash} ) {
+        @command = @{ $source->raw->{exec} || [] };
+    }
+    elsif ( $meta->{is_scalar} ) {
+        @command = ${ $source->raw };
+    }
+    elsif ( $meta->{is_array} ) {
+        @command = @{ $source->raw };
+    }
+
+    $class->_croak('No command found in $source->raw!') unless @command;
+
+    $class->_autoflush( \*STDOUT );
+    $class->_autoflush( \*STDERR );
+
+    push @command, @{ $source->test_args || [] };
+
+    return $class->iterator_class->new(
+        {   command => \@command,
+            merge   => $source->merge
+        }
+    );
+}
+
+=head3 C<iterator_class>
+
+The class of iterator to use, override if you're sub-classing.  Defaults
+to L<TAP::Parser::Iterator::Process>.
+
+=cut
+
+use constant iterator_class => 'TAP::Parser::Iterator::Process';
+
+# Turns on autoflush for the handle passed
+sub _autoflush {
+    my ( $class, $flushed ) = @_;
+    my $old_fh = select $flushed;
+    $| = 1;
+    select $old_fh;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+  package MyRubySourceHandler;
+
+  use strict;
+
+  use Carp qw( croak );
+  use TAP::Parser::SourceHandler::Executable;
+
+  use base 'TAP::Parser::SourceHandler::Executable';
+
+  # expect $handler->(['mytest.rb', 'cmdline', 'args']);
+  sub make_iterator {
+    my ($self, $source) = @_;
+    my @test_args = @{ $source->test_args };
+    my $rb_file   = $test_args[0];
+    croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+    return $self->SUPER::raw_source(['/usr/bin/ruby', @test_args]);
+  }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source;
+  use TAP::Parser::SourceHandler::File;
+
+  my $source = TAP::Parser::Source->new->raw( \'file.tap' );
+  $source->assemble_meta;
+
+  my $class = 'TAP::Parser::SourceHandler::File';
+  my $vote  = $class->can_handle( $source );
+  my $iter  = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<raw TAP stored in a file> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the I<raw> source it's given is a file containing raw TAP
+output.  See L<TAP::Parser::IteratorFactory> for more details.
+
+2. Takes raw TAP from the text file given, and converts into an iterator.
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+  my $vote = $class->can_handle( $source );
+
+Only votes if $source looks like a regular file.  Casts the following votes:
+
+  0.9 if it's a .tap file
+  0.9 if it has an extension matching any given in user config.
+
+=cut
+
+sub can_handle {
+    my ( $class, $src ) = @_;
+    my $meta   = $src->meta;
+    my $config = $src->config_for($class);
+
+    return 0 unless $meta->{is_file};
+    my $file = $meta->{file};
+    return 0.9 if $file->{lc_ext} eq '.tap';
+
+    if ( my $exts = $config->{extensions} ) {
+        my @exts = ref $exts eq 'ARRAY' ? @$exts : $exts;
+        return 0.9 if grep { lc($_) eq $file->{lc_ext} } @exts;
+    }
+
+    return 0;
+}
+
+=head3 C<make_iterator>
+
+  my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Stream> for the source.  C<croak>s
+on error.
+
+=cut
+
+sub make_iterator {
+    my ( $class, $source ) = @_;
+
+    $class->_croak('$source->raw must be a scalar ref')
+      unless $source->meta->{is_scalar};
+
+    my $file = ${ $source->raw };
+    my $fh;
+    open( $fh, '<', $file )
+      or $class->_croak("error opening TAP source file '$file': $!");
+    return $class->iterator_class->new($fh);
+}
+
+=head3 C<iterator_class>
+
+The class of iterator to use, override if you're sub-classing.  Defaults
+to L<TAP::Parser::Iterator::Stream>.
+
+=cut
+
+use constant iterator_class => 'TAP::Parser::Iterator::Stream';
+
+1;
+
+__END__
+
+=head1 CONFIGURATION
+
+  {
+   extensions => [ @case_insensitive_exts_to_match ]
+  }
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source;
+  use TAP::Parser::SourceHandler::Executable;
+
+  my $source = TAP::Parser::Source->new->raw( \*TAP_FILE );
+  $source->assemble_meta;
+
+  my $class = 'TAP::Parser::SourceHandler::Handle';
+  my $vote  = $class->can_handle( $source );
+  my $iter  = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<raw TAP stored in an IO Handle> L<TAP::Parser::SourceHandler> class.  It
+has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is an L<IO::Handle> or
+GLOB containing raw TAP output (L</can_handle>).
+
+2. Creates an iterator for IO::Handle's & globs (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+  my $vote = $class->can_handle( $source );
+
+Casts the following votes:
+
+  0.9 if $source is an IO::Handle
+  0.8 if $source is a glob
+
+=cut
+
+sub can_handle {
+    my ( $class, $src ) = @_;
+    my $meta = $src->meta;
+
+    return 0.9
+      if $meta->{is_object}
+          && UNIVERSAL::isa( $src->raw, 'IO::Handle' );
+
+    return 0.8 if $meta->{is_glob};
+
+    return 0;
+}
+
+=head3 C<make_iterator>
+
+  my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Stream> for the source.
+
+=cut
+
+sub make_iterator {
+    my ( $class, $source ) = @_;
+
+    $class->_croak('$source->raw must be a glob ref or an IO::Handle')
+      unless $source->meta->{is_glob}
+          || UNIVERSAL::isa( $source->raw, 'IO::Handle' );
+
+    return $class->iterator_class->new( $source->raw );
+}
+
+=head3 C<iterator_class>
+
+The class of iterator to use, override if you're sub-classing.  Defaults
+to L<TAP::Parser::Iterator::Stream>.
+
+=cut
+
+use constant iterator_class => 'TAP::Parser::Iterator::Stream';
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut

database/perl/lib/TAP/Parser/SourceHandler/Perl.pm

@@ -0,0 +1,370 @@
+package TAP::Parser::SourceHandler::Perl;
+
+use strict;
+use warnings;
+use Config;
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::IteratorFactory           ();
+use TAP::Parser::Iterator::Process         ();
+use Text::ParseWords qw(shellwords);
+
+use base 'TAP::Parser::SourceHandler::Executable';
+
+TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
+
+=head1 NAME
+
+TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable
+
+=head1 VERSION
+
+Version 3.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source;
+  use TAP::Parser::SourceHandler::Perl;
+
+  my $source = TAP::Parser::Source->new->raw( \'script.pl' );
+  $source->assemble_meta;
+
+  my $class = 'TAP::Parser::SourceHandler::Perl';
+  my $vote  = $class->can_handle( $source );
+  my $iter  = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<Perl> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is actually a Perl
+script (L</can_handle>).
+
+2. Creates an iterator for Perl sources (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+  my $vote = $class->can_handle( $source );
+
+Only votes if $source looks like a file.  Casts the following votes:
+
+  0.9  if it has a shebang ala "#!...perl"
+  0.75 if it has any shebang
+  0.8  if it's a .t file
+  0.9  if it's a .pl file
+  0.75 if it's in a 't' directory
+  0.25 by default (backwards compat)
+
+=cut
+
+sub can_handle {
+    my ( $class, $source ) = @_;
+    my $meta = $source->meta;
+
+    return 0 unless $meta->{is_file};
+    my $file = $meta->{file};
+
+    if ( my $shebang = $file->{shebang} ) {
+        return 0.9 if $shebang =~ /^#!.*\bperl/;
+
+        # We favour Perl as the interpreter for any shebang to preserve
+        # previous semantics: we used to execute everything via Perl and
+        # relied on it to pass the shebang off to the appropriate
+        # interpreter.
+        return 0.3;
+    }
+
+    return 0.8 if $file->{lc_ext} eq '.t';    # vote higher than Executable
+    return 0.9 if $file->{lc_ext} eq '.pl';
+
+    return 0.75 if $file->{dir} =~ /^t\b/;    # vote higher than Executable
+
+    # backwards compat, always vote:
+    return 0.25;
+}
+
+=head3 C<make_iterator>
+
+  my $iterator = $class->make_iterator( $source );
+
+Constructs & returns a new L<TAP::Parser::Iterator::Process> for the source.
+Assumes C<$source-E<gt>raw> contains a reference to the perl script.  C<croak>s
+if the file could not be found.
+
+The command to run is built as follows:
+
+  $perl @switches $perl_script @test_args
+
+The perl command to use is determined by L</get_perl>.  The command generated
+is guaranteed to preserve:
+
+  PERL5LIB
+  PERL5OPT
+  Taint Mode, if set in the script's shebang
+
+I<Note:> the command generated will I<not> respect any shebang line defined in
+your Perl script.  This is only a problem if you have compiled a custom version
+of Perl or if you want to use a specific version of Perl for one test and a
+different version for another, for example:
+
+  #!/path/to/a/custom_perl --some --args
+  #!/usr/local/perl-5.6/bin/perl -w
+
+Currently you need to write a plugin to get around this.
+
+=cut
+
+sub _autoflush_stdhandles {
+    my ($class) = @_;
+
+    $class->_autoflush( \*STDOUT );
+    $class->_autoflush( \*STDERR );
+}
+
+sub make_iterator {
+    my ( $class, $source ) = @_;
+    my $meta        = $source->meta;
+    my $perl_script = ${ $source->raw };
+
+    $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file};
+
+    # TODO: does this really need to be done here?
+    $class->_autoflush_stdhandles;
+
+    my ( $libs, $switches )
+      = $class->_mangle_switches(
+        $class->_filter_libs( $class->_switches($source) ) );
+
+    $class->_run( $source, $libs, $switches );
+}
+
+
+sub _has_taint_switch {
+    my( $class, $switches ) = @_;
+
+    my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches};
+    return $has_taint ? 1 : 0;
+}
+
+sub _mangle_switches {
+    my ( $class, $libs, $switches ) = @_;
+
+    # Taint mode ignores environment variables so we must retranslate
+    # PERL5LIB as -I switches and place PERL5OPT on the command line
+    # in order that it be seen.
+    if ( $class->_has_taint_switch($switches) ) {
+        my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : ();
+        return (
+            $libs,
+            [   @{$switches},
+                $class->_libs2switches([@$libs, @perl5lib]),
+                defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : ()
+            ],
+        );
+    }
+
+    return ( $libs, $switches );
+}
+
+sub _filter_libs {
+    my ( $class, @switches ) = @_;
+
+    my $path_sep = $Config{path_sep};
+    my $path_re  = qr{$path_sep};
+
+    # Filter out any -I switches to be handled as libs later.
+    #
+    # Nasty kludge. It might be nicer if we got the libs separately
+    # although at least this way we find any -I switches that were
+    # supplied other then as explicit libs.
+    #
+    # We filter out any names containing colons because they will break
+    # PERL5LIB
+    my @libs;
+    my @filtered_switches;
+    for (@switches) {
+        if ( !/$path_re/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+            push @libs, $1;
+        }
+        else {
+            push @filtered_switches, $_;
+        }
+    }
+
+    return \@libs, \@filtered_switches;
+}
+
+sub _iterator_hooks {
+    my ( $class, $source, $libs, $switches ) = @_;
+
+    my $setup = sub {
+        if ( @{$libs} and !$class->_has_taint_switch($switches) ) {
+            $ENV{PERL5LIB} = join(
+                $Config{path_sep}, grep {defined} @{$libs},
+                $ENV{PERL5LIB}
+            );
+        }
+    };
+
+    # VMS environment variables aren't guaranteed to reset at the end of
+    # the process, so we need to put PERL5LIB back.
+    my $previous = $ENV{PERL5LIB};
+    my $teardown = sub {
+        if ( defined $previous ) {
+            $ENV{PERL5LIB} = $previous;
+        }
+        else {
+            delete $ENV{PERL5LIB};
+        }
+    };
+
+    return ( $setup, $teardown );
+}
+
+sub _run {
+    my ( $class, $source, $libs, $switches ) = @_;
+
+    my @command = $class->_get_command_for_switches( $source, $switches )
+      or $class->_croak("No command found!");
+
+    my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches );
+
+    return $class->_create_iterator( $source, \@command, $setup, $teardown );
+}
+
+sub _create_iterator {
+    my ( $class, $source, $command, $setup, $teardown ) = @_;
+
+    return TAP::Parser::Iterator::Process->new(
+        {   command  => $command,
+            merge    => $source->merge,
+            setup    => $setup,
+            teardown => $teardown,
+        }
+    );
+}
+
+sub _get_command_for_switches {
+    my ( $class, $source, $switches ) = @_;
+    my $file    = ${ $source->raw };
+    my @args    = @{ $source->test_args || [] };
+    my $command = $class->get_perl;
+
+   # XXX don't need to quote if we treat the parts as atoms (except maybe vms)
+   #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+    my @command = ( $command, @{$switches}, $file, @args );
+    return @command;
+}
+
+sub _libs2switches {
+    my $class = shift;
+    return map {"-I$_"} grep {$_} @{ $_[0] };
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+  # $taint will be 't'
+  my $taint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+  # $untaint will be undefined
+  my $untaint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+    my ( $class, $shebang ) = @_;
+    return
+      unless defined $shebang
+          && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+    return $1;
+}
+
+sub _switches {
+    my ( $class, $source ) = @_;
+    my $file     = ${ $source->raw };
+    my @switches = @{ $source->switches || [] };
+    my $shebang  = $source->meta->{file}->{shebang};
+    return unless defined $shebang;
+
+    my $taint = $class->get_taint($shebang);
+    push @switches, "-$taint" if defined $taint;
+
+    # Quote the argument if we're VMS, since VMS will downcase anything
+    # not quoted.
+    if (IS_VMS) {
+        for (@switches) {
+            $_ = qq["$_"];
+        }
+    }
+
+    return @switches;
+}
+
+=head3 C<get_perl>
+
+Gets the version of Perl currently running the test suite.
+
+=cut
+
+sub get_perl {
+    my $class = shift;
+    return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+    return qq["$^X"] if IS_WIN32 && ( $^X =~ /[^\w\.\/\\]/ );
+    return $^X;
+}
+
+1;
+
+__END__
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+  package MyPerlSourceHandler;
+
+  use strict;
+
+  use TAP::Parser::SourceHandler::Perl;
+
+  use base 'TAP::Parser::SourceHandler::Perl';
+
+  # use the version of perl from the shebang line in the test file
+  sub get_perl {
+      my $self = shift;
+      if (my $shebang = $self->shebang( $self->{file} )) {
+          $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+	  return $1 if $1;
+      }
+      return $self->SUPER::get_perl(@_);
+  }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>,
+L<TAP::Parser::SourceHandler::RawTAP>
+
+=cut

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source;
+  use TAP::Parser::SourceHandler::RawTAP;
+
+  my $source = TAP::Parser::Source->new->raw( \"1..1\nok 1\n" );
+  $source->assemble_meta;
+
+  my $class = 'TAP::Parser::SourceHandler::RawTAP';
+  my $vote  = $class->can_handle( $source );
+  my $iter  = $class->make_iterator( $source );
+
+=head1 DESCRIPTION
+
+This is a I<raw TAP output> L<TAP::Parser::SourceHandler> - it has 2 jobs:
+
+1. Figure out if the L<TAP::Parser::Source> it's given is raw TAP output
+(L</can_handle>).
+
+2. Creates an iterator for raw TAP output (L</make_iterator>).
+
+Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
+won't need to use this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<can_handle>
+
+  my $vote = $class->can_handle( $source );
+
+Only votes if $source is an array, or a scalar with newlines.  Casts the
+following votes:
+
+  0.9  if it's a scalar with '..' in it
+  0.7  if it's a scalar with 'ok' in it
+  0.3  if it's just a scalar with newlines
+  0.5  if it's an array
+
+=cut
+
+sub can_handle {
+    my ( $class, $src ) = @_;
+    my $meta = $src->meta;
+
+    return 0 if $meta->{file};
+    if ( $meta->{is_scalar} ) {
+        return 0 unless $meta->{has_newlines};
+        return 0.9 if ${ $src->raw } =~ /\d\.\.\d/;
+        return 0.7 if ${ $src->raw } =~ /ok/;
+        return 0.3;
+    }
+    elsif ( $meta->{is_array} ) {
+        return 0.5;
+    }
+    return 0;
+}
+
+=head3 C<make_iterator>
+
+  my $iterator = $class->make_iterator( $source );
+
+Returns a new L<TAP::Parser::Iterator::Array> for the source.
+C<$source-E<gt>raw> must be an array ref, or a scalar ref.
+
+C<croak>s on error.
+
+=cut
+
+sub make_iterator {
+    my ( $class, $src ) = @_;
+    my $meta = $src->meta;
+
+    my $tap_array;
+    if ( $meta->{is_scalar} ) {
+        $tap_array = [ split "\n" => ${ $src->raw } ];
+    }
+    elsif ( $meta->{is_array} ) {
+        $tap_array = $src->raw;
+    }
+
+    $class->_croak('No raw TAP found in $source->raw')
+      unless scalar $tap_array;
+
+    return TAP::Parser::Iterator::Array->new($tap_array);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>,
+L<TAP::Parser::SourceHandler::Executable>,
+L<TAP::Parser::SourceHandler::Perl>,
+L<TAP::Parser::SourceHandler::File>,
+L<TAP::Parser::SourceHandler::Handle>
+
+=cut

database/perl/lib/TAP/Parser/YAMLish/Reader.pm

@@ -0,0 +1,332 @@
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+use warnings;
+
+use base 'TAP::Object';
+
+our $VERSION = '3.42';
+
+# TODO:
+#   Handle blessed object syntax
+
+# Printable characters for escapes
+my %UNESCAPES = (
+    z => "\x00", a => "\x07", t    => "\x09",
+    n => "\x0a", v => "\x0b", f    => "\x0c",
+    r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+my $QQ_STRING    = qr{ " (?:\\. | [^"])* " }x;
+my $HASH_LINE    = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
+my $IS_HASH_KEY  = qr{ ^ [\w\'\"] }x;
+my $IS_END_YAML  = qr{ ^ \.\.\. \s* $ }x;
+my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
+
+# new() implementation supplied by TAP::Object
+
+sub read {
+    my $self = shift;
+    my $obj  = shift;
+
+    die "Must have a code reference to read input from"
+      unless ref $obj eq 'CODE';
+
+    $self->{reader}  = $obj;
+    $self->{capture} = [];
+
+    # Prime the reader
+    $self->_next;
+    return unless $self->{next};
+
+    my $doc = $self->_read;
+
+    # The terminator is mandatory otherwise we'd consume a line from the
+    # iterator that doesn't belong to us. If we want to remove this
+    # restriction we'll have to implement look-ahead in the iterators.
+    # Which might not be a bad idea.
+    my $dots = $self->_peek;
+    die "Missing '...' at end of YAMLish"
+      unless defined $dots
+          and $dots =~ $IS_END_YAML;
+
+    delete $self->{reader};
+    delete $self->{next};
+
+    return $doc;
+}
+
+sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
+
+sub _peek {
+    my $self = shift;
+    return $self->{next} unless wantarray;
+    my $line = $self->{next};
+    $line =~ /^ (\s*) (.*) $ /x;
+    return ( $2, length $1 );
+}
+
+sub _next {
+    my $self = shift;
+    die "_next called with no reader"
+      unless $self->{reader};
+    my $line = $self->{reader}->();
+    $self->{next} = $line;
+    push @{ $self->{capture} }, $line;
+}
+
+sub _read {
+    my $self = shift;
+
+    my $line = $self->_peek;
+
+    # Do we have a document header?
+    if ( $line =~ /^ --- (?: \s* (.+?)? \s* )? $/x ) {
+        $self->_next;
+
+        return $self->_read_scalar($1) if defined $1;    # Inline?
+
+        my ( $next, $indent ) = $self->_peek;
+
+        if ( $next =~ /^ - /x ) {
+            return $self->_read_array($indent);
+        }
+        elsif ( $next =~ $IS_HASH_KEY ) {
+            return $self->_read_hash( $next, $indent );
+        }
+        elsif ( $next =~ $IS_END_YAML ) {
+            die "Premature end of YAMLish";
+        }
+        else {
+            die "Unsupported YAMLish syntax: '$next'";
+        }
+    }
+    else {
+        die "YAMLish document header not found";
+    }
+}
+
+# Parse a double quoted string
+sub _read_qq {
+    my $self = shift;
+    my $str  = shift;
+
+    unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
+        die "Internal: not a quoted string";
+    }
+
+    $str =~ s/\\"/"/gx;
+    $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) 
+                 / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
+    return $str;
+}
+
+# Parse a scalar string to the actual scalar
+sub _read_scalar {
+    my $self   = shift;
+    my $string = shift;
+
+    return undef if $string eq '~';
+    return {} if $string eq '{}';
+    return [] if $string eq '[]';
+
+    if ( $string eq '>' || $string eq '|' ) {
+
+        my ( $line, $indent ) = $self->_peek;
+        die "Multi-line scalar content missing" unless defined $line;
+
+        my @multiline = ($line);
+
+        while (1) {
+            $self->_next;
+            my ( $next, $ind ) = $self->_peek;
+            last if $ind < $indent;
+
+            my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
+            push @multiline, $pad . $next;
+        }
+
+        return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
+    }
+
+    if ( $string =~ /^ ' (.*) ' $/x ) {
+        ( my $rv = $1 ) =~ s/''/'/g;
+        return $rv;
+    }
+
+    if ( $string =~ $IS_QQ_STRING ) {
+        return $self->_read_qq($string);
+    }
+
+    if ( $string =~ /^['"]/ ) {
+
+        # A quote with folding... we don't support that
+        die __PACKAGE__ . " does not support multi-line quoted scalars";
+    }
+
+    # Regular unquoted string
+    return $string;
+}
+
+sub _read_nested {
+    my $self = shift;
+
+    my ( $line, $indent ) = $self->_peek;
+
+    if ( $line =~ /^ -/x ) {
+        return $self->_read_array($indent);
+    }
+    elsif ( $line =~ $IS_HASH_KEY ) {
+        return $self->_read_hash( $line, $indent );
+    }
+    else {
+        die "Unsupported YAMLish syntax: '$line'";
+    }
+}
+
+# Parse an array
+sub _read_array {
+    my ( $self, $limit ) = @_;
+
+    my $ar = [];
+
+    while (1) {
+        my ( $line, $indent ) = $self->_peek;
+        last
+          if $indent < $limit
+              || !defined $line
+              || $line =~ $IS_END_YAML;
+
+        if ( $indent > $limit ) {
+            die "Array line over-indented";
+        }
+
+        if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
+            $indent += length $1;
+            $line =~ s/-\s+//;
+            push @$ar, $self->_read_hash( $line, $indent );
+        }
+        elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
+            die "Unexpected start of YAMLish" if $line =~ /^---/;
+            $self->_next;
+            push @$ar, $self->_read_scalar($1);
+        }
+        elsif ( $line =~ /^ - \s* $/x ) {
+            $self->_next;
+            push @$ar, $self->_read_nested;
+        }
+        elsif ( $line =~ $IS_HASH_KEY ) {
+            $self->_next;
+            push @$ar, $self->_read_hash( $line, $indent, );
+        }
+        else {
+            die "Unsupported YAMLish syntax: '$line'";
+        }
+    }
+
+    return $ar;
+}
+
+sub _read_hash {
+    my ( $self, $line, $limit ) = @_;
+
+    my $indent;
+    my $hash = {};
+
+    while (1) {
+        die "Badly formed hash line: '$line'"
+          unless $line =~ $HASH_LINE;
+
+        my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
+        $self->_next;
+
+        if ( defined $value ) {
+            $hash->{$key} = $self->_read_scalar($value);
+        }
+        else {
+            $hash->{$key} = $self->_read_nested;
+        }
+
+        ( $line, $indent ) = $self->_peek;
+        last
+          if $indent < $limit
+              || !defined $line
+              || $line =~ $IS_END_YAML;
+    }
+
+    return $hash;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
+
+=head1 VERSION
+
+Version 3.42
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Note that parts of this code were derived from L<YAML::Tiny> with the
+permission of Adam Kennedy.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Reader> object.
+
+ my $reader = TAP::Parser::YAMLish::Reader->new; 
+
+=head2 Instance Methods
+
+=head3 C<read>
+
+ my $got = $reader->read($iterator);
+
+Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
+represents.
+
+=head3 C<get_raw>
+
+ my $source = $reader->get_source;
+
+Return the raw YAMLish source from the most recent C<read>.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
+the YAML matching regular expressions for this module.
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2011 Andy Armstrong.
+
+Portions copyright 2006-2008 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+

database/perl/lib/TAP/Parser/YAMLish/Writer.pm

@@ -0,0 +1,254 @@
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+use warnings;
+
+use base 'TAP::Object';
+
+our $VERSION = '3.42';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
+my $ESCAPE_KEY  = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
+
+my @UNPRINTABLE = qw(
+  z    x01  x02  x03  x04  x05  x06  a
+  x08  t    n    v    f    r    x0e  x0f
+  x10  x11  x12  x13  x14  x15  x16  x17
+  x18  x19  x1a  e    x1c  x1d  x1e  x1f
+);
+
+# new() implementation supplied by TAP::Object
+
+sub write {
+    my $self = shift;
+
+    die "Need something to write"
+      unless @_;
+
+    my $obj = shift;
+    my $out = shift || \*STDOUT;
+
+    die "Need a reference to something I can write to"
+      unless ref $out;
+
+    $self->{writer} = $self->_make_writer($out);
+
+    $self->_write_obj( '---', $obj );
+    $self->_put('...');
+
+    delete $self->{writer};
+}
+
+sub _make_writer {
+    my $self = shift;
+    my $out  = shift;
+
+    my $ref = ref $out;
+
+    if ( 'CODE' eq $ref ) {
+        return $out;
+    }
+    elsif ( 'ARRAY' eq $ref ) {
+        return sub { push @$out, shift };
+    }
+    elsif ( 'SCALAR' eq $ref ) {
+        return sub { $$out .= shift() . "\n" };
+    }
+    elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
+        return sub { print $out shift(), "\n" };
+    }
+
+    die "Can't write to $out";
+}
+
+sub _put {
+    my $self = shift;
+    $self->{writer}->( join '', @_ );
+}
+
+sub _enc_scalar {
+    my $self = shift;
+    my $val  = shift;
+    my $rule = shift;
+
+    return '~' unless defined $val;
+
+    if ( $val =~ /$rule/ ) {
+        $val =~ s/\\/\\\\/g;
+        $val =~ s/"/\\"/g;
+        $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
+        return qq{"$val"};
+    }
+
+    if ( length($val) == 0 or $val =~ /\s/ ) {
+        $val =~ s/'/''/;
+        return "'$val'";
+    }
+
+    return $val;
+}
+
+sub _write_obj {
+    my $self   = shift;
+    my $prefix = shift;
+    my $obj    = shift;
+    my $indent = shift || 0;
+
+    if ( my $ref = ref $obj ) {
+        my $pad = '  ' x $indent;
+        if ( 'HASH' eq $ref ) {
+            if ( keys %$obj ) {
+                $self->_put($prefix);
+                for my $key ( sort keys %$obj ) {
+                    my $value = $obj->{$key};
+                    $self->_write_obj(
+                        $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
+                        $value, $indent + 1
+                    );
+                }
+            }
+            else {
+                $self->_put( $prefix, ' {}' );
+            }
+        }
+        elsif ( 'ARRAY' eq $ref ) {
+            if (@$obj) {
+                $self->_put($prefix);
+                for my $value (@$obj) {
+                    $self->_write_obj(
+                        $pad . '-', $value,
+                        $indent + 1
+                    );
+                }
+            }
+            else {
+                $self->_put( $prefix, ' []' );
+            }
+        }
+        else {
+            die "Don't know how to encode $ref";
+        }
+    }
+    else {
+        $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
+    }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 3.42
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::YAMLish::Writer;
+    
+    my $data = {
+        one => 1,
+        two => 2,
+        three => [ 1, 2, 3 ],
+    };
+    
+    my $yw = TAP::Parser::YAMLish::Writer->new;
+    
+    # Write to an array...
+    $yw->write( $data, \@some_array );
+    
+    # ...an open file handle...
+    $yw->write( $data, $some_file_handle );
+    
+    # ...a string ...
+    $yw->write( $data, \$some_string );
+    
+    # ...or a closure
+    $yw->write( $data, sub {
+        my $line = shift;
+        print "$line\n";
+    } );
+
+=head1 DESCRIPTION
+
+Encodes a scalar, hash reference or array reference as YAMLish.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Writer> object.
+
+=head2 Instance Methods
+
+=head3 C<write>
+
+ $writer->write($obj, $output );
+
+Encode a scalar, hash reference or array reference as YAML.
+
+    my $writer = sub {
+        my $line = shift;
+        print SOMEFILE "$line\n";
+    };
+    
+    my $data = {
+        one => 1,
+        two => 2,
+        three => [ 1, 2, 3 ],
+    };
+    
+    my $yw = TAP::Parser::YAMLish::Writer->new;
+    $yw->write( $data, $writer );
+
+
+The C< $output > argument may be:
+
+=over
+
+=item * a reference to a scalar to append YAML to
+
+=item * the handle of an open file
+
+=item * a reference to an array into which YAML will be pushed
+
+=item * a code reference
+
+=back
+
+If you supply a code reference the subroutine will be called once for
+each line of output with the line as its only argument. Passed lines
+will have no trailing newline.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2011 Andy Armstrong.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+