File Coverage

blib/lib/TAP/Parser/Source.pm
Criterion Covered Total %
statement 101 103 98.0
branch 62 76 81.5
condition 6 9 66.6
subroutine 17 17 100.0
pod 10 10 100.0
total 196 215 91.1


line stmt bran cond sub pod time code
1             package TAP::Parser::Source;
2              
3 39     39   42984 use strict;
  39         43  
  39         939  
4 39     39   154 use warnings;
  39         37  
  39         1019  
5              
6 39     39   146 use File::Basename qw( fileparse );
  39         34  
  39         2797  
7 39     39   576 use base 'TAP::Object';
  39         54  
  39         3312  
8              
9 39     39   159 use constant BLK_SIZE => 512;
  39         45  
  39         38228  
10              
11             =head1 NAME
12              
13             TAP::Parser::Source - a TAP source & meta data about it
14              
15             =head1 VERSION
16              
17             Version 3.38
18              
19             =cut
20              
21             our $VERSION = '3.38';
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 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. Cs encapsulate these I sources, and
42             provide some useful meta data about them. They are used by
43             Ls, which do whatever is required to produce &
44             capture a stream of TAP from the I source, and package it up in a
45             L for the parser to consume.
46              
47             Unless you're writing a new L, a plugin or
48             subclassing L, you probably won't need to use this module directly.
49              
50             =head1 METHODS
51              
52             =head2 Class Methods
53              
54             =head3 C
55              
56             my $source = TAP::Parser::Source->new;
57              
58             Returns a new C object.
59              
60             =cut
61              
62             # new() implementation supplied by TAP::Object
63              
64             sub _initialize {
65 359     359   567 my ($self) = @_;
66 359         1159 $self->meta( {} );
67 359         1033 $self->config( {} );
68 359         774 return $self;
69             }
70              
71             ##############################################################################
72              
73             =head2 Instance Methods
74              
75             =head3 C
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
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 for more info.
90              
91             =head3 C
92              
93             True if the source has meta data.
94              
95             =head3 C
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 for more info.
103              
104             =head3 C
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
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
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 2378     2378 1 3777 my $self = shift;
132 2378 100       9913 return $self->{raw} unless @_;
133 330         590 $self->{raw} = shift;
134 330         547 return $self;
135             }
136              
137             sub meta {
138 3391     3391 1 3273 my $self = shift;
139 3391 100       9209 return $self->{meta} unless @_;
140 372         892 $self->{meta} = shift;
141 372         446 return $self;
142             }
143              
144             sub has_meta {
145 326 50   326 1 357 return scalar %{ shift->meta } ? 1 : 0;
  326         578  
146             }
147              
148             sub config {
149 1306     1306 1 1649 my $self = shift;
150 1306 100       4085 return $self->{config} unless @_;
151 665         873 $self->{config} = shift;
152 665         1403 return $self;
153             }
154              
155             sub merge {
156 517     517 1 590 my $self = shift;
157 517 100       3251 return $self->{merge} unless @_;
158 292         570 $self->{merge} = shift;
159 292         845 return $self;
160             }
161              
162             sub switches {
163 504     504 1 715 my $self = shift;
164 504 100       1860 return $self->{switches} unless @_;
165 292         479 $self->{switches} = shift;
166 292         836 return $self;
167             }
168              
169             sub test_args {
170 518     518 1 564 my $self = shift;
171 518 100       3088 return $self->{test_args} unless @_;
172 293         586 $self->{test_args} = shift;
173 293         502 return $self;
174             }
175              
176             =head3 C
177              
178             my $meta = $source->assemble_meta;
179              
180             Gathers meta data about the L source, stashes it in L and returns
181             it as a hashref. This is done so that the Ls 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 326     326 1 506 my ($self) = @_;
231              
232 326 50       849 return $self->meta if $self->has_meta;
233              
234 326         574 my $meta = $self->meta;
235 326         561 my $raw = $self->raw;
236              
237             # rudimentary is object test - if it's blessed it'll
238             # inherit from UNIVERSAL
239 326 100       1422 $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0;
240              
241 326 100       671 if ( $meta->{is_object} ) {
242 4         12 $meta->{class} = ref($raw);
243             }
244             else {
245 322         988 my $ref = lc( ref($raw) );
246 322         922 $meta->{"is_$ref"} = 1;
247             }
248              
249 326 100       844 if ( $meta->{is_scalar} ) {
    100          
    100          
250 296         536 my $source = $$raw;
251 296         776 $meta->{length} = length($$raw);
252 296 100       1320 $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0;
253              
254             # only do file checks if it looks like a filename
255 296 100 66     1569 if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) {
256 230         402 my $file = {};
257 230 100       6186 $file->{exists} = -e $source ? 1 : 0;
258 230 100       610 if ( $file->{exists} ) {
259 226         415 $meta->{file} = $file;
260              
261             # avoid extra system calls (see `perldoc -f -X`)
262 226         1154 $file->{stat} = [ stat(_) ];
263 226 50       784 $file->{empty} = -z _ ? 1 : 0;
264 226         485 $file->{size} = -s _;
265 226 100       24848 $file->{text} = -T _ ? 1 : 0;
266 226 100       5289 $file->{binary} = -B _ ? 1 : 0;
267 226 50       966 $file->{read} = -r _ ? 1 : 0;
268 226 50       1076 $file->{write} = -w _ ? 1 : 0;
269 226 100       640 $file->{execute} = -x _ ? 1 : 0;
270 226 50       667 $file->{setuid} = -u _ ? 1 : 0;
271 226 50       576 $file->{setgid} = -g _ ? 1 : 0;
272 226 50       577 $file->{sticky} = -k _ ? 1 : 0;
273              
274 226 100       646 $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0;
275 226 100       648 $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 226 100       2469 = -l $source ? 1 : 0;
280 226 100       641 if ( $file->{is_symlink} ) {
281 1         4 $file->{lstat} = [ lstat(_) ];
282             }
283              
284             # put together some common info about the file
285             ( $file->{basename}, $file->{dir}, $file->{ext} )
286 226 50       11338 = map { defined $_ ? $_ : '' }
  678         2256  
287             fileparse( $source, qr/\.[^.]*/ );
288 226         968 $file->{lc_ext} = lc( $file->{ext} );
289 226 100       669 $file->{basename} .= $file->{ext} if $file->{ext};
290              
291 226 50 66     1614 if ( !$file->{is_dir} && $file->{read} ) {
292 225         388 eval { $file->{shebang} = $self->shebang($$raw); };
  225         970  
293 225 50       972 if ( my $e = $@ ) {
294 0         0 warn $e;
295             }
296             }
297             }
298             }
299             }
300             elsif ( $meta->{is_array} ) {
301 7         19 $meta->{size} = $#$raw + 1;
302             }
303             elsif ( $meta->{is_hash} ) {
304             ; # do nothing
305             }
306              
307 326         828 return $meta;
308             }
309              
310             =head3 C
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 115     115   194 my ( $class, $file ) = @_;
327 115 50       3910 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 115         1183 my $got = read $fh, my ($buf), BLK_SIZE;
331 115 50       382 defined $got or die "I/O error: $!\n";
332 115 50       2084 return $1 if $buf =~ /(.*)/;
333 0         0 return;
334             }
335              
336             sub shebang {
337 225     225 1 384 my ( $class, $file ) = @_;
338             $shebang_for{$file} = $class->_read_shebang($file)
339 225 100       937 unless exists $shebang_for{$file};
340 225         758 return $shebang_for{$file};
341             }
342             }
343              
344             =head3 C
345              
346             my $config = $source->config_for( $class );
347              
348             Returns L 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 324     324 1 460 my ( $self, $class ) = @_;
361 324         4656 my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ );
362 324   66     671 my $config = $self->config->{$abbrv_class} || $self->config->{$class};
363 324         734 return $config;
364             }
365              
366             1;
367              
368             __END__