lib/TAP/Harness/JUnit.pm

   1 use warnings;
   2 use strict;
   3
   4 =head1 NAME
   5
   6 TAP::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         ...
  14     });
  15     $harness->runtests(@tests);
  16
  17 =head1 DESCRIPTION
  18
  19 The only difference between this module and I<TAP::Harness> is that
  20 this adds optional 'xmlfile' argument, that causes the output to
  21 be formatted into XML in format similar to one that is produced by
  22 JUnit testing framework.
  23
  24 =head1 METHODS
  25
  26 This modules inherits all functions from I<TAP::Harness>.
  27
  28 =cut
  29
  30 package TAP::Harness::JUnit;
  31 use base 'TAP::Harness';
  32
  33 use Benchmark ':hireswallclock';
  34 use File::Temp;
  35 use TAP::Parser;
  36 use XML::Simple;
  37 use Scalar::Util qw/blessed/;
  38 use Encode;
  39
  40 our $VERSION = '0.26';
  41
  42 =head2 new
  43
  44 These options are added (compared to I<TAP::Harness>):
  45
  46 =over
  47
  48 =item xmlfile
  49
  50 Name of the file XML output will be saved to.  In case this argument
  51 is ommited, default of "junit_output.xml" is used and a warning is issued.
  52
  53 =item notimes
  54
  55 If provided (and true), test case times will not be recorded.
  56
  57 =item namemangle
  58
  59 Specify how to mangle testcase names. This is sometimes required to
  60 interact with buggy JUnit consumers that lack sufficient validation.
  61 Available values are:
  62
  63 =over
  64
  65 =item hudson
  66
  67 Replace anything but alphanumeric characters with underscores.
  68 This is default for historic reasons.
  69
  70 =item perl
  71
  72 Replace slashes in directory hierarchy with dots so that the
  73 filesystem layout resemble Java class hierarchy.
  74
  75 =item none
  76
  77 Do not do any transformations.
  78
  79 =back
  80
  81 =back
  82
  83 =cut
  84
  85 sub new {
  86         my ($class, $args) = @_;
  87         $args ||= {};
  88
  89         # Process arguments
  90         my $xmlfile;
  91         unless ($xmlfile = delete $args->{xmlfile}) {
  92                 $xmlfile = 'junit_output.xml';
  93                 warn 'xmlfile argument not supplied, defaulting to "junit_output.xml"';
  94         }
  95         defined $args->{merge} or
  96                 warn 'You should consider using "merge" parameter. See BUGS section of TAP::Harness::JUnit manual';
  97
  98         # Get the name of raw perl dump directory
  99         my $rawtapdir = $ENV{PERL_TEST_HARNESS_DUMP_TAP};
 100         $rawtapdir = $args->{rawtapdir} unless $rawtapdir;
 101         $rawtapdir = File::Temp::tempdir() unless $rawtapdir;
 102         delete $args->{rawtapdir};
 103
 104         my $notimes = delete $args->{notimes};
 105
 106         my $self = $class->SUPER::new($args);
 107         $self->{__xmlfile} = $xmlfile;
 108         $self->{__xml} = {testsuite => []};
 109         $self->{__rawtapdir} = $rawtapdir;
 110         $self->{__cleantap} = not defined $ENV{PERL_TEST_HARNESS_DUMP_TAP};
 111         $self->{__notimes} = $notimes;
 112         if (defined $args->{namemangle}) {
 113                 $self->{__namemangle} = $args->{namemangle};
 114         } else {
 115                 $self->{__namemangle} = 'hudson';
 116         }
 117
 118         return $self;
 119 }
 120
 121 # Add "(number)" at the end of the test name if the test with
 122 # the same name already exists in XML
 123 sub uniquename {
 124         my $xml = shift;
 125         my $name = shift;
 126
 127         my $newname;
 128         my $number = 1;
 129
 130         # Beautify a bit -- strip leading "- "
 131         # (that is added by Test::More)
 132         $name =~ s/^[\s-]*//;
 133
 134         NAME: while (1) {
 135                 if ($name) {
 136                         $newname = $name;
 137                         $newname .= " ($number)" if $number > 1;
 138                 } else {
 139                         $newname = "Unnamed test case $number";
 140                 }
 141
 142                 $number++;
 143                 foreach my $testcase (@{$xml->{testcase}}) {
 144                         next NAME if $newname eq $testcase->{name};
 145                 }
 146
 147                 return $newname;
 148         }
 149 }
 150
 151 # Add a single TAP output file to the XML
 152 sub parsetest {
 153         my $self = shift;
 154         my $file = shift;
 155         my $name = shift;
 156         my $time = shift;
 157
 158         my $badretval;
 159
 160         my $xml = {
 161                 name => $name,
 162                 failures => 0,
 163                 errors => 0,
 164                 tests => undef,
 165                 'time' => $time,
 166                 testcase => [],
 167                 'system-out' => [''],
 168         };
 169
 170         open (my $tap_handle, $self->{__rawtapdir}.'/'.$file)
 171                 or die $!;
 172         my $rawtap = join ('', <$tap_handle>);
 173         close ($tap_handle);
 174
 175         my $parser = new TAP::Parser ({'tap' => $rawtap });
 176
 177         my $tests_run = 0;
 178         my $comment = ''; # Comment agreggator
 179         while ( my $result = $parser->next ) {
 180
 181                 # Counters
 182                 if ($result->type eq 'plan') {
 183                         $xml->{tests} = $result->tests_planned;
 184                 }
 185
 186                 # Comments
 187                 if ($result->type eq 'comment') {
 188                         # See BUGS
 189                         $badretval = $result if $result->comment =~ /Looks like your test died/;
 190
 191                         #$comment .= $result->comment."\n";
 192                         # ->comment has leading whitespace stripped
 193                         $result->raw =~ /^# (.*)/ and $comment .= $1."\n";
 194                 }
 195
 196                 # Errors
 197                 if ($result->type eq 'unknown') {
 198                         $comment .= $result->raw."\n";
 199                 }
 200
 201                 # Test case
 202                 if ($result->type eq 'test') {
 203                         $tests_run++;
 204
 205                         # JUnit can't express these -- pretend they do not exist
 206                         $result->directive eq 'TODO' and next;
 207                         $result->directive eq 'SKIP' and next;
 208
 209                         my $test = {
 210                                 'time' => 0,
 211                                 name => uniquename ($xml, $result->description),
 212                                 classname => $name,
 213                         };
 214
 215                         if ($result->ok eq 'not ok') {
 216                                 $test->{failure} = [{
 217                                         type => blessed ($result),
 218                                         message => $result->raw,
 219                                         content => $comment,
 220                                 }];
 221                                 $xml->{errors}++;
 222                         };
 223
 224                         push @{$xml->{testcase}}, $test;
 225                         $comment = '';
 226                 }
 227
 228                 # Log
 229                 $xml->{'system-out'}->[0] .= $result->raw."\n";
 230         }
 231
 232         # Detect no plan
 233         unless (defined $xml->{tests}) {
 234                 # Ensure XML will have non-empty value
 235                 $xml->{tests} = 0;
 236
 237                 # Fake a failed test
 238                 push @{$xml->{testcase}}, {
 239                         'time' => 0,
 240                         name => uniquename ($xml, 'Test died too soon, even before plan.'),
 241                         classname => $name,
 242                         failure => {
 243                                 type => 'Plan',
 244                                 message => 'The test suite died before a plan was produced. You need to have a plan.',
 245                                 content => 'No plan',
 246                         },
 247                 };
 248                 $xml->{errors}++;
 249         }
 250
 251         # Detect bad plan
 252         elsif ($xml->{failures} = $xml->{tests} - $tests_run) {
 253                 # Fake a failed test
 254                 push @{$xml->{testcase}}, {
 255                         'time' => 0,
 256                         name => uniquename ($xml, 'Number of runned tests does not match plan.'),
 257                         classname => $name,
 258                         failure => {
 259                                 type => 'Plan',
 260                                 message => ($xml->{failures} > 0
 261                                         ? 'Some test were not executed, The test died prematurely.'
 262                                         : 'Extra tests tun.'),
 263                                 content => 'Bad plan',
 264                         },
 265                 };
 266                 $xml->{errors}++;
 267                 $xml->{failures} = abs ($xml->{failures});
 268         }
 269
 270         # Bad return value. See BUGS
 271         elsif ($badretval and not $xml->{errors}) {
 272                 # Fake a failed test
 273                 push @{$xml->{testcase}}, {
 274                         'time' => 0,
 275                         name => uniquename ($xml, 'Test returned failure'),
 276                         classname => $name,
 277                         failure => {
 278                                 type => 'Died',
 279                                 message => $badretval->comment,
 280                                 content => $badretval->raw,
 281                         },
 282                 };
 283                 $xml->{errors}++;
 284         }
 285
 286         # Make up times for sub-tests
 287         if ($time) {
 288                 foreach my $testcase (@{$xml->{testcase}}) {
 289                         $testcase->{time} = $time / @{$xml->{testcase}};
 290                 }
 291         }
 292
 293         # Add this suite to XML
 294         push @{$self->{__xml}->{testsuite}}, $xml;
 295 }
 296
 297 sub runtests {
 298         my ($self, @files) = @_;
 299
 300         $ENV{PERL_TEST_HARNESS_DUMP_TAP} = $self->{__rawtapdir};
 301         my $aggregator = $self->SUPER::runtests(@files);
 302
 303         foreach my $test (@files) {
 304                 my $file;
 305                 my $comment;
 306
 307                 if (ref $test eq 'ARRAY') {
 308                         ($file, $comment) = @{$test};
 309                 } else {
 310                         $file = $test;
 311                 }
 312                 $comment = $file unless defined $comment;
 313
 314                 if ($self->{__namemangle}) {
 315                         # Older version of hudson crafted an URL of the test
 316                         # results using the comment verbatim. Unfortunatelly,
 317                         # they didn't escape special characters, soo '/'-s
 318                         # and family would result in incorrect URLs.
 319                         # See hudson bug #2167
 320                         $self->{__namemangle} eq 'hudson'
 321                                 and $comment =~ s/[^a-zA-Z0-9, ]/_/g;
 322
 323                         # Transform hierarchy of directories into what would
 324                         # look like hierarchy of classes in Hudson
 325                         if ($self->{__namemangle} eq 'perl') {
 326                                 $comment =~ s/^[\.\/]*//;
 327                                 $comment =~ s/\./_/g;
 328                                 $comment =~ s/\//./g;
 329                         }
 330                 }
 331
 332                 $self->parsetest ($file, $comment, $self->{__notimes} ? 0 : $aggregator->elapsed->[0]);
 333         }
 334
 335         # Format XML output
 336         my $xs = new XML::Simple;
 337         my $xml = $xs->XMLout ($self->{__xml}, RootName => 'testsuites');
 338
 339         # Ensure it is valid XML. Not very smart though.
 340         $xml = encode ('UTF-8', decode ('UTF-8', $xml));
 341
 342         # Dump output
 343         open my $xml_fh, '>', $self->{__xmlfile}
 344                 or die $self->{__xmlfile}.': '.$!;
 345         print $xml_fh "<?xml version='1.0' encoding='utf-8'?>\n";
 346         print $xml_fh $xml;
 347         close $xml_fh;
 348
 349         # If we caused the dumps to be preserved, clean them
 350         File::Path::rmtree($self->{__rawtapdir}) if $self->{__cleantap};
 351
 352         return $aggregator;
 353 }
 354
 355 =head1 SEE ALSO
 356
 357 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>.
 358
 359 =head1 ACKNOWLEDGEMENTS
 360
 361 This module was partly inspired by Michael Peters' I<TAP::Harness::Archive>.
 362
 363 Following people (in no specific order) have reported problems
 364 or contributed fixes to I<TAP::Harness::JUnit>:
 365
 366 =over
 367
 368 =item David Ritter
 369
 370 =item Jeff Lavallee
 371
 372 =item Andreas Pohl
 373
 374 =back
 375
 376 =head1 BUGS
 377
 378 Test return value is ignored. This is actually not a bug, I<TAP::Parser> doesn't present
 379 the fact and TAP specification does not require that anyway.
 380
 381 Note that this may be a problem when running I<Test::More> tests with C<no_plan>,
 382 since it will add a plan matching the number of tests actually run even in case
 383 the test dies. Do not do that -- always write a plan! In case it's not possible,
 384 pass C<merge> argument when creating a I<TAP::Harness::JUnit> instance, and the
 385 harness will detect such failures by matching certain comments.
 386
 387 Test durations are not mesaured. Unless the "notimes" parameter is provided (and
 388 true), the test duration is recorded as testcase duration divided by number of
 389 tests, otherwise it's set to 0 seconds. This could be addressed if the module
 390 was reimplmented as a formatter.
 391
 392 The comments that are above the C<ok> or C<not ok> are considered the output
 393 of the test. This, though being more logical, is against TAP specification.
 394
 395 I<XML::Simple> is used to generate the output. It is suboptimal and involves
 396 some hacks.
 397
 398 During testing, the resulting files are not tested against the schema, which
 399 would be a good thing to do.
 400
 401 =head1 AUTHOR
 402
 403 Lubomir Rintel (Good Data) C<< <lubo.rintel@gooddata.com> >>
 404
 405 Source code for I<TAP::Harness::JUnit> is kept in a public GIT repository.
 406 Visit L<http://repo.or.cz/w/TAP-Harness-JUnit.git> to get it.
 407
 408 =head1 COPYRIGHT & LICENSE
 409
 410 Copyright 2008, 2009 Good Data, All rights reserved.
 411
 412 This program is free software; you can redistribute it and/or modify it
 413 under the same terms as Perl itself.
 414
 415 =cut
 416
 417 1;