summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm374
1 files changed, 293 insertions, 81 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm
index 9263e9e5442..a33fe6fdb62 100644
--- a/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm
@@ -3,35 +3,49 @@ package TAP::Parser::Source;
use strict;
use vars qw($VERSION @ISA);
-use TAP::Object ();
-use TAP::Parser::IteratorFactory ();
+use TAP::Object ();
+use File::Basename qw( fileparse );
@ISA = qw(TAP::Object);
-# Causes problem on MacOS and shouldn't be necessary anyway
-#$SIG{CHLD} = sub { wait };
-
=head1 NAME
-TAP::Parser::Source - Stream output from some source
+TAP::Parser::Source - a TAP source & meta data about it
=head1 VERSION
-Version 3.17
+Version 3.23
=cut
-$VERSION = '3.17';
+$VERSION = '3.23';
=head1 SYNOPSIS
use TAP::Parser::Source;
my $source = TAP::Parser::Source->new;
- my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+ $source->raw( \'reference to raw TAP source' )
+ ->config( \%config )
+ ->merge( $boolean )
+ ->switches( \@switches )
+ ->test_args( \@args )
+ ->assemble_meta;
+
+ do { ... } if $source->meta->{is_file};
+ # see assemble_meta for a full list of data available
=head1 DESCRIPTION
-Takes a command and hopefully returns a stream from it.
+A TAP I<source> is something that produces a stream of TAP for the parser to
+consume, such as an executable file, a text file, an archive, an IO handle, a
+database, etc. C<TAP::Parser::Source>s encapsulate these I<raw> sources, and
+provide some useful meta data about them. They are used by
+L<TAP::Parser::SourceHandler>s, which do whatever is required to produce &
+capture a stream of TAP from the I<raw> source, and package it up in a
+L<TAP::Parser::Iterator> for the parser to consume.
+
+Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or
+subclassing L<TAP::Parser>, you probably won't need to use this module directly.
=head1 METHODS
@@ -48,10 +62,9 @@ Returns a new C<TAP::Parser::Source> object.
# new() implementation supplied by TAP::Object
sub _initialize {
- my ( $self, $args ) = @_;
- $self->{switches} = [];
- _autoflush( \*STDOUT );
- _autoflush( \*STDERR );
+ my ($self) = @_;
+ $self->meta( {} );
+ $self->config( {} );
return $self;
}
@@ -59,69 +72,86 @@ sub _initialize {
=head2 Instance Methods
-=head3 C<source>
+=head3 C<raw>
- my $source = $source->source;
- $source->source(['./some_prog some_test_file']);
+ my $raw = $source->raw;
+ $source->raw( $some_value );
- # or
- $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
+Chaining getter/setter for the raw TAP source. This is a reference, as it may
+contain large amounts of data (eg: raw TAP).
-Getter/setter for the source. The source should generally consist of an array
-reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>,
-should return a filehandle which returns successive rows of TAP. C<croaks> if
-it doesn't get an arrayref.
+=head3 C<meta>
-=cut
+ my $meta = $source->meta;
+ $source->meta({ %some_value });
-sub source {
- my $self = shift;
- return $self->{source} unless @_;
- unless ( 'ARRAY' eq ref $_[0] ) {
- $self->_croak('Argument to &source must be an array reference');
- }
- $self->{source} = shift;
- return $self;
-}
+Chaining getter/setter for meta data about the source. This defaults to an
+empty hashref. See L</assemble_meta> for more info.
-##############################################################################
+=head3 C<has_meta>
-=head3 C<get_stream>
+True if the source has meta data.
- my $stream = $source->get_stream;
+=head3 C<config>
-Returns a L<TAP::Parser::Iterator> stream of the output generated by executing
-C<source>. C<croak>s if there was no command found.
+ my $config = $source->config;
+ $source->config({ %some_value });
-Must be passed an object that implements a C<make_iterator> method.
-Typically this is a TAP::Parser instance.
+Chaining getter/setter for the source's configuration, if any has been provided
+by the user. How it's used is up to you. This defaults to an empty hashref.
+See L</config_for> for more info.
-=cut
+=head3 C<merge>
-sub get_stream {
- my ( $self, $factory ) = @_;
- my @command = $self->_get_command
- or $self->_croak('No command found!');
+ my $merge = $source->merge;
+ $source->config( $bool );
- return $factory->make_iterator(
- { command => \@command,
- merge => $self->merge
- }
- );
-}
+Chaining getter/setter for the flag that dictates whether STDOUT and STDERR
+should be merged (where appropriate). Defaults to undef.
-sub _get_command { return @{ shift->source || [] } }
+=head3 C<switches>
-##############################################################################
+ my $switches = $source->switches;
+ $source->config([ @switches ]);
-=head3 C<merge>
+Chaining getter/setter for the list of command-line switches that should be
+passed to the source (where appropriate). Defaults to undef.
- my $merge = $source->merge;
+=head3 C<test_args>
+
+ my $test_args = $source->test_args;
+ $source->config([ @test_args ]);
-Sets or returns the flag that dictates whether STDOUT and STDERR are merged.
+Chaining getter/setter for the list of command-line arguments that should be
+passed to the source (where appropriate). Defaults to undef.
=cut
+sub raw {
+ my $self = shift;
+ return $self->{raw} unless @_;
+ $self->{raw} = shift;
+ return $self;
+}
+
+sub meta {
+ my $self = shift;
+ return $self->{meta} unless @_;
+ $self->{meta} = shift;
+ return $self;
+}
+
+sub has_meta {
+ return scalar %{ shift->meta } ? 1 : 0;
+}
+
+sub config {
+ my $self = shift;
+ return $self->{config} unless @_;
+ $self->{config} = shift;
+ return $self;
+}
+
sub merge {
my $self = shift;
return $self->{merge} unless @_;
@@ -129,45 +159,227 @@ sub merge {
return $self;
}
-# Turns on autoflush for the handle passed
-sub _autoflush {
- my $flushed = shift;
- my $old_fh = select $flushed;
- $| = 1;
- select $old_fh;
+sub switches {
+ my $self = shift;
+ return $self->{switches} unless @_;
+ $self->{switches} = shift;
+ return $self;
}
-1;
+sub test_args {
+ my $self = shift;
+ return $self->{test_args} unless @_;
+ $self->{test_args} = shift;
+ return $self;
+}
+
+=head3 C<assemble_meta>
+
+ my $meta = $source->assemble_meta;
+
+Gathers meta data about the L</raw> source, stashes it in L</meta> and returns
+it as a hashref. This is done so that the L<TAP::Parser::SourceHandler>s don't
+have to repeat common checks. Currently this includes:
+
+ is_scalar => $bool,
+ is_hash => $bool,
+ is_array => $bool,
+
+ # for scalars:
+ length => $n
+ has_newlines => $bool
+
+ # only done if the scalar looks like a filename
+ is_file => $bool,
+ is_dir => $bool,
+ is_symlink => $bool,
+ file => {
+ # only done if the scalar looks like a filename
+ basename => $string, # including ext
+ dir => $string,
+ ext => $string,
+ lc_ext => $string,
+ # system checks
+ exists => $bool,
+ stat => [ ... ], # perldoc -f stat
+ empty => $bool,
+ size => $n,
+ text => $bool,
+ binary => $bool,
+ read => $bool,
+ write => $bool,
+ execute => $bool,
+ setuid => $bool,
+ setgid => $bool,
+ sticky => $bool,
+ is_file => $bool,
+ is_dir => $bool,
+ is_symlink => $bool,
+ # only done if the file's a symlink
+ lstat => [ ... ], # perldoc -f lstat
+ # only done if the file's a readable text file
+ shebang => $first_line,
+ }
-=head1 SUBCLASSING
+ # for arrays:
+ size => $n,
-Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+=cut
-=head2 Example
+sub assemble_meta {
+ my ($self) = @_;
- package MyRubySource;
+ return $self->meta if $self->has_meta;
- use strict;
- use vars '@ISA';
+ my $meta = $self->meta;
+ my $raw = $self->raw;
- use Carp qw( croak );
- use TAP::Parser::Source;
+ # rudimentary is object test - if it's blessed it'll
+ # inherit from UNIVERSAL
+ $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0;
+
+ if ( $meta->{is_object} ) {
+ $meta->{class} = ref($raw);
+ }
+ else {
+ my $ref = lc( ref($raw) );
+ $meta->{"is_$ref"} = 1;
+ }
+
+ if ( $meta->{is_scalar} ) {
+ my $source = $$raw;
+ $meta->{length} = length($$raw);
+ $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0;
+
+ # only do file checks if it looks like a filename
+ if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) {
+ my $file = {};
+ $file->{exists} = -e $source ? 1 : 0;
+ if ( $file->{exists} ) {
+ $meta->{file} = $file;
+
+ # avoid extra system calls (see `perldoc -f -X`)
+ $file->{stat} = [ stat(_) ];
+ $file->{empty} = -z _ ? 1 : 0;
+ $file->{size} = -s _;
+ $file->{text} = -T _ ? 1 : 0;
+ $file->{binary} = -B _ ? 1 : 0;
+ $file->{read} = -r _ ? 1 : 0;
+ $file->{write} = -w _ ? 1 : 0;
+ $file->{execute} = -x _ ? 1 : 0;
+ $file->{setuid} = -u _ ? 1 : 0;
+ $file->{setgid} = -g _ ? 1 : 0;
+ $file->{sticky} = -k _ ? 1 : 0;
+
+ $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0;
+ $meta->{is_dir} = $file->{is_dir} = -d _ ? 1 : 0;
+
+ # symlink check requires another system call
+ $meta->{is_symlink} = $file->{is_symlink}
+ = -l $source ? 1 : 0;
+ if ( $file->{is_symlink} ) {
+ $file->{lstat} = [ lstat(_) ];
+ }
+
+ # put together some common info about the file
+ ( $file->{basename}, $file->{dir}, $file->{ext} )
+ = map { defined $_ ? $_ : '' }
+ fileparse( $source, qr/\.[^.]*/ );
+ $file->{lc_ext} = lc( $file->{ext} );
+ $file->{basename} .= $file->{ext} if $file->{ext};
+
+ if ( $file->{text} and $file->{read} ) {
+ eval { $file->{shebang} = $self->_read_shebang($$raw); };
+ if ( my $e = $@ ) {
+ warn $e;
+ }
+ }
+ }
+ }
+ }
+ elsif ( $meta->{is_array} ) {
+ $meta->{size} = $#$raw + 1;
+ }
+ elsif ( $meta->{is_hash} ) {
+ ; # do nothing
+ }
+
+ return $meta;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
- @ISA = qw( TAP::Parser::Source );
+ sub _read_shebang {
+ my ( $self, $file ) = @_;
+ my $shebang;
+ local *TEST;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ chomp $shebang;
+ close(TEST) or die "Can't close $file. $!\n";
+ }
+ else {
+ die "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ $shebang_for{$file} = $class->_read_shebang($file)
+ unless exists $shebang_for{$file};
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<config_for>
+
+ my $config = $source->config_for( $class );
+
+Returns L</config> for the $class given. Class names may be fully qualified
+or abbreviated, eg:
+
+ # these are equivalent
+ $source->config_for( 'Perl' );
+ $source->config_for( 'TAP::Parser::SourceHandler::Perl' );
- # expect $source->(['mytest.rb', 'cmdline', 'args']);
- sub source {
- my ($self, $args) = @_;
- my ($rb_file) = @$args;
- croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
- return $self->SUPER::source(['/usr/bin/ruby', @$args]);
- }
+If a fully qualified $class is given, its abbreviated version is checked first.
+
+=cut
+
+sub config_for {
+ my ( $self, $class ) = @_;
+ my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ );
+ my $config = $self->config->{$abbrv_class} || $self->config->{$class};
+ return $config;
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Steve Purkis.
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
-L<TAP::Parser::Source::Perl>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::SourceHandler>
=cut
-