diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm | 374 |
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 - |