Initial Commit
This commit is contained in:
Riley Schneider
381
database/perl/lib/TAP/Parser/Source.pm
Normal file
381
database/perl/lib/TAP/Parser/Source.pm
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user