Initial Commit
This commit is contained in:
184
database/perl/lib/TAP/Parser/SourceHandler/Executable.pm
Normal file
184
database/perl/lib/TAP/Parser/SourceHandler/Executable.pm
Normal file
@@ -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
|
||||
136
database/perl/lib/TAP/Parser/SourceHandler/File.pm
Normal file
136
database/perl/lib/TAP/Parser/SourceHandler/File.pm
Normal file
@@ -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
|
||||
124
database/perl/lib/TAP/Parser/SourceHandler/Handle.pm
Normal file
124
database/perl/lib/TAP/Parser/SourceHandler/Handle.pm
Normal file
@@ -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
|
||||
370
database/perl/lib/TAP/Parser/SourceHandler/Perl.pm
Normal file
370
database/perl/lib/TAP/Parser/SourceHandler/Perl.pm
Normal file
@@ -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
|
||||
130
database/perl/lib/TAP/Parser/SourceHandler/RawTAP.pm
Normal file
130
database/perl/lib/TAP/Parser/SourceHandler/RawTAP.pm
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user