Update Test-Harness to CPAN version 3.39
[perl.git] / 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.39
18
19 =cut
20
21 our $VERSION = '3.39';
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