1use warnings; 2use strict; 3 4=head1 NAME 5 6TAP::Harness::JUnit - Generate JUnit compatible output from TAP results 7 8=head1 SYNOPSIS 9 10 use TAP::Harness::JUnit; 11 my $harness = TAP::Harness::JUnit->new({ 12 xmlfile => 'output.xml', 13 package => 'database', 14 # ... 15 }); 16 $harness->runtests(@tests); 17 18=head1 DESCRIPTION 19 20The only difference between this module and I<TAP::Harness> is that this module 21adds the optional arguments 'xmlfile', 'package', and 'namemangle' that cause 22the output to be formatted into XML in a format similar to the one that is 23produced by the JUnit testing framework. 24 25=head1 METHODS 26 27This module inherits all functions from I<TAP::Harness>. 28 29=cut 30 31package TAP::Harness::JUnit; 32use base 'TAP::Harness'; 33 34use Benchmark ':hireswallclock'; 35use File::Temp; 36use TAP::Parser; 37use XML::Simple; 38use Scalar::Util qw/blessed/; 39use Encode; 40 41our $VERSION = '0.42'; 42 43=head2 new 44 45These options are added (compared to I<TAP::Harness>): 46 47=over 48 49=item xmlfile 50 51Name of the file XML output will be saved to. If this argument is omitted, the 52default of "junit_output.xml" is used and a warning is issued. 53 54Alternatively, the name of the output file can be specified in the 55$JUNIT_OUTPUT_FILE environment variable 56 57=item package 58 59The Hudson/Jenkins continuous-integration systems support separating test 60results into "packages". By default any number of output xml files will be 61merged into the default package "(root)". 62 63Setting a package name will place all test results from the current run into 64that package. You can also set the environment variable $JUNIT_PACKAGE to do 65the same. 66 67=item notimes (DEPRECATED) 68 69If provided (and true), test case times will not be recorded. 70 71=item namemangle 72 73Specify how to mangle testcase names. This is sometimes required to interact 74with buggy JUnit consumers that lack sufficient validation. 75 76Alternatively, this value can be set in the environment variable 77$JUNIT_NAME_MANGLE. 78 79Available values are: 80 81=over 82 83=item hudson 84 85Replace anything but alphanumeric characters with underscores. This is the 86default for historic reasons. 87 88=item perl (RECOMMENDED) 89 90Replace slashes in the directory hierarchy with dots so that the filesystem 91layout resembles a Java class hierarchy. 92 93This is the recommended setting and may become the default in future. 94 95=item none 96 97Do not perform any transformations. 98 99=back 100 101=back 102 103=head1 ENVIRONMENT VARIABLES 104 105The name of the output file can be specified in the $JUNIT_OUTPUT_FILE 106environment variable 107 108The package name that Hudson/Jenkins use to categorise test results can be 109specified in $JUNIT_PACKAGE. 110 111The name mangling mechanism used to rewrite test names can be specified in 112$JUNIT_NAME_MANGLE. (See namemangle documentation for available values.) 113 114=cut 115 116sub new { 117 my ($class, $args) = @_; 118 $args ||= {}; 119 120 # Process arguments 121 my $xmlfile = delete $args->{xmlfile}; 122 $xmlfile = $ENV{JUNIT_OUTPUT_FILE} unless defined $xmlfile; 123 unless ($xmlfile) { 124 $xmlfile = 'junit_output.xml'; 125 warn 'xmlfile argument not supplied, defaulting to "junit_output.xml"'; 126 } 127 128 my $xmlpackage = delete $args->{package}; 129 $xmlpackage = $ENV{JUNIT_PACKAGE} unless defined $xmlpackage; 130 131 # Get the name of raw perl dump directory 132 my $rawtapdir = $ENV{PERL_TEST_HARNESS_DUMP_TAP}; 133 $rawtapdir = $args->{rawtapdir} unless $rawtapdir; 134 $rawtapdir = File::Temp::tempdir() unless $rawtapdir; 135 delete $args->{rawtapdir}; 136 137 my $notimes = delete $args->{notimes}; 138 139 my $namemangle = delete $args->{namemangle}; 140 $namemangle = $ENV{JUNIT_NAME_MANGLE} unless defined $namemangle; 141 unless ($namemangle) { 142 $namemangle = 'hudson'; 143 } 144 145 my $self = $class->SUPER::new($args); 146 $self->{__xmlfile} = $xmlfile; 147 $self->{__xml} = {testsuite => []}; 148 $self->{__xmlpackage} = $xmlpackage; 149 $self->{__rawtapdir} = $rawtapdir; 150 $self->{__cleantap} = not defined $ENV{PERL_TEST_HARNESS_DUMP_TAP}; 151 $self->{__notimes} = $notimes; 152 $self->{__namemangle} = $namemangle; 153 $self->{__auto_number} = 1; 154 155 # Inject our parser, that persists results for later 156 # consumption and adds timing information 157 @TAP::Harness::JUnit::Parser::ISA = ($self->parser_class); 158 $self->parser_class ('TAP::Harness::JUnit::Parser'); 159 160 return $self; 161} 162 163# Add "(number)" at the end of the test name if the test with 164# the same name already exists in XML 165sub uniquename { 166 my $self = shift; 167 my $xml = shift; 168 my $name = shift; 169 170 my $newname; 171 172 # Beautify a bit -- strip leading "- " 173 # (that is added by Test::More) 174 $name =~ s/^[\s-]*//; 175 176 $self->{__test_names} = { map { $_->{name} => 1 } @{ $xml->{testcase} } } 177 unless $self->{__test_names}; 178 179 while(1) { 180 my $number = $self->{__auto_number}; 181 $newname = $name 182 ? $name.($number > 1 ? " ($number)" : '') 183 : "Unnamed test case $number" 184 ; 185 last unless exists $self->{__test_names}->{$newname}; 186 $self->{__auto_number}++; 187 }; 188 189 $self->{__test_names}->{$newname}++; 190 191 return xmlsafe($newname); 192} 193 194# Add result of a single TAP parse to the XML 195sub parsetest { 196 my $self = shift; 197 my $name = shift; 198 my $parser = shift; 199 200 my $time = $parser->end_time - $parser->start_time; 201 $time = 0 if $self->{__notimes}; 202 203 # Get the return code of test script before re-parsing the TAP output 204 my $badretval = $parser->exit; 205 206 if ($self->{__namemangle}) { 207 # Older version of hudson crafted an URL of the test 208 # results using the name verbatim. Unfortunatelly, 209 # they didn't escape special characters, soo '/'-s 210 # and family would result in incorrect URLs. 211 # See hudson bug #2167 212 $self->{__namemangle} eq 'hudson' 213 and $name =~ s/[^a-zA-Z0-9, ]/_/g; 214 215 # Transform hierarchy of directories into what would 216 # look like hierarchy of classes in Hudson 217 if ($self->{__namemangle} eq 'perl') { 218 $name =~ s/^[\.\/]*//; 219 $name =~ s/\./_/g; 220 $name =~ s/\//./g; 221 } 222 } 223 224 # Hudson/Jenkins strip the prefix from a classname to figure out the package 225 my $prefixname = $self->{__xmlpackage} 226 ? $self->{__xmlpackage}.'.'.$name 227 : $name; 228 229 my $xml = { 230 name => $prefixname, 231 failures => 0, 232 errors => 0, 233 tests => undef, 234 'time' => $time, 235 testcase => [], 236 'system-out' => [''], 237 skipped => 0, 238 }; 239 240 my $tests_run = 0; 241 my $comment = ''; # Comment agreggator 242 foreach my $result (@{$parser->{__results}}) { 243 244 my $time = $result->{__end_time} - $result->{__start_time}; 245 $time = 0 if $self->{__notimes}; 246 247 # Counters 248 if ($result->type eq 'plan') { 249 $xml->{tests} = $result->tests_planned; 250 } 251 252 # Comments 253 if ($result->type eq 'comment') { 254 $result->raw =~ /^# (.*)/ and $comment .= xmlsafe($1)."\n"; 255 } 256 257 # Errors 258 if ($result->type eq 'unknown') { 259 $comment .= xmlsafe($result->raw)."\n"; 260 } 261 262 # Test case 263 if ($result->type eq 'test') { 264 $tests_run++; 265 266 # JUnit can't express these -- pretend they do not exist 267 $result->directive eq 'TODO' and next; 268 269 my $test = { 270 'time' => $time, 271 name => $self->uniquename($xml, $result->description), 272 classname => $prefixname, 273 }; 274 275 if ($result->ok eq 'not ok') { 276 $test->{failure} = [{ 277 type => blessed ($result), 278 message => xmlsafe($result->raw), 279 content => $comment, 280 }]; 281 $xml->{failures}++; 282 }; 283 284 if ($result->directive eq 'SKIP') { 285 $test->{skipped} = [{ 286 message => xmlsafe($result->raw), 287 }]; 288 $xml->{skipped}++; 289 }; 290 291 push @{$xml->{testcase}}, $test; 292 $comment = ''; 293 } 294 295 # Log 296 $xml->{'system-out'}->[0] .= xmlsafe($result->raw)."\n"; 297 } 298 299 # Detect no plan 300 unless (defined $xml->{tests}) { 301 # Ensure XML will have non-empty value 302 $xml->{tests} = 0; 303 304 # Fake a failed test 305 push @{$xml->{testcase}}, { 306 'time' => $time, 307 name => $self->uniquename($xml, 'Test died too soon, even before plan.'), 308 classname => $prefixname, 309 failure => { 310 type => 'Plan', 311 message => 'The test suite died before a plan was produced. You need to have a plan.', 312 content => 'No plan', 313 }, 314 }; 315 $xml->{errors}++; 316 } 317 318 # Detect bad plan 319 elsif ($xml->{errors} = $xml->{tests} - $tests_run) { 320 # Fake an error 321 push @{$xml->{testcase}}, { 322 'time' => $time, 323 name => $self->uniquename($xml, 'Number of runned tests does not match plan.'), 324 classname => $prefixname, 325 failure => { 326 type => 'Plan', 327 message => ($xml->{errors} > 0 328 ? 'Some test were not executed, The test died prematurely.' 329 : 'Extra tests tun.'), 330 content => 'Bad plan', 331 }, 332 }; 333 $xml->{failures}++; 334 $xml->{errors} = abs ($xml->{errors}); 335 } 336 337 # Bad return value. See BUGS 338 elsif ($badretval and not $xml->{failures}) { 339 # Fake an error 340 push @{$xml->{testcase}}, { 341 'time' => $time, 342 name => $self->uniquename($xml, 'Test returned failure'), 343 classname => $prefixname, 344 failure => { 345 type => 'Died', 346 message => "Test died with return code $badretval", 347 content => "Test died with return code $badretval", 348 }, 349 }; 350 $xml->{errors}++; 351 $xml->{tests}++; 352 } 353 354 # Add this suite to XML 355 push @{$self->{__xml}->{testsuite}}, $xml; 356} 357 358sub runtests { 359 my ($self, @files) = @_; 360 361 my $aggregator = $self->SUPER::runtests(@files); 362 363 foreach my $test (keys %{$aggregator->{parser_for}}) { 364 $self->parsetest ($test => $aggregator->{parser_for}->{$test}); 365 } 366 367 # Format XML output 368 my $xs = new XML::Simple; 369 my $xml = $xs->XMLout ($self->{__xml}, RootName => 'testsuites'); 370 371 # Ensure it is valid XML. Not very smart though. 372 $xml = encode ('UTF-8', decode ('UTF-8', $xml)); 373 374 # Dump output 375 open my $xml_fh, '>', $self->{__xmlfile} 376 or die $self->{__xmlfile}.': '.$!; 377 print $xml_fh "<?xml version='1.0' encoding='utf-8'?>\n"; 378 print $xml_fh $xml; 379 close $xml_fh; 380 381 # If we caused the dumps to be preserved, clean them 382 File::Path::rmtree($self->{__rawtapdir}) if $self->{__cleantap}; 383 384 return $aggregator; 385} 386 387# Because not all utf8 characters are allowed in xml, only these 388# Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] 389# http://www.w3.org/TR/REC-xml/#NT-Char 390sub xmlsafe { 391 my $s = shift; 392 393 return '' unless defined $s && length($s) > 0; 394 395 $s =~ s/([\x00|\x01|\x02|\x03|\x04|\x05|\x06|\x07|\x08|\x0B|\x0C|\x0E|\x0F|\x11|\x12|\x13|\x14|\x15|\x16|\x17|\x18|\x19|\x1A|\x1B|\x1C|\x1D|\x1E|\x1F])/ sprintf("<%0.2x>", ord($1)) /gex; 396 397 398 return $s; 399} 400 401# This is meant to transparently extend the parser chosen by user. 402# Dynamically superubclassed to the chosen parser upon harnsess construction. 403package TAP::Harness::JUnit::Parser; 404 405use Time::HiRes qw/time/; 406 407# Upon each line taken, account for time and remember the exact 408# result. A harness should then collect the results from the aggregator. 409sub next 410{ 411 my $self = shift; 412 my $result = $self->SUPER::next (@_); 413 return $result unless $result; # last call 414 415 # First assert 416 unless ($self->{__results}) { 417 $self->{__last_assert} = $self->start_time; 418 $self->{__results} = [] 419 } 420 421 # Account for time taken 422 $result->{__start_time} = $self->{__last_assert}; 423 $result->{__end_time} = $self->{__last_assert} = time; 424 425 # Remember for the aggregator 426 push @{$self->{__results}}, $result; 427 428 return $result; 429} 430 431=head1 SEE ALSO 432 433I<TAP::Formatter::JUnit> at L<https://metacpan.org/pod/TAP::Formatter::JUnit> 434 435The JUnit XML schema was obtained from 436L<http://jra1mw.cvs.cern.ch:8180/cgi-bin/jra1mw.cgi/org.glite.testing.unit/config/JUnitXSchema.xsd?view=markup>. 437 438=head1 ACKNOWLEDGEMENTS 439 440This module was partly inspired by Michael Peters's I<TAP::Harness::Archive>. 441It was originally written by Lubomir Rintel (GoodData) 442C<< <lubo.rintel@gooddata.com> >> and includes code from several contributors. 443 444The following people (in no specific order) have reported problems or 445contributed code to I<TAP::Harness::JUnit>: 446 447=over 448 449=item David Ritter 450 451=item Jeff Lavallee 452 453=item Andreas Pohl 454 455=item Ton Voon 456 457=item Kevin Goess 458 459=item Richard Huxton 460 461=item David E. Wheeler 462 463=item Malcolm Parsons 464 465=item Finn Smith 466 467=item Toby Broyles 468 469=back 470 471=head1 BUGS 472 473The comments that are above the C<ok> or C<not ok> are considered the output of 474the test. This, though being more logical, is against TAP specification. 475 476I<XML::Simple> is used to generate the output. This is suboptimal and involves 477some hacks. 478 479During testing the resulting files are not tested against the schema. This 480would be a good thing to do. 481 482=head1 CONTRIBUTING 483 484Source code for I<TAP::Harness::JUnit> is kept in a public Git repository. 485Visit L<https://github.com/jlavallee/tap-harness-junit>. 486 487Bug reports and feature enhancement requests are tracked at 488L<https://rt.cpan.org/Public/Dist/Display.html?Name=TAP-Harness-JUnit>. 489 490=head1 COPYRIGHT & LICENSE 491 492Copyright 2008, 2009, 2010, 2011, 2012, 2013 I<TAP::Harness::JUnit> 493contributors. All rights reserved. 494 495This program is free software; you can redistribute it and/or modify it under 496the same terms as Perl itself. 497 498=cut 499 5001; 501