diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler')
6 files changed, 1140 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Executable.pm b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Executable.pm new file mode 100755 index 00000000000..5337abac543 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Executable.pm @@ -0,0 +1,185 @@ +package TAP::Parser::SourceHandler::Executable; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP source + +=head1 VERSION + +Version 3.20 + +=cut + +$VERSION = '3.20'; + +=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 .sh file + 0.8 if it's a .bat file + 0.75 if it's got an execute bit set + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + if ( $meta->{is_file} ) { + my $file = $meta->{file}; + + # Note: we go in low so we can be out-voted + return 0.8 if $file->{lc_ext} eq '.sh'; + return 0.8 if $file->{lc_ext} eq '.bat'; + return 0.7 if $file->{execute}; + } + elsif ( $meta->{is_hash} ) { + return 0.9 if $src->raw->{exec}; + } + + return 0; +} + +=head3 C<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 ); + + return $class->iterator_class->new( + { command => \@command, + merge => $source->merge + } + ); +} + +=head3 C<iterator_class> + +The class of iterator to use, override if you're sub-classing. Defaults +to L<TAP::Parser::Iterator::Process>. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Process'; + +# Turns on autoflush for the handle passed +sub _autoflush { + my ( $class, $flushed ) = @_; + my $old_fh = select $flushed; + $| = 1; + select $old_fh; +} + +1; + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head2 Example + + package MyRubySourceHandler; + + use strict; + use vars '@ISA'; + + use Carp qw( croak ); + use TAP::Parser::SourceHandler::Executable; + + @ISA = qw( TAP::Parser::SourceHandler::Executable ); + + # expect $handler->(['mytest.rb', 'cmdline', 'args']); + sub make_iterator { + my ($self, $source) = @_; + my @test_args = @{ $source->test_args }; + my $rb_file = $test_args[0]; + croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file); + return $self->SUPER::raw_source(['/usr/bin/ruby', @test_args]); + } + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/File.pm b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/File.pm new file mode 100755 index 00000000000..d44ace11483 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/File.pm @@ -0,0 +1,136 @@ +package TAP::Parser::SourceHandler::File; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::File - Stream TAP from a text file. + +=head1 VERSION + +Version 3.20 + +=cut + +$VERSION = '3.20'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::File; + + my $source = TAP::Parser::Source->new->raw( \'file.tap' ); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::File'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is a I<raw TAP stored in a file> L<TAP::Parser::SourceHandler> - it has 2 jobs: + +1. Figure out if the I<raw> source it's given is a file containing raw TAP +output. See L<TAP::Parser::IteratorFactory> for more details. + +2. Takes raw TAP from the text file given, and converts into an iterator. + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Only votes if $source looks like a regular file. Casts the following votes: + + 0.9 if it's a .tap file + 0.9 if it has an extension matching any given in user config. + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + my $config = $src->config_for($class); + + return 0 unless $meta->{is_file}; + my $file = $meta->{file}; + return 0.9 if $file->{lc_ext} eq '.tap'; + + if ( my $exts = $config->{extensions} ) { + return 0.9 if grep { lc($_) eq $file->{lc_ext} } @$exts; + } + + return 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Stream> for the source. C<croak>s +on error. + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + + $class->_croak('$source->raw must be a scalar ref') + unless $source->meta->{is_scalar}; + + my $file = ${ $source->raw }; + my $fh; + open( $fh, '<', $file ) + or $class->_croak("error opening TAP source file '$file': $!"); + return $class->iterator_class->new($fh); +} + +=head3 C<iterator_class> + +The class of iterator to use, override if you're sub-classing. Defaults +to L<TAP::Parser::Iterator::Stream>. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Stream'; + +1; + +__END__ + +=head1 CONFIGURATION + + { + extensions => [ @case_insensitive_exts_to_match ] + } + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Handle.pm b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Handle.pm new file mode 100755 index 00000000000..30594fa1e75 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Handle.pm @@ -0,0 +1,125 @@ +package TAP::Parser::SourceHandler::Handle; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB. + +=head1 VERSION + +Version 3.20 + +=cut + +$VERSION = '3.20'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::Executable; + + my $source = TAP::Parser::Source->new->raw( \*TAP_FILE ); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::Handle'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is a I<raw TAP stored in an IO Handle> L<TAP::Parser::SourceHandler> class. It +has 2 jobs: + +1. Figure out if the L<TAP::Parser::Source> it's given is an L<IO::Handle> or +GLOB containing raw TAP output (L</can_handle>). + +2. Creates an iterator for IO::Handle's & globs (L</make_iterator>). + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Casts the following votes: + + 0.9 if $source is an IO::Handle + 0.8 if $source is a glob + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + return 0.9 + if $meta->{is_object} + && UNIVERSAL::isa( $src->raw, 'IO::Handle' ); + + return 0.8 if $meta->{is_glob}; + + return 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Stream> for the source. + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + + $class->_croak('$source->raw must be a glob ref or an IO::Handle') + unless $source->meta->{is_glob} + || UNIVERSAL::isa( $source->raw, 'IO::Handle' ); + + return $class->iterator_class->new( $source->raw ); +} + +=head3 C<iterator_class> + +The class of iterator to use, override if you're sub-classing. Defaults +to L<TAP::Parser::Iterator::Stream>. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Stream'; + +1; + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::Iterator>, +L<TAP::Parser::Iterator::Stream>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Perl.pm b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Perl.pm new file mode 100755 index 00000000000..f6513fd3156 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/Perl.pm @@ -0,0 +1,310 @@ +package TAP::Parser::SourceHandler::Perl; + +use strict; +use Config; +use vars qw($VERSION @ISA); + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => ( $^O eq 'VMS' ); + +use TAP::Parser::SourceHandler::Executable (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); +use TAP::Parser::Utils qw( split_shell ); + +@ISA = 'TAP::Parser::SourceHandler::Executable'; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable + +=head1 VERSION + +Version 3.20 + +=cut + +$VERSION = '3.20'; + +=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.8 if it's a .t file + 0.9 if it's a .pl file + 0.75 if it's in a 't' directory + 0.25 by default (backwards compat) + +=cut + +sub can_handle { + my ( $class, $source ) = @_; + my $meta = $source->meta; + + return 0 unless $meta->{is_file}; + my $file = $meta->{file}; + + if ( my $shebang = $file->{shebang} ) { + return 0.9 if $shebang =~ /^#!.*\bperl/; + } + + return 0.8 if $file->{lc_ext} eq '.t'; # vote higher than Executable + return 0.9 if $file->{lc_ext} eq '.pl'; + + return 0.75 if $file->{dir} =~ /^t\b/; # vote higher than Executable + + # backwards compat, always vote: + return 0.25; +} + +=head3 C<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 make_iterator { + my ( $class, $source ) = @_; + my $meta = $source->meta; + my $perl_script = ${ $source->raw }; + + $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file}; + + # TODO: does this really need to be done here? + $class->_autoflush( \*STDOUT ); + $class->_autoflush( \*STDERR ); + + my @switches = $class->_switches($source); + my $path_sep = $Config{path_sep}; + my $path_re = qr{$path_sep}; + + # Filter out any -I switches to be handled as libs later. + # + # Nasty kludge. It might be nicer if we got the libs separately + # although at least this way we find any -I switches that were + # supplied other then as explicit libs. + # + # We filter out any names containing colons because they will break + # PERL5LIB + my @libs; + my @filtered_switches; + for (@switches) { + if ( !/$path_re/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { + push @libs, $1; + } + else { + push @filtered_switches, $_; + } + } + @switches = @filtered_switches; + + my $setup = sub { + if (@libs) { + $ENV{PERL5LIB} + = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); + } + }; + + # Cargo culted from comments seen elsewhere about VMS / environment + # variables. I don't know if this is actually necessary. + my $previous = $ENV{PERL5LIB}; + my $teardown = sub { + if ( defined $previous ) { + $ENV{PERL5LIB} = $previous; + } + else { + delete $ENV{PERL5LIB}; + } + }; + + # Taint mode ignores environment variables so we must retranslate + # PERL5LIB as -I switches and place PERL5OPT on the command line + # in order that it be seen. + if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { + push @switches, $class->_libs2switches(@libs); + push @switches, split_shell( $ENV{PERL5OPT} ); + } + + my @command = $class->_get_command_for_switches( $source, @switches ) + or $class->_croak("No command found!"); + + return TAP::Parser::Iterator::Process->new( + { command => \@command, + merge => $source->merge, + setup => $setup, + teardown => $teardown, + } + ); +} + +sub _get_command_for_switches { + my ( $class, $source, @switches ) = @_; + my $file = ${ $source->raw }; + my @args = @{ $source->test_args || [] }; + my $command = $class->get_perl; + + # XXX don't need to quote if we treat the parts as atoms (except maybe vms) + #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); + my @command = ( $command, @switches, $file, @args ); + return @command; +} + +sub _libs2switches { + my $class = shift; + return map {"-I$_"} grep {$_} @_; +} + +=head3 C<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 @args = @{ $source->test_args || [] }; + my @switches = @{ $source->switches || [] }; + my $shebang = $source->meta->{file}->{shebang}; + return unless defined $shebang; + + my $taint = $class->get_taint($shebang); + push @switches, "-$taint" if defined $taint; + + # Quote the argument if we're VMS, since VMS will downcase anything + # not quoted. + if (IS_VMS) { + for (@switches) { + $_ = qq["$_"]; + } + } + + return @switches; +} + +=head3 C<get_perl> + +Gets the version of Perl currently running the test suite. + +=cut + +sub get_perl { + my $class = shift; + return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; + return Win32::GetShortPathName($^X) if IS_WIN32; + return $^X; +} + +1; + +__END__ + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head2 Example + + package MyPerlSourceHandler; + + use strict; + use vars '@ISA'; + + use TAP::Parser::SourceHandler::Perl; + + @ISA = qw( TAP::Parser::SourceHandler::Perl ); + + # use the version of perl from the shebang line in the test file + sub get_perl { + my $self = shift; + if (my $shebang = $self->shebang( $self->{file} )) { + $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; + return $1 if $1; + } + return $self->SUPER::get_perl(@_); + } + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/RawTAP.pm b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/RawTAP.pm new file mode 100755 index 00000000000..c7048be98de --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/RawTAP.pm @@ -0,0 +1,131 @@ +package TAP::Parser::SourceHandler::RawTAP; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Array (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/array ref. + +=head1 VERSION + +Version 3.20 + +=cut + +$VERSION = '3.20'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::RawTAP; + + my $source = TAP::Parser::Source->new->raw( \"1..1\nok 1\n" ); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::RawTAP'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is a I<raw TAP output> L<TAP::Parser::SourceHandler> - it has 2 jobs: + +1. Figure out if the L<TAP::Parser::Source> it's given is raw TAP output +(L</can_handle>). + +2. Creates an iterator for raw TAP output (L</make_iterator>). + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Only votes if $source is an array, or a scalar with newlines. Casts the +following votes: + + 0.9 if it's a scalar with '..' in it + 0.7 if it's a scalar with 'ok' in it + 0.3 if it's just a scalar with newlines + 0.5 if it's an array + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + return 0 if $meta->{file}; + if ( $meta->{is_scalar} ) { + return 0 unless $meta->{has_newlines}; + return 0.9 if ${ $src->raw } =~ /\d\.\.\d/; + return 0.7 if ${ $src->raw } =~ /ok/; + return 0.3; + } + elsif ( $meta->{is_array} ) { + return 0.5; + } + return 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Array> for the source. +C<$source-E<gt>raw> must be an array ref, or a scalar ref. + +C<croak>s on error. + +=cut + +sub make_iterator { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + my $tap_array; + if ( $meta->{is_scalar} ) { + $tap_array = [ split "\n" => ${ $src->raw } ]; + } + elsif ( $meta->{is_array} ) { + $tap_array = $src->raw; + } + + $class->_croak('No raw TAP found in $source->raw') + unless scalar $tap_array; + + return TAP::Parser::Iterator::Array->new($tap_array); +} + +1; + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/pgTAP.pm b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/pgTAP.pm new file mode 100755 index 00000000000..aeaf5365ff5 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/TAP/Parser/SourceHandler/pgTAP.pm @@ -0,0 +1,253 @@ +package TAP::Parser::SourceHandler::pgTAP; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); + +@ISA = qw(TAP::Parser::SourceHandler); +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::pgTAP - Stream TAP from pgTAP test scripts + +=head1 VERSION + +Version 3.20 + +=cut + +$VERSION = '3.20'; + +=head1 SYNOPSIS + +In F<Build.PL> for your application with pgTAP tests in F<t/*.pg>: + + Module::Build->new( + module_name => 'MyApp', + test_file_exts => [qw(.t .pg)], + use_tap_harness => 1, + tap_harness_args => { + sources => { + Perl => undef, + pgTAP => { + dbname => 'try', + username => 'postgres', + suffix => '.pg', + }, + } + }, + build_requires => { + 'Module::Build' => '0.30', + 'TAP::Parser::SourceHandler::pgTAP' => '3.19', + }, + )->create_build_script; + +If you're using L<C<prove>|prove>: + + prove --source Perl \ + --source pgTAP --pgtap-option dbname=try \ + --pgtap-option username=postgres \ + --pgtap-option suffix=.pg + +Direct use: + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::pgTAP; + + my $source = TAP::Parser::Source->new->raw(\'mytest.pg'); + $source->config({ pgTAP => { + dbname => 'testing', + username => 'postgres', + suffix => '.pg', + }); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::pgTAP'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This source handler executes pgTAP tests. It does two things: + +=over + +=item 1. + +Looks at the L<TAP::Parser::Source> passed to it to determine whether or not +the source in question is in fact a pgTAP test (L</can_handle>). + +=item 2. + +Creates an iterator that will call C<psql> to run the pgTAP tests +(L</make_iterator>). + +=back + +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 ); + +Looks at the source to determine whether or not it's a pgTAP test file and +returns a score for how likely it is in fact a pgTAP test file. The scores are +as follows: + + 1 if it has a suffix equal to that in the "suffix" config + 1 if its suffix is ".pg" + 0.8 if its suffix is ".sql" + 0.75 if its suffix is ".s" + +The latter two scores are subject to change, so try to name your pgTAP tests +ending in ".pg" or specify a suffix in the configuration to be sure. + +=cut + +sub can_handle { + my ( $class, $source ) = @_; + my $meta = $source->meta; + + return 0 unless $meta->{is_file}; + + my $suf = $meta->{file}{lc_ext}; + + # If the config specifies a suffix, it's required. + if ( my $config = $source->config_for('pgTAP') ) { + if ( defined $config->{suffix} ) { + return $suf eq $config->{suffix} ? 1 : 0; + } + } + + # Otherwise, return a score for our supported suffixes. + my %score_for = ( + '.pg' => 0.9, + '.sql' => 0.8, + '.s' => 0.75, + ); + return $score_for{$suf} || 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Process> for the source. C<< +$source->raw >> must be either a file name or a scalar reference to the file +name. + +The pgTAP tests are run by executing C<psql>, the PostgreSQL command-line +utility. A number of arguments are passed to it, many of which you can effect +by setting up the source source configuration. The configuration must be a +hash reference, and supports the following keys: + +=over + +=item C<psql> + +The path to the C<psql> command. Defaults to simply "psql", which should work +well enough if it's in your path. + +=item C<dbname> + +The database to which to connect to run the tests. Defaults to the value of +the C<$PGDATABASE> environment variable or, if not set, to the system +username. + +=item C<username> + +The PostgreSQL username to use to connect to PostgreSQL. If not specified, no +username will be used, in which case C<psql> will fall back on either the +C<$PGUSER> environment variable or, if not set, the system username. + +=item C<host> + +Specifies the host name of the machine to which to connect to the PostgreSQL +server. If the value begins with a slash, it is used as the directory for the +Unix-domain socket. Defaults to the value of the C<$PGDATABASE> environment +variable or, if not set, the local host. + +=item C<port> + +Specifies the TCP port or the local Unix-domain socket file extension on which +the server is listening for connections. Defaults to the value of the +C<$PGPORT> environment variable or, if not set, to the port specified at the +time C<psql> was compiled, usually 5432. + +=begin comment + +=item C<search_path> + +The schema search path to use during the execution of the tests. Useful for +overriding the default search path and you have pgTAP installed in a schema +not included in that search path. + +=end comment + +=back + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + my $config = $source->config_for('pgTAP'); + + my @command = ( $config->{psql} || 'psql' ); + push @command, qw( + --no-psqlrc + --no-align + --quiet + --pset pager= + --pset tuples_only=true + --set ON_ERROR_ROLLBACK=1 + --set ON_ERROR_STOP=1 + ); + + for (qw(username host port dbname)) { + push @command, "--$_" => $config->{$_} if defined $config->{$_}; + } + + my $fn = ref $source->raw ? ${ $source->raw } : $source->raw; + $class->_croak( + 'No such file or directory: ' . ( defined $fn ? $fn : '' ) ) + unless $fn && -e $fn; + + push @command, '--file', $fn; + + # XXX I'd like a way to be able to specify environment variables to set when + # the iterator executes the command... + # local $ENV{PGOPTIONS} = "--search_path=$config->{search_path}" + # if $config->{search_path}; + + return TAP::Parser::Iterator::Process->new( + { command => \@command, + merge => $source->merge + } + ); +} + +=head1 SEE ALSO + +L<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>, +L<TAP::Parser::SourceHandler::RawTAP> + +=head1 AUTHOR + +David E. Wheeler <dwheeler@cpan.org> + +=cut |