1package TAP::Parser::Source;
2
3use strict;
4use warnings;
5
6use File::Basename qw( fileparse );
7use base 'TAP::Object';
8
9use constant BLK_SIZE => 512;
10
11=head1 NAME
12
13TAP::Parser::Source - a TAP source & meta data about it
14
15=head1 VERSION
16
17Version 3.48
18
19=cut
20
21our $VERSION = '3.48';
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
39A TAP I<source> is something that produces a stream of TAP for the parser to
40consume, such as an executable file, a text file, an archive, an IO handle, a
41database, etc.  C<TAP::Parser::Source>s encapsulate these I<raw> sources, and
42provide some useful meta data about them.  They are used by
43L<TAP::Parser::SourceHandler>s, which do whatever is required to produce &
44capture a stream of TAP from the I<raw> source, and package it up in a
45L<TAP::Parser::Iterator> for the parser to consume.
46
47Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or
48subclassing 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
58Returns a new C<TAP::Parser::Source> object.
59
60=cut
61
62# new() implementation supplied by TAP::Object
63
64sub _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
80Chaining getter/setter for the raw TAP source.  This is a reference, as it may
81contain large amounts of data (eg: raw TAP).
82
83=head3 C<meta>
84
85  my $meta = $source->meta;
86  $source->meta({ %some_value });
87
88Chaining getter/setter for meta data about the source.  This defaults to an
89empty hashref.  See L</assemble_meta> for more info.
90
91=head3 C<has_meta>
92
93True if the source has meta data.
94
95=head3 C<config>
96
97  my $config = $source->config;
98  $source->config({ %some_value });
99
100Chaining getter/setter for the source's configuration, if any has been provided
101by the user.  How it's used is up to you.  This defaults to an empty hashref.
102See L</config_for> for more info.
103
104=head3 C<merge>
105
106  my $merge = $source->merge;
107  $source->config( $bool );
108
109Chaining getter/setter for the flag that dictates whether STDOUT and STDERR
110should be merged (where appropriate).  Defaults to undef.
111
112=head3 C<switches>
113
114  my $switches = $source->switches;
115  $source->config([ @switches ]);
116
117Chaining getter/setter for the list of command-line switches that should be
118passed 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
125Chaining getter/setter for the list of command-line arguments that should be
126passed to the source (where appropriate).  Defaults to undef.
127
128=cut
129
130sub raw {
131    my $self = shift;
132    return $self->{raw} unless @_;
133    $self->{raw} = shift;
134    return $self;
135}
136
137sub meta {
138    my $self = shift;
139    return $self->{meta} unless @_;
140    $self->{meta} = shift;
141    return $self;
142}
143
144sub has_meta {
145    return scalar %{ shift->meta } ? 1 : 0;
146}
147
148sub config {
149    my $self = shift;
150    return $self->{config} unless @_;
151    $self->{config} = shift;
152    return $self;
153}
154
155sub merge {
156    my $self = shift;
157    return $self->{merge} unless @_;
158    $self->{merge} = shift;
159    return $self;
160}
161
162sub switches {
163    my $self = shift;
164    return $self->{switches} unless @_;
165    $self->{switches} = shift;
166    return $self;
167}
168
169sub 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
180Gathers meta data about the L</raw> source, stashes it in L</meta> and returns
181it as a hashref.  This is done so that the L<TAP::Parser::SourceHandler>s don't
182have 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
229sub 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
312Get the shebang line for a script file.
313
314  my $shebang = TAP::Parser::Source->shebang( $some_script );
315
316May 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
348Returns L</config> for the $class given.  Class names may be fully qualified
349or abbreviated, eg:
350
351  # these are equivalent
352  $source->config_for( 'Perl' );
353  $source->config_for( 'TAP::Parser::SourceHandler::Perl' );
354
355If a fully qualified $class is given, its abbreviated version is checked first.
356
357=cut
358
359sub 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
3661;
367
368__END__
369
370=head1 AUTHORS
371
372Steve Purkis.
373
374=head1 SEE ALSO
375
376L<TAP::Object>,
377L<TAP::Parser>,
378L<TAP::Parser::IteratorFactory>,
379L<TAP::Parser::SourceHandler>
380
381=cut
382