File Coverage

blib/lib/TAP/Harness/Archive.pm
Criterion Covered Total %
statement 162 171 94.7
branch 56 86 65.1
condition 7 14 50.0
subroutine 20 20 100.0
pod 3 3 100.0
total 248 294 84.3


line stmt bran cond sub pod time code
1             package TAP::Harness::Archive;
2 3     3   153775 use warnings;
  3         7  
  3         97  
3 3     3   14 use strict;
  3         4  
  3         63  
4 3     3   15 use base 'TAP::Harness';
  3         7  
  3         2775  
5 3     3   28263 use Cwd ();
  3         6  
  3         47  
6 3     3   16 use File::Basename ();
  3         4  
  3         43  
7 3     3   15 use File::Temp ();
  3         5  
  3         40  
8 3     3   13 use File::Spec ();
  3         5  
  3         44  
9 3     3   14 use File::Path ();
  3         6  
  3         42  
10 3     3   12 use File::Find ();
  3         4  
  3         40  
11 3     3   1099564 use Archive::Tar ();
  3         2046366  
  3         91  
12 3     3   3322 use TAP::Parser ();
  3         155809  
  3         73  
13 3     3   2976 use YAML::Tiny ();
  3         17453  
  3         83  
14 3     3   2598 use TAP::Parser::Aggregator ();
  3         20661  
  3         273  
15              
16             =head1 NAME
17              
18             TAP::Harness::Archive - Create an archive of TAP test results
19              
20             =cut
21              
22             our $VERSION = '0.18';
23              
24             =head1 SYNOPSIS
25              
26             use TAP::Harness::Archive;
27             my $harness = TAP::Harness::Archive->new(\%args);
28             $harness->runtests(@tests);
29              
30             =head1 DESCRIPTION
31              
32             This module is a direct subclass of L and behaves
33             in exactly the same way except for one detail. In addition to
34             outputting a running progress of the tests and an ending summary
35             it can also capture all of the raw TAP from the individual test
36             files or streams into an archive file (C<.tar> or C<.tar.gz>).
37              
38             =head1 METHODS
39              
40             All methods are exactly the same as our base L except
41             for the following.
42              
43             =head2 new
44              
45             In addition to the options that L allow to this method,
46             we also allow the following:
47              
48             =over
49              
50             =item archive
51              
52             This is the name of the archive file to generate. We use L
53             in the background so we only support C<.tar> and C<.tar.gz> archive file
54             formats. This can optionally be an existing directory that will have
55             the TAP archive's contents deposited therein without any file archiving
56             (no L involved).
57              
58             =item extra_files
59              
60             This is an array reference to extra files that you want to include in the TAP
61             archive but which are not TAP files themselves. This is useful if you want to
62             include some log files that contain useful information about the test run.
63              
64             =item extra_properties
65              
66             This is a hash reference of extra properties that you've collected during your
67             test run. Some things you might want to include are the Perl version, the system's
68             architecture, the operating system, etc.
69              
70             =back
71              
72             =cut
73              
74             my (%ARCHIVE_TYPES, @ARCHIVE_EXTENSIONS);
75             BEGIN {
76 3     3   26 %ARCHIVE_TYPES = (
77             'tar' => 'tar',
78             'tar.gz' => 'tar.gz',
79             'tgz' => 'tar.gz',
80             );
81 3         10 @ARCHIVE_EXTENSIONS = map { ".$_" } keys %ARCHIVE_TYPES;
  9         5243  
82             }
83              
84             sub new {
85 7     7 1 19864 my ($class, $args) = @_;
86 7   100     40 $args ||= {};
87              
88             # these can't be passed on to Test::Harness
89 7         21 my $archive = delete $args->{archive};
90 7         26 my $extra_files = delete $args->{extra_files};
91 7         16 my $extra_props = delete $args->{extra_properties};
92              
93 7 100       38 $class->_croak("You must provide the name of the archive to create!")
94             unless $archive;
95              
96 6         70 my $self = $class->SUPER::new($args);
97              
98 6 100       74628 my $is_directory = -d $archive ? 1 : 0;
99 6 100       58 if ($is_directory) {
100 1         8 $self->{__archive_is_directory} = $is_directory;
101 1         6 $self->{__archive_tempdir} = $archive;
102             } else {
103 5         47 my $format = $class->_get_archive_format_from_filename($archive);
104              
105             # if it's not a format we understand, or it's not a directory
106             $class->_croak("Archive is not a known format type!")
107 5 100 66     61 unless $format && $ARCHIVE_TYPES{$format};
108              
109 4         16 $self->{__archive_file} = $archive;
110 4         10 $self->{__archive_format} = $format;
111 4         26 $self->{__archive_tempdir} = File::Temp::tempdir();
112             }
113              
114             # handle any extra files
115 5 100       1731 if($extra_files) {
116 1 50       5 ref $extra_files eq 'ARRAY'
117             or $class->_croak("extra_files must be an array reference!");
118 1         3 foreach my $file (@$extra_files) {
119 3 50       41 $class->_croak("extra_file $file does not exist!") unless -e $file;
120 3 50       37 $class->_croak("extra_file $file is not readable!") unless -r $file;
121             }
122 1         2 $self->{__archive_extra_files} = $extra_files;
123             }
124              
125 5 100       20 if($extra_props) {
126 1 50       4 ref $extra_props eq 'HASH'
127             or $class->_croak("extra_properties must be a hash reference!");
128 1         3 $self->{__archive_extra_props} = $extra_props;
129             }
130              
131 5         23 return $self;
132             }
133              
134             sub _get_archive_format_from_filename {
135 5     5   19 my ($self, $filename) = @_;
136              
137             # try to guess it if we don't have one
138 5         447 my (undef, undef, $suffix) = File::Basename::fileparse($filename, @ARCHIVE_EXTENSIONS);
139 5         23 $suffix =~ s/^\.//;
140 5         63 return $ARCHIVE_TYPES{$suffix};
141             }
142              
143             =head2 runtests
144              
145             Takes the same arguments as L's version and returns the
146             same thing (a L object). The only difference
147             is that in addition to the normal test running and progress output
148             we also create the TAP Archive when it's all done.
149              
150             =cut
151              
152             sub runtests {
153 5     5 1 67 my ($self, @files) = @_;
154              
155             # tell TAP::Harness to put the raw tap someplace we can find it later
156 5         20 my $dir = $self->{__archive_tempdir};
157 5         45 $ENV{PERL_TEST_HARNESS_DUMP_TAP} = $dir;
158              
159             # get some meta information about this run
160 5         54 my %meta = (
161             file_order => \@files,
162             start_time => time(),
163             );
164              
165 5         75 my $aggregator = $self->SUPER::runtests(@files);
166              
167 5         509820 $meta{stop_time} = time();
168              
169 5         48 my @parsers = $aggregator->parsers;
170 5         124 for ( my $i = 0; $i < @parsers; $i++ ) {
171 10         179 $parsers[ $i ] = {
172             start_time => $parsers[ $i ]->start_time,
173             end_time => $parsers[ $i ]->end_time,
174             description => $files[ $i ],
175             };
176             }
177 5         97 $meta{file_attributes} = \@parsers;
178              
179 5         72 my $cwd = Cwd::getcwd();
180 5         20 my $is_dir = $self->{__archive_is_directory};
181 5         16 my ($archive, $output_file);
182 5 100       34 if( $is_dir ) {
183 1         9 $output_file = $self->{__archive_tempdir};
184             } else {
185 4         20 $output_file = $self->{__archive_file};
186              
187             # go into the dir so that we can reference files
188             # relatively and put them in the archive that way
189 4 50       164 chdir($dir) or $self->_croak("Could not change to directory $dir: $!");
190              
191 4 50       186 unless (File::Spec->file_name_is_absolute($output_file)) {
192 0         0 $output_file = File::Spec->catfile($cwd, $output_file);
193             }
194              
195             # create the archive
196 4         101 $archive = Archive::Tar->new();
197 4         132 $archive->add_files($self->_get_all_tap_files);
198 4 50       4566 chdir($cwd) or $self->_croak("Could not return to directory $cwd: $!");
199             }
200            
201             # add in any extra files
202 5 100       39 if(my $x_files = $self->{__archive_extra_files}) {
203 1         2 my @rel_x_files;
204 1         8 foreach my $x_file (@$x_files) {
205             # handle both relative and absolute file names
206 3         7 my $rel_file;
207 3 50       26 if( File::Spec->file_name_is_absolute($x_file) ) {
208 0         0 $rel_file = File::Spec->abs2rel($x_file, $cwd);
209             } else {
210 3         6 $rel_file = $x_file;
211             }
212 3         12 push(@rel_x_files, $rel_file);
213             }
214 1 50       19 $archive->add_files(@rel_x_files) unless $is_dir;
215 1         1050 $meta{extra_files} = \@rel_x_files;
216             }
217              
218             # add any extra_properties to the meta
219 5 100       39 if(my $extra_props = $self->{__archive_extra_props}) {
220 1         5 $meta{extra_properties} = $extra_props;
221             }
222              
223             # create the YAML meta file
224 5         107 my $yaml = YAML::Tiny->new();
225 5         59 $yaml->[0] = \%meta;
226 5 100       29 if( $is_dir ) {
227 1         71 my $meta_file = File::Spec->catfile($output_file, 'meta.yml');
228 1 50       296 open(my $out, '>', $meta_file) or die "Could not create meta.yml: $!";
229 1         11 print $out $yaml->write_string;
230 1         1141 close($out);
231             } else {
232 4         47 $archive->add_data('meta.yml', $yaml->write_string);
233 4 50       4689 $archive->write($output_file, $self->{__archive_format} eq 'tar.gz') or die $archive->error;
234             # be nice and clean up
235 4         26388 File::Path::rmtree($dir);
236             }
237              
238 5 50       75 print "\nTAP Archive created at $output_file\n" unless $self->verbosity < -1;
239              
240 5         620 return $aggregator;
241             }
242              
243             sub _get_all_tap_files {
244 4     4   13 my ($self, $dir, $meta) = @_;
245 4   33     59 $dir ||= $self->{__archive_tempdir};
246 4         9 my @files;
247             my %x_files;
248 4 0 33     25 if($meta && $meta->{extra_files}) {
249 0         0 %x_files = map { $_ => 1 } @{$meta->{extra_files}};
  0         0  
  0         0  
250             }
251              
252             File::Find::find(
253             {
254             no_chdir => 1,
255             wanted => sub {
256 16 50   16   82 return if /^\./;
257 16 100       1375 return if -d;
258 8         936 my $rel_name = File::Spec->abs2rel($_, $dir);
259 8 50       44 return if $rel_name eq 'meta.yml';
260 8 50       140 push(@files, $rel_name) unless $x_files{$rel_name};
261             },
262             },
263 4         759 $dir
264             );
265 4         80 return @files;
266             }
267              
268             =head2 aggregator_from_archive
269              
270             This class method will return a L object
271             when given a TAP Archive to open and parse. It's pretty much the reverse
272             of creating a TAP Archive from using C and C.
273              
274             It takes a hash of arguments which are as follows:
275              
276             =over
277              
278             =item archive
279              
280             The path to the archive file. This can also be a directory if you created
281             the archive as a directory. This is required.
282              
283             =item parser_callbacks
284              
285             This is a hash ref containing callbacks for the L objects
286             that are created while parsing the TAP files. See the L
287             documentation for details about these callbacks.
288              
289             =item made_parser_callback
290              
291             This callback is executed every time a new L object
292             is created. It will be passed the new parser object, the name
293             of the file to be parsed, and also the full (temporary) path of that file.
294              
295             =item meta_yaml_callback
296              
297             This is a subroutine that will be called if we find and parse a YAML
298             file containing meta information about the test run in the archive.
299             The structure of the YAML file will be passed in as an argument.
300              
301             =back
302              
303             my $aggregator = TAP::Harness::Archive->aggregator_from_archive(
304             {
305             archive => 'my_tests.tar.gz',
306             parser_callbacks => {
307             plan => sub { warn "Nice to see you plan ahead..." },
308             unknown => sub { warn "Your TAP is bad!" },
309             },
310             made_parser_callback => sub {
311             my ($parser, $file, $full_path) = @_;
312             warn "$file is temporarily located at $full_path\n";
313             }
314            
315             }
316             );
317              
318             =cut
319              
320             sub aggregator_from_archive {
321 5     5 1 4455 my ($class, $args) = @_;
322 5         17 my $meta;
323              
324             my $file = Cwd::abs_path( $args->{archive} )
325 5 50       281 or $class->_croak("You must provide the path to the archive!");
326              
327 5         171 my $is_directory = -d $file;
328              
329             # extract the files out into a temporary directory
330 5 100       71 my $dir = $is_directory ? $file : File::Temp::tempdir();
331 5         1791 my $cwd = Cwd::getcwd();
332 5 50       80 chdir($dir) or $class->_croak("Could not change to directory $dir: $!");
333 5         13 my @files;
334              
335 5 100       47 Archive::Tar->new()->extract_archive($file) unless $is_directory;
336 5         124398 my @tap_files;
337              
338             # do we have a meta.yml file in the archive?
339 5         118 my $yaml_file = File::Spec->catfile($dir, 'meta.yml');
340 5 50       177 if( -e $yaml_file) {
341              
342             # parse it into a structure
343 5 50       125 if ($YAML::Tiny::VERSION < 1.57) {
344 0         0 $meta = YAML::Tiny->new()->read($yaml_file);
345 0 0       0 die "Could not read YAML $yaml_file: " . YAML::Tiny->errstr if YAML::Tiny->errstr;
346             } else {
347 5         28 $meta = eval {
348 5         102 YAML::Tiny->new()->read($yaml_file);
349             };
350 5 50       238330 if ($@) {
351 0         0 die "Could not read YAML $yaml_file: ".$@;
352             }
353             }
354              
355 5 50       35 if($args->{meta_yaml_callback}) {
356 5         33 $args->{meta_yaml_callback}->($meta);
357             }
358 5         10118 $meta = $meta->[0];
359              
360 5 50 33     129 if($meta->{file_order} && ref $meta->{file_order} eq 'ARRAY') {
361 5         11 foreach my $file (@{$meta->{file_order}}) {
  5         33  
362 10 50       183 push(@tap_files, $file) if -e $file;
363             }
364             }
365             }
366              
367             # if we didn't get the files from the YAML file, just find them all
368 5 50       34 unless(@tap_files) {
369 0         0 @tap_files = $class->_get_all_tap_files($dir, $meta);
370             }
371              
372             # now create the aggregator
373 5         108 my $aggregator = TAP::Parser::Aggregator->new();
374 5         490 foreach my $tap_file (@tap_files) {
375 10 50       1242 open(my $fh, $tap_file) or die "Could not open $tap_file for reading: $!";
376 10         127 my $parser = TAP::Parser->new({source => $fh, callbacks => $args->{parser_callbacks}});
377 10 100       6380 if($args->{made_parser_callback}) {
378 6         129 $args->{made_parser_callback}->($parser, $tap_file, File::Spec->catfile($dir, $tap_file));
379             }
380 10         11728 $parser->run;
381 10         16018 $aggregator->add($tap_file, $parser);
382             }
383              
384             # be nice and clean up
385 5 50       897 chdir($cwd) or $class->_croak("Could not return to directory $cwd: $!");
386 5 100       4879 File::Path::rmtree($dir) unless $is_directory;
387              
388 5         101 return $aggregator;
389             }
390              
391             =head1 AUTHOR
392              
393             Michael Peters, C<< >>
394              
395             =head1 BUGS
396              
397             Please report any bugs or feature requests to
398             C, or through the web interface at
399             L.
400             I will be notified, and then you'll automatically be notified of progress on
401             your bug as I make changes.
402              
403             =head1 SUPPORT
404              
405             You can find documentation for this module with the perldoc command.
406              
407             perldoc TAP::Harness::Archive
408              
409             You can also look for information at:
410              
411             =over 4
412              
413             =item * AnnoCPAN: Annotated CPAN documentation
414              
415             L
416              
417             =item * CPAN Ratings
418              
419             L
420              
421             =item * RT: CPAN's request tracker
422              
423             L
424              
425             =item * Search CPAN
426              
427             L
428              
429             =back
430              
431             =head1 ACKNOWLEDGEMENTS
432              
433             =over
434              
435             =item * A big thanks to Plus Three, LP (L) for sponsoring my work on this module and other open source pursuits.
436              
437             =item * Andy Armstrong
438              
439             =back
440              
441             =head1 COPYRIGHT & LICENSE
442              
443             Copyright 2007 Michael Peters, all rights reserved.
444              
445             This program is free software; you can redistribute it and/or modify it
446             under the same terms as Perl itself.
447              
448             =cut
449              
450             1; # End of TAP::Harness::Archive