use warnings;
use strict;
=head1 NAME
TAP::Harness::JUnit - Generate JUnit compatible output from TAP results
=head1 SYNOPSIS
use TAP::Harness::JUnit;
my $harness = TAP::Harness::JUnit->new({
xmlfile => 'output.xml',
...
});
$harness->runtests(@tests);
=head1 DESCRIPTION
The only difference between this module and I<TAP::Harness> is that
this adds mandatory 'xmlfile' argument, that causes the output to
be formatted into XML in format similar to one that is produced by
JUnit testing framework.
=head1 METHODS
This modules inherits all functions from I<TAP::Harness>.
=cut
package TAP::Harness::JUnit;
use base 'TAP::Harness';
use File::Temp;
use TAP::Parser;
use XML::Simple;
use Scalar::Util qw/blessed/;
our $VERSION = '0.23';
=head2 new
These options are added (compared to I<TAP::Harness>):
=over
=item xmlfile
Name of the file XML output will be saved to.
=back
=cut
sub new {
my ($class, $args) = @_;
$args ||= {};
# Process arguments
my $xmlfile = $args->{xmlfile} or
$class->_croak("'xmlfile' argument is mandatory");
defined $args->{merge} or
warn 'You should consider using "merge" parameter. See BUGS section of TAP::Harness::JUnit manual';
# Get the name of raw perl dump directory
my $rawtapdir = $ENV{PERL_TEST_HARNESS_DUMP_TAP};
$rawtapdir = $args->{rawtapdir} unless $rawtapdir;
$rawtapdir = File::Temp::tempdir() unless $rawtapdir;
# Don't pass these to TAP::Harness
delete $args->{rawtapdir};
delete $args->{xmlfile};
my $self = $class->SUPER::new($args);
$self->{__xmlfile} = $xmlfile;
$self->{__xml} = {testsuite => []};
$self->{__rawtapdir} = $rawtapdir;
$self->{__cleantap} = not defined $ENV{PERL_TEST_HARNESS_DUMP_TAP};
return $self;
}
sub parsetest {
my $self = shift;
my $file = shift;
my $name = shift;
my $xml = {
name => $name,
failures => 0,
errors => 0,
tests => undef,
'time' => 0,
testcase => [],
'system-out' => [''],
};
my $parser = new TAP::Parser ({'exec' => ['/bin/cat', $self->{__rawtapdir}.'/'.$file]});
my $tests_run = 0;
my $comment = ''; # Comment agreggator
while ( my $result = $parser->next ) {
# Counters
if ($result->type eq 'plan') {
$xml->{tests} = $result->tests_planned;
}
# Comments
if ($result->type eq 'comment') {
# See BUGS
if ($result->comment =~ /Looks like your test died/) {
push @{$xml->{testcase}}, {
'time' => 0,
name => $result->comment,
classname => $name,
failure => {
type => 'Died',
message => $result->comment,
content => $result->raw,
},
};
}
#$comment .= $result->comment."\n";
# ->comment has leading whitespace stripped
$result->raw =~ /^# (.*)/ and $comment .= $1."\n";
}
# Errors
if ($result->type eq 'unknown') {
$comment .= $result->raw."\n";
}
# Test case
if ($result->type eq 'test') {
$tests_run++;
# JUnit can't express these -- pretend they do not exist
$result->directive eq 'TODO' and next;
$result->directive eq 'SKIP' and next;
my $test = {
'time' => 0,
name => $result->description,
classname => $name,
};
# Beautify a bit -- strip leading "- "
# (that is added by Test::More)
$test->{name} =~ s/^[\s-]*//;
if ($result->ok eq 'not ok') {
$test->{failure} = [{
type => blessed ($result),
message => $result->raw,
content => $comment,
}];
$xml->{errors}++;
};
push @{$xml->{testcase}}, $test;
$comment = '';
}
# Log
$xml->{'system-out'}->[0] .= $result->raw."\n";
}
# Detect no plan
unless (defined $xml->{tests}) {
# Fake a failed test
push @{$xml->{testcase}}, {
'time' => 0,
name => 'Test died too soon, even before plan.',
classname => $name,
failure => {
type => 'Plan',
message => 'The test suite died before a plan was produced. You need to have a plan.',
content => 'No plan',
},
};
$xml->{errors}++;
}
# Detect bad plan
if ($xml->{failures} = $xml->{tests} - $tests_run) {
# Fake a failed test
push @{$xml->{testcase}}, {
'time' => 0,
name => 'Test died too soon, some test did not execute.',
classname => $name,
failure => {
type => 'Plan',
message => 'Some test were not executed. The test died prematurely.',
content => 'Bad plan',
},
};
$xml->{errors}++;
}
# Add this suite to XML
push @{$self->{__xml}->{testsuite}}, $xml;
}
sub runtests {
my ($self, @files) = @_;
$ENV{PERL_TEST_HARNESS_DUMP_TAP} = $self->{__rawtapdir};
my $aggregator = $self->SUPER::runtests(@files);
foreach my $test (@files) {
my $file;
my $comment;
if (ref $test eq 'ARRAY') {
($file, $comment) = @{$test};
} else {
$file = $test;
}
$comment = $file unless defined $comment;
# Hudson crafts an URL of the test results using the comment verbatim.
# Unfortunatelly, they don't escape special characters.
# '/'-s and family will result in incorrect URLs.
# Filed here: https://hudson.dev.java.net/issues/show_bug.cgi?id=2167
$comment =~ s/[^a-zA-Z0-9 ]/_/g;
$self->parsetest ($file, $comment);
}
# Format XML output
my $xs = new XML::Simple;
my $xml = $xs->XMLout ($self->{__xml}, RootName => 'testsuites');
open (XMLFILE, '>'.$self->{__xmlfile})
or die $self->{__xmlfile}.': '.$!;
print XMLFILE "<?xml version='1.0' encoding='utf-8'?>\n";
print XMLFILE $xml;
close (XMLFILE);
# If we caused the dumps to be preserved, clean them
File::Path::rmtree($self->{__rawtapdir}) if $self->{__cleantap};
return $aggregator;
}
=head1 SEE ALSO
JUnit XML schema was obtained from L<http://jra1mw.cvs.cern.ch:8180/cgi-bin/jra1mw.cgi/org.glite.testing.unit/config/JUnitXSchema.xsd?view=markup>.
=head1 ACKNOWLEDGEMENTS
This module was partly inspired by Michael Peters' I<TAP::Harness::Archive>.
=head1 BUGS
Test return value is ignored. This is actually not a bug, I<TAP::Parser> doesn't present
the fact and TAP specification does not require that anyway.
Note that this may be a problem when running I<Test::More> tests with C<no_plan>,
since it will add a plan matching the number of tests actually run even in case
the test dies. No not do that -- always write a plan! In case it's not possible,
pass C<merge> argument when creating a I<TAP::Harness::JUnit> instance, and the
harness will detect such failures by matching certain comments.
Test durations are always set to 0 seconds.
The comments that are above the C<ok> or C<not ok> are considered the output
of the test. This, though being more logical, is against TAP specification.
L<XML::Simple> is used to generate the output. It is suboptimal and involves
some hacks.
=head1 AUTHOR
Lubomir Rintel (Good Data) C<< <lubo.rintel@gooddata.com> >>
=head1 COPYRIGHT & LICENSE
Copyright 2008 Good Data, 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;