[tapx-dev] [commit][242] adding initial version of TAP::Harness::Archive
michael at hexten.net
michael at hexten.net
Thu Aug 16 17:59:37 BST 2007
Revision: 242
Author: michael
Date: 2007-08-16 17:59:37 +0100 (Thu, 16 Aug 2007)
Log Message:
-----------
adding initial version of TAP::Harness::Archive
Added Paths:
-----------
TAP-Harness-Archive/trunk/Build.PL
TAP-Harness-Archive/trunk/Changes
TAP-Harness-Archive/trunk/MANIFEST
TAP-Harness-Archive/trunk/README
TAP-Harness-Archive/trunk/TODO
TAP-Harness-Archive/trunk/lib/
TAP-Harness-Archive/trunk/lib/TAP/
TAP-Harness-Archive/trunk/lib/TAP/Harness/
TAP-Harness-Archive/trunk/lib/TAP/Harness/Archive.pm
TAP-Harness-Archive/trunk/t/
TAP-Harness-Archive/trunk/t/archive.t
TAP-Harness-Archive/trunk/t/pod-coverage.t
TAP-Harness-Archive/trunk/t/pod.t
Added: TAP-Harness-Archive/trunk/Build.PL
===================================================================
--- TAP-Harness-Archive/trunk/Build.PL (rev 0)
+++ TAP-Harness-Archive/trunk/Build.PL 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+use Module::Build;
+use lib './t/lib';
+
+my $builder = Module::Build->new(
+ module_name => 'TAP::Harness::Archive',
+ license => 'perl',
+ dist_author => 'Michael Peters <mpeters at plusthree.com>',
+ dist_version_from => 'lib/TAP/Harness/Archive.pm',
+ requires => {
+ 'TAP::Harness' => 0.52,
+ 'Archive::Builder' => 1.12,
+ 'Test::More' => 0,
+ 'Cwd' => 0,
+ 'File::Basename' => 0,
+ 'File::Temp' => 0,
+ 'File::Spec' => 0,
+ 'File::Path' => 0,
+ 'File::Find' => 0,
+ 'YAML::Tiny' => 0,
+ },
+ recommends => {'Archive::Extract' => 0.22,},
+ create_makefile_pl => 'traditional',
+ create_readme => 1,
+);
+
+$builder->create_build_script()
Added: TAP-Harness-Archive/trunk/Changes
===================================================================
--- TAP-Harness-Archive/trunk/Changes (rev 0)
+++ TAP-Harness-Archive/trunk/Changes 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,5 @@
+Revision history for TAP-Harness-Archive
+
+0.01 Date/time
+ First version, released on an unsuspecting world.
+
Added: TAP-Harness-Archive/trunk/MANIFEST
===================================================================
--- TAP-Harness-Archive/trunk/MANIFEST (rev 0)
+++ TAP-Harness-Archive/trunk/MANIFEST 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,11 @@
+Build.PL
+Changes
+lib/TAP/Harness/Archive.pm
+MANIFEST
+META.yml # Will be created by "make dist"
+README
+t/00-runtests.t
+t/archive.t
+t/pod-coverage.t
+t/pod.t
+TODO
Added: TAP-Harness-Archive/trunk/README
===================================================================
--- TAP-Harness-Archive/trunk/README (rev 0)
+++ TAP-Harness-Archive/trunk/README 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,49 @@
+TAP-Harness-Archive
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the README
+file from a module distribution so that people browsing the archive
+can use it get an idea of the modules uses. It is usually a good idea
+to provide version information here so that people can decide whether
+fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the perldoc command.
+
+ perldoc TAP::Harness::Archive
+
+You can also look for information at:
+
+ Search CPAN
+ http://search.cpan.org/dist/TAP-Harness-Archive
+
+ CPAN Request Tracker:
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=TAP-Harness-Archive
+
+ AnnoCPAN, annotated CPAN documentation:
+ http://annocpan.org/dist/TAP-Harness-Archive
+
+ CPAN Ratings:
+ http://cpanratings.perl.org/d/TAP-Harness-Archive
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2007 Michael Peters
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
Added: TAP-Harness-Archive/trunk/TODO
===================================================================
--- TAP-Harness-Archive/trunk/TODO (rev 0)
+++ TAP-Harness-Archive/trunk/TODO 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,9 @@
+=head1 TODO
+
+=over
+
+=item * Add a aggregator_from_archive() method
+
+This will read a TAP archive, create and return a TAP::Parser::Aggregator object.
+
+=back
Added: TAP-Harness-Archive/trunk/lib/TAP/Harness/Archive.pm
===================================================================
--- TAP-Harness-Archive/trunk/lib/TAP/Harness/Archive.pm (rev 0)
+++ TAP-Harness-Archive/trunk/lib/TAP/Harness/Archive.pm 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,342 @@
+package TAP::Harness::Archive;
+
+use warnings;
+use strict;
+use base 'TAP::Harness';
+use Cwd ();
+use File::Basename ();
+use File::Temp ();
+use File::Spec ();
+use File::Path ();
+use File::Find ();
+use Archive::Builder;
+use TAP::Parser;
+use YAML::Tiny;
+
+=head1 NAME
+
+TAP::Harness::Archive - Create an archive of TAP test results
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+ use TAP::Harness::Archive;
+ my $harness = TAP::Harness::Archive->new(\%args);
+ $harness->runtests(@tests);
+
+=head1 DESCRIPTION
+
+This module is a direct subclass of L<TAP::Harness> and behaves
+in exactly the same way except for one detail. In addition to
+outputting a running progress of the tests and an ending summary
+it can also capture all of the raw TAP from the individual test
+files or streams into an archive file (C<.tar>, C<.tar.gz> or C<.zip>).
+
+=head1 METHODS
+
+All methods are exactly the same as our base L<TAP::Harness> except
+for the following.
+
+=head2 new
+
+In addition to the options that L<TAP::Harness> allow to this method,
+we also allow the following:
+
+=over
+
+=item archive
+
+This is the name of the archive file to generate. We use L<Archive::Builder>
+so any formats supported by L<Archive::Builder> are allowed.
+
+=back
+
+=cut
+
+my %ARCHIVE_TYPES = (
+ 'zip' => 'zip',
+ 'tar' => 'tar',
+ 'tar.gz' => 'tar.gz',
+ 'tgz' => 'tar.gz',
+);
+my @ARCHIVE_EXTENSIONS = map { ".$_" } keys %ARCHIVE_TYPES;
+
+sub new {
+ my ($class, $args) = @_;
+ $args ||= {};
+ my $archive = delete $args->{archive};
+ $class->_croak("You must provide the name of the archive to create!")
+ unless $archive;
+
+ my $format = $class->_get_archive_format_from_filename($archive);
+ $class->_croak("Archive is not a known format type!")
+ unless $format && $ARCHIVE_TYPES{$format};
+
+ my $self = $class->SUPER::new($args);
+ $self->{__archive_file} = $archive;
+ $self->{__archive_format} = $format;
+ $self->{__archive_tempdir} = File::Temp::tempdir();
+ return $self;
+}
+
+sub _get_archive_format_from_filename {
+ my ($self, $filename) = @_;
+
+ # try to guess it if we don't have one
+ my (undef, undef, $suffix) = File::Basename::fileparse($filename, @ARCHIVE_EXTENSIONS);
+ $suffix =~ s/^\.//;
+ return $ARCHIVE_TYPES{$suffix};
+}
+
+=head2 runtests
+
+Takes the same argument's as L<TAP::Harness>'s version and returns the
+same thing (a L<TAP::Parser::Aggregator> object). The only difference
+is that in addition to the normal test running and progress output
+we also create the TAP Archive when it's all done.
+
+=cut
+
+sub runtests {
+ my ($self, @files) = @_;
+
+ # tell TAP::Harness to put the raw tap someplace we can find it later
+ my $dir = $self->{__archive_tempdir};
+ $ENV{PERL_TEST_HARNESS_DUMP_TAP} = $dir;
+
+ # get some meta information about this run
+ my %meta = (
+ file_order => \@files,
+ start_time => time(),
+ );
+
+ my $aggregator = $self->SUPER::runtests(@files);
+
+ $meta{stop_time} = time();
+
+ # create the YAML meta file
+ my $yaml = YAML::Tiny->new();
+ $yaml->[0] = \%meta;
+ $yaml->write(File::Spec->catfile($dir, 'meta.yml'))
+ or $self->_croak("Could not write data to meta.yml: " . $yaml->errstr);
+
+ # go into the dir so that we can reference files
+ # relatively and put them in the archive that way
+ my $cwd = Cwd::getcwd();
+ chdir($dir) or $self->_croak("Could not change to directory $dir: $!");
+
+ my $output_file = $self->{__archive_file};
+ unless(File::Spec->file_name_is_absolute($output_file)) {
+ $output_file = File::Spec->catfile($cwd, $output_file);
+ }
+
+ # now create the archive
+ my $builder = Archive::Builder->new();
+ my $section = $builder->new_section('tap_archive') or die $builder->errstr;
+ foreach my $file ($self->_get_all_files) {
+ $section->new_file($file, 'file', $file) or die $section->errstr;
+ }
+ my $archive = $section->archive($self->{__archive_format}) or die $section->errstr;
+ $archive->save($output_file) or die $archive->errstr;
+
+ print "\nTAP Archive created at $output_file\n" unless $self->really_quiet;
+
+ # be nice and clean up
+ File::Path::rmtree($dir);
+ chdir($cwd) or $self->_croak("Could not return to directory $cwd: $!");
+
+ return $aggregator;
+}
+
+sub _get_all_files {
+ my ($self, $dir) = @_;
+ $dir ||= $self->{__archive_tempdir};
+ my @files;
+ File::Find::find(
+ {
+ no_chdir => 1,
+ wanted => sub {
+ return if /^\./;
+ return if -d;
+ push(@files, File::Spec->abs2rel($_, $dir));
+ },
+ },
+ $dir
+ );
+ return @files;
+}
+
+=head2 aggregator_from_archive
+
+This class method will return a L<TAP::Parser::Aggregator> object
+when given a TAP Archive to open and parse. It's pretty much the reverse
+of creating a TAP Archive from using C<new> and C<runtests>.
+
+It takes a hash of arguments which are as follows:
+
+=over
+
+=item archive
+
+The path to the archive file.
+This is required.
+
+=item parser_callbacks
+
+This is a hash ref containing callbacks for the L<TAP::Parser> objects
+that are created while parsing the TAP files. See the L<TAP::Parser>
+documentation for details about these callbacks.
+
+=item made_parser_callback
+
+This callback is executed every time a new L<TAP::Parser> object
+is created. It will be passed the new parser object and the name
+of the file to be parsed.
+
+=item meta_yaml_callback
+
+This is a subroutine that will be called if we find and parse a YAML
+file containing meta information about the test run in the archive.
+The structure of the YAML file will be passed in as an argument.
+
+=back
+
+ my $aggregator = TAP::Harness::Archive->aggregator_from_archive(
+ {
+ archive => 'my_tests.tar.gz',
+ parser_callbacks => {
+ plan => sub { warn "Nice to see you plan ahead..." },
+ unknown => sub { warn "Your TAP is bad!" },
+ },
+ }
+ );
+
+=cut
+
+sub aggregator_from_archive {
+ my ($class, $args) = @_;
+
+ eval { require Archive::Extract };
+ die
+ "Could not load Archive::Extract. It is required to use the aggregator_from_archive() method: $@"
+ if $@;
+
+ my $file = $args->{archive}
+ or $class->_croak("You must provide the path to the archive!");
+
+ # extract the files out into a temporary directory
+ my $dir = File::Temp::tempdir();
+ my $cwd = Cwd::getcwd();
+ chdir($dir) or $class->_croak("Could not change to directory $dir: $!");
+ my @files;
+
+ my $archive = Archive::Extract->new(archive => $file);
+ $archive->extract();
+ my @tap_files;
+
+ # do we have a .yml file in the archive?
+ my ($yaml_file) = glob('*.yml');
+ if($yaml_file) {
+
+ # parse it into a structure
+ my $meta = YAML::Tiny->new()->read($yaml_file);
+ die "Could not read YAML $yaml_file: " . YAML::Tiny->errstr if YAML::Tiny->errstr;
+
+ if($args->{meta_yaml_callback}) {
+ $args->{meta_yaml_callback}->($meta);
+ }
+ $meta = $meta->[0];
+
+ if($meta->{file_order} && ref $meta->{file_order} eq 'ARRAY') {
+ foreach my $file (@{$meta->{file_order}}) {
+ push(@tap_files, $file) if -e $file;
+ }
+ }
+ }
+
+ # if we didn't get the files from the YAML file, just find them all
+ unless(@tap_files) {
+ @tap_files = grep { $_ !~ /\.yml$/ } $class->_get_all_files($dir);
+ }
+
+ # now create the aggregator
+ my $aggregator = TAP::Parser::Aggregator->new();
+ foreach my $tap_file (@tap_files) {
+ open(my $fh, $tap_file) or die "Could not open $tap_file for reading: $!";
+ my $parser = TAP::Parser->new({source => $fh, callbacks => $args->{parser_callbacks}});
+ if($args->{made_parser_callback}) {
+ $args->{made_parser_callback}->($parser, $tap_file);
+ }
+ $parser->run;
+ $aggregator->add($tap_file, $parser);
+ }
+
+ # be nice and clean up
+ File::Path::rmtree($dir);
+ chdir($cwd) or $class->_croak("Could not return to directory $cwd: $!");
+
+ return $aggregator;
+}
+
+=head1 AUTHOR
+
+Michael Peters, C<< <mpeters at plusthree.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-tap-harness-archive at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Harness-Archive>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc TAP::Harness::Archive
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/TAP-Harness-Archive>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/TAP-Harness-Archive>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=TAP-Harness-Archive>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/TAP-Harness-Archive>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+A big thanks to Plus Three, LP (L<http://www.plusthree.com>) for
+sponsoring my work on this module and other open source pursuits.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Michael Peters, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of TAP::Harness::Archive
Added: TAP-Harness-Archive/trunk/t/archive.t
===================================================================
--- TAP-Harness-Archive/trunk/t/archive.t (rev 0)
+++ TAP-Harness-Archive/trunk/t/archive.t 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,77 @@
+#!perl
+use Test::More;
+use File::Temp ();
+use File::Spec::Functions qw(catfile catdir);
+plan(tests => 35);
+
+BEGIN {
+ use_ok('TAP::Harness::Archive');
+}
+
+# do we have Archive::Extract installed?
+eval { require Archive::Extract };
+my $HAVE_ARCHIVE_EXTRACT = $@ ? 0 : 1;
+
+# test creation
+eval { TAP::Harness::Archive->new() };
+like($@, qr/You must provide the name of the archive to create!/);
+eval { TAP::Harness::Archive->new({archive => 'foo.bar'}) };
+like($@, qr/Archive is not a known format type!/);
+
+# a temp directory to put everything in
+my $temp_dir = File::Temp->tempdir('tap-archive-XXXXXXXX', CLEANUP => 0);
+my @testfiles = (catfile('t', 'pod.t'), catfile('t', 'pod-coverage.t'));
+
+# first a .zip file
+my $file = catfile($temp_dir, 'archive.zip');
+my $harness = TAP::Harness::Archive->new({archive => $file});
+$harness->runtests(@testfiles);
+ok(-e $file, 'archive.zip created');
+check_archive($file);
+
+# now a .tar file
+$file = catfile($temp_dir, 'archive.tar');
+$harness = TAP::Harness::Archive->new({archive => $file});
+$harness->runtests(@testfiles);
+ok(-e $file, 'archive.tar created');
+check_archive($file);
+
+# now a .tar.gz
+$file = catfile($temp_dir, 'archive.tar.gz');
+$harness = TAP::Harness::Archive->new({archive => $file});
+$harness->runtests(@testfiles);
+ok(-e $file, 'archive.tar.gz created');
+check_archive($file);
+
+sub check_archive {
+ SKIP: {
+ skip("Don't have Archive::Extract installed", 9) unless $HAVE_ARCHIVE_EXTRACT;
+ my $archive_file = shift;
+ my %tap_files;
+ my $aggregator = TAP::Harness::Archive->aggregator_from_archive(
+ {
+ archive => $archive_file,
+ made_parser_callback => sub {
+ my ($parser, $filename) = @_;
+ isa_ok($parser, 'TAP::Parser');
+ $tap_files{$filename} = 1;
+ },
+ meta_yaml_callback => sub {
+ my $yaml = shift;
+ $yaml = $yaml->[0];
+ ok(exists $yaml->{start_time}, 'meta.yml: start_time exists');
+ ok(exists $yaml->{stop_time}, 'meta.yml: stop_time exists');
+ ok(exists $yaml->{file_order}, 'meta.yml: file_order exists');
+ },
+ }
+ );
+
+ isa_ok($aggregator, 'TAP::Parser::Aggregator');
+ cmp_ok($aggregator->total, '==', 2, "aggregator has correct total");
+ cmp_ok(scalar keys %tap_files, '==', 2, "correct number of files in archive $archive_file");
+ foreach my $f (@testfiles) {
+ ok($tap_files{$f}, "file $f in archive $archive_file");
+ }
+ }
+}
+
Added: TAP-Harness-Archive/trunk/t/pod-coverage.t
===================================================================
--- TAP-Harness-Archive/trunk/t/pod-coverage.t (rev 0)
+++ TAP-Harness-Archive/trunk/t/pod-coverage.t 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
Added: TAP-Harness-Archive/trunk/t/pod.t
===================================================================
--- TAP-Harness-Archive/trunk/t/pod.t (rev 0)
+++ TAP-Harness-Archive/trunk/t/pod.t 2007-08-16 16:59:37 UTC (rev 242)
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
More information about the tapx-dev
mailing list