cpan/Test-Harness/lib/TAP/Parser/Source.pm

   1 package TAP::Parser::Source;
   2
   3 use strict;
   4 use warnings;
   5
   6 use File::Basename qw( fileparse );
   7 use base 'TAP::Object';
   8
   9 use constant BLK_SIZE => 512;
  10
  11 =head1 NAME
  12
  13 TAP::Parser::Source - a TAP source & meta data about it
  14
  15 =head1 VERSION
  16
  17 Version 3.42
  18
  19 =cut
  20
  21 our $VERSION = '3.42';
  22
  23 =head1 SYNOPSIS
  24
  25   use TAP::Parser::Source;
  26   my $source = TAP::Parser::Source->new;
  27   $source->raw( \'reference to raw TAP source' )
  28          ->config( \%config )
  29          ->merge( $boolean )
  30          ->switches( \@switches )
  31          ->test_args( \@args )
  32          ->assemble_meta;
  33
  34   do { ... } if $source->meta->{is_file};
  35   # see assemble_meta for a full list of data available
  36
  37 =head1 DESCRIPTION
  38
  39 A TAP I<source> is something that produces a stream of TAP for the parser to
  40 consume, such as an executable file, a text file, an archive, an IO handle, a
  41 database, etc.  C<TAP::Parser::Source>s encapsulate these I<raw> sources, and
  42 provide some useful meta data about them.  They are used by
  43 L<TAP::Parser::SourceHandler>s, which do whatever is required to produce &
  44 capture a stream of TAP from the I<raw> source, and package it up in a
  45 L<TAP::Parser::Iterator> for the parser to consume.
  46
  47 Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or
  48 subclassing L<TAP::Parser>, you probably won't need to use this module directly.
  49
  50 =head1 METHODS
  51
  52 =head2 Class Methods
  53
  54 =head3 C<new>
  55
  56  my $source = TAP::Parser::Source->new;
  57
  58 Returns a new C<TAP::Parser::Source> object.
  59
  60 =cut
  61
  62 # new() implementation supplied by TAP::Object
  63
  64 sub _initialize {
  65     my ($self) = @_;
  66     $self->meta(   {} );
  67     $self->config( {} );
  68     return $self;
  69 }
  70
  71 ##############################################################################
  72
  73 =head2 Instance Methods
  74
  75 =head3 C<raw>
  76
  77   my $raw = $source->raw;
  78   $source->raw( $some_value );
  79
  80 Chaining getter/setter for the raw TAP source.  This is a reference, as it may
  81 contain large amounts of data (eg: raw TAP).
  82
  83 =head3 C<meta>
  84
  85   my $meta = $source->meta;
  86   $source->meta({ %some_value });
  87
  88 Chaining getter/setter for meta data about the source.  This defaults to an
  89 empty hashref.  See L</assemble_meta> for more info.
  90
  91 =head3 C<has_meta>
  92
  93 True if the source has meta data.
  94
  95 =head3 C<config>
  96
  97   my $config = $source->config;
  98   $source->config({ %some_value });
  99
 100 Chaining getter/setter for the source's configuration, if any has been provided
 101 by the user.  How it's used is up to you.  This defaults to an empty hashref.
 102 See L</config_for> for more info.
 103
 104 =head3 C<merge>
 105
 106   my $merge = $source->merge;
 107   $source->config( $bool );
 108
 109 Chaining getter/setter for the flag that dictates whether STDOUT and STDERR
 110 should be merged (where appropriate).  Defaults to undef.
 111
 112 =head3 C<switches>
 113
 114   my $switches = $source->switches;
 115   $source->config([ @switches ]);
 116
 117 Chaining getter/setter for the list of command-line switches that should be
 118 passed to the source (where appropriate).  Defaults to undef.
 119
 120 =head3 C<test_args>
 121
 122   my $test_args = $source->test_args;
 123   $source->config([ @test_args ]);
 124
 125 Chaining getter/setter for the list of command-line arguments that should be
 126 passed to the source (where appropriate).  Defaults to undef.
 127
 128 =cut
 129
 130 sub raw {
 131     my $self = shift;
 132     return $self->{raw} unless @_;
 133     $self->{raw} = shift;
 134     return $self;
 135 }
 136
 137 sub meta {
 138     my $self = shift;
 139     return $self->{meta} unless @_;
 140     $self->{meta} = shift;
 141     return $self;
 142 }
 143
 144 sub has_meta {
 145     return scalar %{ shift->meta } ? 1 : 0;
 146 }
 147
 148 sub config {
 149     my $self = shift;
 150     return $self->{config} unless @_;
 151     $self->{config} = shift;
 152     return $self;
 153 }
 154
 155 sub merge {
 156     my $self = shift;
 157     return $self->{merge} unless @_;
 158     $self->{merge} = shift;
 159     return $self;
 160 }
 161
 162 sub switches {
 163     my $self = shift;
 164     return $self->{switches} unless @_;
 165     $self->{switches} = shift;
 166     return $self;
 167 }
 168
 169 sub test_args {
 170     my $self = shift;
 171     return $self->{test_args} unless @_;
 172     $self->{test_args} = shift;
 173     return $self;
 174 }
 175
 176 =head3 C<assemble_meta>
 177
 178   my $meta = $source->assemble_meta;
 179
 180 Gathers meta data about the L</raw> source, stashes it in L</meta> and returns
 181 it as a hashref.  This is done so that the L<TAP::Parser::SourceHandler>s don't
 182 have to repeat common checks.  Currently this includes:
 183
 184     is_scalar => $bool,
 185     is_hash   => $bool,
 186     is_array  => $bool,
 187
 188     # for scalars:
 189     length => $n
 190     has_newlines => $bool
 191
 192     # only done if the scalar looks like a filename
 193     is_file => $bool,
 194     is_dir  => $bool,
 195     is_symlink => $bool,
 196     file => {
 197         # only done if the scalar looks like a filename
 198         basename => $string, # including ext
 199         dir      => $string,
 200         ext      => $string,
 201         lc_ext   => $string,
 202         # system checks
 203         exists  => $bool,
 204         stat    => [ ... ], # perldoc -f stat
 205         empty   => $bool,
 206         size    => $n,
 207         text    => $bool,
 208         binary  => $bool,
 209         read    => $bool,
 210         write   => $bool,
 211         execute => $bool,
 212         setuid  => $bool,
 213         setgid  => $bool,
 214         sticky  => $bool,
 215         is_file => $bool,
 216         is_dir  => $bool,
 217         is_symlink => $bool,
 218         # only done if the file's a symlink
 219         lstat      => [ ... ], # perldoc -f lstat
 220         # only done if the file's a readable text file
 221         shebang => $first_line,
 222     }
 223
 224   # for arrays:
 225   size => $n,
 226
 227 =cut
 228
 229 sub assemble_meta {
 230     my ($self) = @_;
 231
 232     return $self->meta if $self->has_meta;
 233
 234     my $meta = $self->meta;
 235     my $raw  = $self->raw;
 236
 237     # rudimentary is object test - if it's blessed it'll
 238     # inherit from UNIVERSAL
 239     $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0;
 240
 241     if ( $meta->{is_object} ) {
 242         $meta->{class} = ref($raw);
 243     }
 244     else {
 245         my $ref = lc( ref($raw) );
 246         $meta->{"is_$ref"} = 1;
 247     }
 248
 249     if ( $meta->{is_scalar} ) {
 250         my $source = $$raw;
 251         $meta->{length} = length($$raw);
 252         $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0;
 253
 254         # only do file checks if it looks like a filename
 255         if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) {
 256             my $file = {};
 257             $file->{exists} = -e $source ? 1 : 0;
 258             if ( $file->{exists} ) {
 259                 $meta->{file} = $file;
 260
 261                 # avoid extra system calls (see `perldoc -f -X`)
 262                 $file->{stat}    = [ stat(_) ];
 263                 $file->{empty}   = -z _ ? 1 : 0;
 264                 $file->{size}    = -s _;
 265                 $file->{text}    = -T _ ? 1 : 0;
 266                 $file->{binary}  = -B _ ? 1 : 0;
 267                 $file->{read}    = -r _ ? 1 : 0;
 268                 $file->{write}   = -w _ ? 1 : 0;
 269                 $file->{execute} = -x _ ? 1 : 0;
 270                 $file->{setuid}  = -u _ ? 1 : 0;
 271                 $file->{setgid}  = -g _ ? 1 : 0;
 272                 $file->{sticky}  = -k _ ? 1 : 0;
 273
 274                 $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0;
 275                 $meta->{is_dir}  = $file->{is_dir}  = -d _ ? 1 : 0;
 276
 277                 # symlink check requires another system call
 278                 $meta->{is_symlink} = $file->{is_symlink}
 279                   = -l $source ? 1 : 0;
 280                 if ( $file->{is_symlink} ) {
 281                     $file->{lstat} = [ lstat(_) ];
 282                 }
 283
 284                 # put together some common info about the file
 285                 ( $file->{basename}, $file->{dir}, $file->{ext} )
 286                   = map { defined $_ ? $_ : '' }
 287                   fileparse( $source, qr/\.[^.]*/ );
 288                 $file->{lc_ext} = lc( $file->{ext} );
 289                 $file->{basename} .= $file->{ext} if $file->{ext};
 290
 291                 if ( !$file->{is_dir} && $file->{read} ) {
 292                     eval { $file->{shebang} = $self->shebang($$raw); };
 293                     if ( my $e = $@ ) {
 294                         warn $e;
 295                     }
 296                 }
 297             }
 298         }
 299     }
 300     elsif ( $meta->{is_array} ) {
 301         $meta->{size} = $#$raw + 1;
 302     }
 303     elsif ( $meta->{is_hash} ) {
 304         ;    # do nothing
 305     }
 306
 307     return $meta;
 308 }
 309
 310 =head3 C<shebang>
 311
 312 Get the shebang line for a script file.
 313
 314   my $shebang = TAP::Parser::Source->shebang( $some_script );
 315
 316 May be called as a class method
 317
 318 =cut
 319
 320 {
 321
 322     # Global shebang cache.
 323     my %shebang_for;
 324
 325     sub _read_shebang {
 326         my ( $class, $file ) = @_;
 327         open my $fh, '<', $file or die "Can't read $file: $!\n";
 328
 329         # Might be a binary file - so read a fixed number of bytes.
 330         my $got = read $fh, my ($buf), BLK_SIZE;
 331         defined $got or die "I/O error: $!\n";
 332         return $1 if $buf =~ /(.*)/;
 333         return;
 334     }
 335
 336     sub shebang {
 337         my ( $class, $file ) = @_;
 338         $shebang_for{$file} = $class->_read_shebang($file)
 339           unless exists $shebang_for{$file};
 340         return $shebang_for{$file};
 341     }
 342 }
 343
 344 =head3 C<config_for>
 345
 346   my $config = $source->config_for( $class );
 347
 348 Returns L</config> for the $class given.  Class names may be fully qualified
 349 or abbreviated, eg:
 350
 351   # these are equivalent
 352   $source->config_for( 'Perl' );
 353   $source->config_for( 'TAP::Parser::SourceHandler::Perl' );
 354
 355 If a fully qualified $class is given, its abbreviated version is checked first.
 356
 357 =cut
 358
 359 sub config_for {
 360     my ( $self, $class ) = @_;
 361     my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ );
 362     my $config = $self->config->{$abbrv_class} || $self->config->{$class};
 363     return $config;
 364 }
 365
 366 1;
 367
 368 __END__
 369
 370 =head1 AUTHORS
 371
 372 Steve Purkis.
 373
 374 =head1 SEE ALSO
 375
 376 L<TAP::Object>,
 377 L<TAP::Parser>,
 378 L<TAP::Parser::IteratorFactory>,
 379 L<TAP::Parser::SourceHandler>
 380
 381 =cut