From 82396ee3ef1ae1dcf64dffb731b354c273dede66 Mon Sep 17 00:00:00 2001 From: Xiaoqiang Wang Date: Fri, 5 May 2017 12:48:31 +0200 Subject: [PATCH 1/2] fix data size of gdd container type getDataSizeElement of gdd container returns the number of sub fields. It has to be called on the "value" field. This fix has already been done in monitorReponse. --- src/cas/generic/casStrmClient.cc | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/src/cas/generic/casStrmClient.cc b/src/cas/generic/casStrmClient.cc index c18e5bfa4..58f89425d 100644 --- a/src/cas/generic/casStrmClient.cc +++ b/src/cas/generic/casStrmClient.cc @@ -530,8 +530,20 @@ caStatus casStrmClient::readResponse ( epicsGuard < casClientMutex > & guard, pChan->getCID(), status, ECA_GETFAIL ); } + aitUint32 elementCount = 0; + if (desc.isContainer()) { + aitUint32 index; + int gdds = gddApplicationTypeTable::app_table.mapAppToIndex + ( desc.applicationType(), gddAppType_value, index ); + if ( gdds ) { + return S_cas_badType; + } + elementCount = desc.getDD(index)->getDataSizeElements(); + } else { + elementCount = desc.getDataSizeElements(); + } ca_uint32_t count = (msg.m_count == 0) ? - (ca_uint32_t)desc.getDataSizeElements() : + (ca_uint32_t)elementCount : msg.m_count; void * pPayload; @@ -659,8 +671,20 @@ caStatus casStrmClient::readNotifyResponse ( epicsGuard < casClientMutex > & gua return ecaStatus; } + aitUint32 elementCount = 0; + if (desc.isContainer()) { + aitUint32 index; + int gdds = gddApplicationTypeTable::app_table.mapAppToIndex + ( desc.applicationType(), gddAppType_value, index ); + if ( gdds ) { + return S_cas_badType; + } + elementCount = desc.getDD(index)->getDataSizeElements(); + } else { + elementCount = desc.getDataSizeElements(); + } ca_uint32_t count = (msg.m_count == 0) ? - (ca_uint32_t)desc.getDataSizeElements() : + (ca_uint32_t)elementCount : msg.m_count; void *pPayload; From b7b3dd2b37ad17bc5b039c6b703e0faa76ea45fd Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 18 May 2017 16:31:43 -0500 Subject: [PATCH 2/2] Support for 'make junitfiles' target. The Perl XML::Generator module must be installed to use this. --- configure/CONFIG_BASE | 1 + configure/CONFIG_SITE | 5 +- configure/RULES.Db | 2 +- configure/RULES_ARCHS | 2 +- configure/RULES_BUILD | 10 +- configure/RULES_DIRS | 2 +- configure/RULES_TOP | 1 + documentation/RELEASE_NOTES.html | 9 + src/tools/Makefile | 1 + src/tools/tap-to-junit-xml.pl | 546 +++++++++++++++++++++++++++++++ 10 files changed, 571 insertions(+), 8 deletions(-) create mode 100644 src/tools/tap-to-junit-xml.pl diff --git a/configure/CONFIG_BASE b/configure/CONFIG_BASE index 373b8311e..7ee5a5b89 100644 --- a/configure/CONFIG_BASE +++ b/configure/CONFIG_BASE @@ -66,6 +66,7 @@ DBTOMENUH = $(call PATH_FILTER, $(TOOLS)/dbToMenuH$(HOSTEXE)) REGISTERRECORDDEVICEDRIVER = $(PERL) $(TOOLS)/registerRecordDeviceDriver.pl CONVERTRELEASE = $(PERL) $(call FIND_TOOL,convertRelease.pl) FULLPATHNAME = $(PERL) $(TOOLS)/fullPathName.pl +TAPTOJUNIT = $(PERL) $(TOOLS)/tap-to-junit-xml.pl #------------------------------------------------------- # tools for installing libraries and products diff --git a/configure/CONFIG_SITE b/configure/CONFIG_SITE index a49cc76f2..6cc19f0f6 100644 --- a/configure/CONFIG_SITE +++ b/configure/CONFIG_SITE @@ -121,11 +121,10 @@ CROSS_COMPILER_TARGET_ARCHS= # CROSS_COMPILER_HOST_ARCHS= -# The 'make runtests' and 'make tapfiles' build targets normally only run +# The 'runtests', 'tapfiles' and 'junitfiles' make targets normally only run # self-tests for the EPICS_HOST_ARCH architecture. If the host can execute # the self-test programs for any other cross-built architectures such as -# a -debug architecture, those architectures can be named here. -# +# a -debug architecture, those architectures must be named in this variable: CROSS_COMPILER_RUNTEST_ARCHS= # Build shared libraries? diff --git a/configure/RULES.Db b/configure/RULES.Db index 11e4d40a6..6c8d8f1c1 100644 --- a/configure/RULES.Db +++ b/configure/RULES.Db @@ -134,7 +134,7 @@ ACTIONS += build ACTIONS += install ACTIONS += buildInstall ACTIONS += browse -ACTIONS += runtests tapfiles +ACTIONS += runtests tapfiles junitfiles actionArchTargets = $(foreach x, $(ACTIONS),\ $(foreach arch,$(BUILD_ARCHS), $(x)$(DIVIDER)$(arch))) diff --git a/configure/RULES_ARCHS b/configure/RULES_ARCHS index 016869d1c..fb0ad523f 100644 --- a/configure/RULES_ARCHS +++ b/configure/RULES_ARCHS @@ -14,7 +14,7 @@ ACTIONS += build ACTIONS += install ACTIONS += buildInstall ACTIONS += browse -ACTIONS += runtests tapfiles +ACTIONS += runtests tapfiles junitfiles #ACTIONS += rebuild actionArchTargets = $(foreach action, $(ACTIONS), \ diff --git a/configure/RULES_BUILD b/configure/RULES_BUILD index 141757acf..3762579bd 100644 --- a/configure/RULES_BUILD +++ b/configure/RULES_BUILD @@ -101,6 +101,7 @@ endif ifneq (,$(findstring $(T_A),$(EPICS_HOST_ARCH) $(CROSS_COMPILER_RUNTEST_ARCHS))) RUNTESTS_ENABLED = YES TAPFILES += $(TESTSCRIPTS:.t=.tap) +JUNITFILES += $(TAPFILES:.tap=.xml) endif #--------------------------------------------------------------- @@ -148,7 +149,7 @@ clean:: $(INC) $(TARGETS) $(DLL_LINK_LIBNAME) $(TDS) \ *.out MakefileInclude $(LOADABLE_SHRLIBNAME) *.manifest *.exp \ $(COMMON_INC) $(HDEPENDS_FILES) $(PRODTARGETS) \ - $(TESTSCRIPTS) $(TAPFILES) + $(TESTSCRIPTS) $(TAPFILES) $(JUNITFILES) ifdef RES @$(RM) *$(RES) endif @@ -354,6 +355,7 @@ testspec: $(TESTSCRIPTS) $(if $(TESTSPEC_$(OS_CLASS)), @echo "Harness: $(TESTSPEC_$(OS_CLASS))" >> $@) tapfiles: $(TESTSCRIPTS) $(TAPFILES) +junitfiles: $(JUNITFILES) # A .tap file is the output from running the associated test script %.tap: %.t @@ -361,6 +363,9 @@ ifdef RUNTESTS_ENABLED -$(PERL) $< -tap > $@ endif +%.xml: %.tap + $(TAPTOJUNIT) --puretap --output $@ --input $< $* + # If there's a perl test script (.plt) available, use it %.t: ../%.plt @$(RM) $@ @@ -494,7 +499,8 @@ $(INSTALL_TEMPLATES_SUBDIR)/%: % .PRECIOUS: $(COMMON_INC) .PHONY: all inc build install clean rebuild buildInstall -.PHONY: runtests checkRelease warnRelease noCheckRelease +.PHONY: runtests tapfiles junitfiles +.PHONY: checkRelease warnRelease noCheckRelease endif # BASE_RULES_BUILD # EOF RULES_BUILD diff --git a/configure/RULES_DIRS b/configure/RULES_DIRS index 7ed122072..eda8d9a05 100644 --- a/configure/RULES_DIRS +++ b/configure/RULES_DIRS @@ -9,7 +9,7 @@ ARCHS += $(BUILD_ARCHS) ACTIONS += inc build install buildInstall clean realclean archclean -ACTIONS += runtests tapfiles +ACTIONS += runtests tapfiles junitfiles dirActionArchTargets = $(foreach dir, $(DIRS), \ $(foreach action, $(ACTIONS), \ diff --git a/configure/RULES_TOP b/configure/RULES_TOP index 6d86564fb..e5637a814 100644 --- a/configure/RULES_TOP +++ b/configure/RULES_TOP @@ -58,6 +58,7 @@ help: @echo " Cannot be used within an O. dir" @echo " rebuild - Same as clean install" @echo " archclean - Removes O. dirs but not O.Common dir" + @echo " runtests - Run self-tests, summarize results" @echo "\"Partial\" build targets supported by Makefiles:" @echo " inc$(DIVIDER) - Installs only header files." @echo " build$(DIVIDER) - Builds and installs only." diff --git a/documentation/RELEASE_NOTES.html b/documentation/RELEASE_NOTES.html index b2465e53c..e925334fc 100644 --- a/documentation/RELEASE_NOTES.html +++ b/documentation/RELEASE_NOTES.html @@ -13,6 +13,15 @@ + +

Self-test JUnit XML Output

+ +

This release adds a new make target junitfiles which if necessary +runs the self-tests and then converts the TAP (Perl Test-Anything-Protocol) +output files (as generated by the tapfiles target) into the more +commonly-recognized JUnit XML format. The program that performs this conversion +needs the Perl module XML::Generator to have been installed.

+

Fix DNS related crash on exit

The attempt to fix DNS related delays for short lived CLI programs (eg. caget) diff --git a/src/tools/Makefile b/src/tools/Makefile index 5f84d49c0..672944958 100644 --- a/src/tools/Makefile +++ b/src/tools/Makefile @@ -29,6 +29,7 @@ PERL_SCRIPTS += makeTestfile.pl PERL_SCRIPTS += mkmf.pl PERL_SCRIPTS += munch.pl PERL_SCRIPTS += replaceVAR.pl +PERL_SCRIPTS += tap-to-junit-xml.pl PERL_SCRIPTS += useManifestTool.pl include $(TOP)/configure/RULES diff --git a/src/tools/tap-to-junit-xml.pl b/src/tools/tap-to-junit-xml.pl new file mode 100644 index 000000000..fe8aa86fb --- /dev/null +++ b/src/tools/tap-to-junit-xml.pl @@ -0,0 +1,546 @@ +#!/usr/local/bin/perl +=head1 NAME + +tap-to-junit-xml - convert perl-style TAP test output to JUnit-style XML + +=head1 SYNOPSIS + +tap-to-junit-xml [--help|--man] + [--[no]hidesummary] + [--input ] + [--output ] + [--puretap] + [] [outputprefix] + +=head1 DESCRIPTION + +Parse test suite output in TAP (Test Anything Protocol, +C) format, and produce XML output in a similar format +to that produced by the ant task. This is useful for consumption by +continuous-integration systems like Hudson (C). + +C<"test suite name"> is a descriptive string used as the B attribute on the +top-level node of the output XML. Defaults to "make test". + +If C is specified, multi-file output will be generated, with +multiple XML files created using C as the start of their +filenames. The files are separated by testplan. This option is ignored +if --puretap is specified (TAP only allows one testplan per input file). +This prefix may contain slashes, in which case the files will be +placed into a directory hierarchy accordingly (although care should be taken to +ensure these directories exist in advance). + +If --input I is not specified, STDIN will be read. +If C or --output is not specified, a single XML file will be +generated on STDOUT. + +--output I is used to write a single XML file to I. + +--puretap parses a single TAP source and handles parse errors and directives +(todo, skip, bailout). --puretap ignores unknown (non-TAP) input. Without +--puretap, the script will parse some additional non-TAP test input, such as +Perl tests that can include a "Test Summary Report", but it won't generate +correct XML unless the TAP testplan comes before the test cases. +--hidesummary report (the default) will hide the summary report, --no-hidesummary +will display it (neither has an effect when --puretap is specified). + +=head1 EXAMPLE + + prove -v 2>&1 | tee tests.log + tap-to-junit-xml "make test" testxml/tests < tests.log + +(JUnit-formatted XML is now in "testxml/tests*.xml".) + +=head1 DEPENDENCIES + + Getopt::Long + Pod::Usage + TAP::Parser + Time::HiRes + XML::Generator + +=head1 BUGS + + - Output is optimized for Hudson, and may not look quite as good in + other UIs. + - Doesn't do anything with the STDERR from tests. + - Doesn't fill in the 'errors' attribute in the element. + (--puretap handles parse errors) + - Doesn't handle "todo" or "skip" (--puretap does) + - Doesn't get the elapsed time for each 'test' (i.e. assertion.) + (TAP output has no elapsed time convention). + +=head1 SOURCE + +http://github.com/jmason/tap-to-junit-xml/tree/master + +=head1 AUTHOR + +original, junit_xml.pl, by Matisse Enzer ; see +C. + +pretty much entirely rewritten by Justin Mason , Feb 2008. + +Miscellaneous fixes and mods (--puretap) by Jascha Lee , Mar 2009. + +=head1 VERSION + + Mar 27 2008 jm + Mar 17 2009 jl + +=head1 COPYRIGHT & LICENSE + +Copyright (c) 2007 Matisse Enzer. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +=cut + +use strict; +use warnings; + +use Getopt::Long qw(:config no_ignore_case); +use Pod::Usage; +use TAP::Parser; +use Time::HiRes qw(gettimeofday tv_interval); +use XML::Generator qw(:noimport); + +my %opts; +pod2usage() unless GetOptions( \%opts, 'help|h', + 'hidesummary!', + 'input=s', + 'man', + 'output=s', + 'puretap' + ); + +pod2usage(-verbose => 1) if defined $opts{'help'}; +pod2usage(-verbose => 2) if defined $opts{'man'}; + +my $opt_suitename = shift @ARGV; +my $opt_multifile = 0; +my $opt_mfprefix; + +if (defined $ARGV[0]) { + $opt_multifile = 1; + $opt_mfprefix = $ARGV[0]; +} + +# should the 'Test Summary Report' at the end of a test suite be displayed +# as if it was a testcase? in my opinion, no +my $HIDE_TEST_SUMMARY_REPORT = defined $opts{'hidesummary'} ? $opts{'hidesummary'} : 1; + +my $suite_name = $opt_suitename || 'make test'; +my $safe_suite_name = $suite_name; $safe_suite_name =~ s/[^-:_A-Za-z0-9]+/_/gs; + +# TODO: it'd be nice to respect 'Universal desirable behavior #1' from +# http://testanything.org/wiki/index.php/TAP_Consumers -- 'Should work on the +# TAP as a stream (ie. as each line is received) rather than wait until all the +# TAP is received'. But it seems TAP::Parser itself doesn't support it! +# maybe when TAP::Parser does that, we'll do it too. +my $tapfh; +if ( defined $opts{'input'} ) { + open $tapfh, '<', $opts{'input'} or die "Can't open TAP file '$opts{'input'}': $!\n"; +} +else { + $tapfh = \*STDIN; +} + +my $outfh; +if ( defined $opts{'output'} ) { + open $outfh, '>', $opts{'output'} or die "Can't open output file '$opts{'output'}' for writing: $!\n"; +} +else { + $outfh = \*STDOUT; +} + +my $tap = TAP::Parser->new( { source => $tapfh } ); +my $xmlgen = XML::Generator->new( ':pretty'); +my $xmlgenunescaped = XML::Generator->new( escape => 'unescaped', + conformance => 'strict', + pretty => 2 + ); +my @properties = _get_properties($xmlgen); +if ( defined $opts{'puretap'} ) { + # + # Instead of trying to parse everything in one pass, which fails if the + # testplan is last, parse through the results for the test cases and + # then construct the information from the TAP and wrap it + # around the test cases. Ignore 'unknown' information. [JL] + # + my @testcases = _parse_testcases( $tap, $xmlgen ); + errorOut( $tap, $xmlgen ) if $tap->parse_errors; + print $outfh $xmlgen->testsuites( + $xmlgen->testsuite( { name => $safe_suite_name, + tests => $tap->tests_planned, + failures => scalar $tap->failed, + errors => 0, + time => 0, + id => 1 }, + @testcases )); + +} +else { + my $test_results = _parse_tests( $tap, $xmlgen ); + if ($opt_multifile) { + _gen_junit_multifile_xml( $xmlgen, \@properties, $test_results ); + } else { + print $outfh _get_junit_xml( $xmlgen, \@properties, $test_results ); + } +} +exit; + +#------------------------------------------------------------------------------- + +sub _get_junit_xml { + my ( $xmlgen, $properties, $test_results ) = @_; + my $xml = "\n" . + $xmlgen->testsuites({ + name => $suite_name, + }, @$test_results); + return $xml; +} + +sub _gen_junit_multifile_xml { + my ( $xmlgen, $properties, $test_results ) = @_; + my $count = 1; + foreach my $testsuite (@$test_results) { + open OUT, ">${opt_mfprefix}.${count}.xml" + or die "cannot write ${opt_mfprefix}.${count}.xml"; + print OUT "\n"; + print OUT $testsuite; + close OUT; + $count++; + } +} + +# +# Wrap up parse errors and output them as test cases. +# +sub errorOut { + my $parser = shift; + my $xmlgen = shift; + die "errorOut() needs some args" unless $parser and $xmlgen; + my ($xml, @errors, $name); + my $count = 1; + foreach my $error ( $parser->parse_errors ) { + $name = sprintf "%s%02d", 'Error_', $count++; + $xml = $xmlgen->testcase( { name => $name, + classname => 'TestsNotRun.ParseError', + time => 0 }, + + $xmlgen->error( { type => 'TAPParseError', + message => $error } )); + push @errors, $xml; + } + print $outfh $xmlgen->testsuites( + $xmlgen->testsuite( { name => 'TestsNotRun.ParseError', + tests => $tap->tests_planned, + failures => 0, + errors => scalar $tap->parse_errors, + time => 0, + id => 1 }, + @errors )); + exit 86; +} + +# +# Construct an array of XML'd test cases +# +sub _parse_testcases { + my $parser = shift; + my $xmlgen = shift; + return () unless $parser and $xmlgen; + my ($name, $directive, $xml, @testcases); + + while ( my $result = $parser->next ) { + if ( $result->is_bailout ) { + $xml = $xmlgen->testcase( { name => 'BailOut', + classname => "$safe_suite_name.Tests", + time => 0 }, + + $xmlgen->error( { type => 'BailOut', + message => $result->explanation } )); + + push @testcases, $xml; + last; + } + next unless $result->is_test; + $directive = $result->directive; + $name = sprintf "%s%02d", 'Test_', $result->number; + $name .= "_$directive" if $directive; + if ( $result->is_ok ) { + $xml = $xmlgen->testcase( { name => $name, + classname => "$safe_suite_name.Tests", + time => 0 } ); + push @testcases, $xml; + } + else { + $xml = $xmlgen->testcase( { name => $name, + classname => "$safe_suite_name.Tests", + time => 0 }, + $xmlgen->failure( { type => 'TAPTestFailed', + message => $result->as_string } )); + push @testcases, $xml; + } + } + + return @testcases; +} + +sub _parse_tests { + my ( $parser, $xmlgen ) = @_; + + my $ctx = { + testsuites => [ ], + test_name => 'notest', + plan_ntests => 0, + case_id => 0, + }; + + _new_ctx($ctx); + + my $lastunk = ''; + + # unknown t/basic_lint......... + # plan 1..1 + # comment # Running under perl version 5.008008 for linux + # comment # Current time local: Thu Jan 24 17:44:30 2008 + # comment # Current time GMT: Thu Jan 24 17:44:30 2008 + # comment # Using Test.pm version 1.25 + # unknown /usr/bin/perl -T -w ../spamassassin.raw -C log/test_rules_copy --siteconfigpath log/localrules.tmp -p log/test_default.cf -L --lint + # unknown Checking anything + # test ok 1 + # test ok 2 + # unknown t/basic_meta......... + # plan 1..2 + # comment # Running under perl version 5.008008 for linux + # comment # Current time local: Thu Jan 24 17:44:31 2008 + # comment # Current time GMT: Thu Jan 24 17:44:31 2008 + # comment # Using Test.pm version 1.25 + # test not ok 1 + # comment # Failed test 1 in t/basic_meta.t at line 91 + # test ok 2 + # unknown Failed 1/2 subtests + # unknown t/basic_obj_api...... + # plan 1..4 + # comment # Running under perl version 5.008008 for linux + # comment # Current time local: Thu Jan 24 17:44:33 2008 + # comment # Current time GMT: Thu Jan 24 17:44:33 2008 + # comment # Using Test.pm version 1.25 + # test ok 1 + # test ok 2 + # test ok 3 + # test ok 4 + # test ok 9 + # unknown + # unknown Test Summary Report + # unknown ------------------- + # unknown t/basic_meta.t (Wstat: 0 Tests: 2 Failed: 1) + # unknown Failed test: 1 + # unknown Files=3, Tests=7, 6 wallclock secs ( 0.01 usr 0.00 sys + 4.39 cusr 0.23 csys = 4.63 CPU) + # unknown Result: FAIL + # unknown Failed 1/3 test programs. 1/7 subtests failed. + # unknown make: *** [test_dynamic] Error 255 + + while ( my $r = $parser->next ) { + my $t = $r->type; + my $s = $r->as_string; $s =~ s/\s+$//; + + # warn "JMD $t $s"; + + if ($t eq 'unknown') { + $lastunk = $s; + + # PERL_DL_NONLAZY=1 /usr/bin/perl "-MExtUtils::Command::MM" "-e" "test_harness(1, 'blib/lib', 'blib/arch')" t/basic_* + # if ($s =~ /test_harness\(.*?\)" (.+)$/) { + # $suite_name = $1; + # } + if ($s =~ /^Test Summary Report$/) { + # create a block for the summary + $ctx->{plan_ntests} = 0; + $ctx->{test_name} = "Test Summary Report"; + $ctx->{case_tests} = 1; + _finish_test_block($ctx); + } + elsif ($s =~ /^Result: FAIL$/) { + $ctx->{case_tests}++; + $ctx->{case_failures}++; + my $test_case = { + classname => test_name_to_classname($ctx->{test_name}), + name => 'result', + 'time' => 0, + }; + my $failure = $xmlgen->failure({ + type => "OverallTestsFailed", + message => $s + }, "__FAILUREMESSAGETODO__"); + + if (!$HIDE_TEST_SUMMARY_REPORT) { + push @{$ctx->{test_cases}}, $xmlgen->testcase($test_case, $failure); + } + } + elsif ($s =~ /^(\S+?)\.\.\.+1\.\.(\d+?)\s*$/) { + # perl 5.6.x "Test" format plan line + # unknown t/basic_lint....................1..1 + + my ($name, $nt) = ($1,$2); + if ($ctx->{plan_ntests}) { # only if there have been tests planned + _finish_test_block($ctx); + } + + $ctx->{plan_ntests} = $nt+0; + $ctx->{test_name} = "$name.t"; + } + } + elsif ($t eq 'plan') { + if ($ctx->{plan_ntests}) { # only if there have been tests planned + _finish_test_block($ctx); + } + + $ctx->{plan_ntests} = 0; + $s =~ /(\d+)$/ and $ctx->{plan_ntests} = $1+0; + + $ctx->{test_name} = $lastunk; + $ctx->{test_name} =~ s/\.*\s*$//gs; + $ctx->{test_name} .= ".t"; + } + elsif ($t eq 'test') { + my $ntest = 0; + if ($s =~ /(?:not |)\S+ (\d+)/) { $ntest = $1+0; } + + if ($ntest > $ctx->{plan_ntests}) { + # jump in test numbers, more than planned; this is probably TAP::Parser's wierdness. + # (when it sees the "ok" line at the end of a test case with no number, + # it outputs the current total number of tests so far.) + next; + } + + # clean this up in a Hudson-compatible way; ":" and "/" are out, "." also causes + # trouble by creating an extra "directory" in the results + + my $test_case = { + classname => test_name_to_classname($ctx->{test_name}), + name => sprintf("test %6d", $ntest), # space-padding ensures ordering + 'time' => 0, + }; + + $ctx->{case_tests}++; + my $failure = undef; + if ($s =~ /^not /i) { + $ctx->{case_failures}++; + $failure = $xmlgen->failure({ + type => "TAPTestFailed", + message => $s + }, "__FAILUREMESSAGETODO__"); + push @{$ctx->{test_cases}}, $xmlgen->testcase($test_case, $failure); + } + else { + push @{$ctx->{test_cases}}, $xmlgen->testcase($test_case); + } + } + + $ctx->{sysout} .= $s."\n"; + } + + if (scalar(@{$ctx->{test_cases}}) == 0 && + scalar(@{$ctx->{testsuites}}) == 0) + { + # no tests found! create a block containing *something* at least + $ctx->{case_tests}++; + my $test_case = { + classname => test_name_to_classname($ctx->{test_name}), + name => 'result', + 'time' => 0, + }; + push @{$ctx->{test_cases}}, $xmlgen->testcase($test_case); + } + + _finish_test_block($ctx); + return $ctx->{testsuites}; +} + +sub _new_ctx { + my $ctx = shift; + $ctx->{start_time} = [gettimeofday]; + $ctx->{test_cases} = []; + $ctx->{case_tests} = 0; + $ctx->{case_failures} = 0; + $ctx->{case_time} = 0; + $ctx->{case_id}++; + $ctx->{sysout} = ''; + return $ctx; +} + +sub _finish_test_block { + my $ctx = shift; + $ctx->{sysout} =~ s/\n\S+\.*\s*\n$/\n/s; # remove next test's "t/foo....." line + + my $elapsed_time = 0; # TODO + #my $elapsed_time = tv_interval( $ctx->{start_time}, [gettimeofday] ); + + # clean it up to valid Java packagename format (or at least something Hudson will + # consume) + my $name = $ctx->{test_name}; + $name =~ s/[^-:_A-Za-z0-9]+/_/gs; + $name = "$safe_suite_name.$name"; # a "directory" for the suite name + + my $testsuite = { + 'time' => $elapsed_time, + 'name' => $name, + tests => $ctx->{case_tests}, + failures => $ctx->{case_failures}, + 'id' => $ctx->{case_id}, + errors => 0, + }; + + my @fixedcases = (); + foreach my $tc (@{$ctx->{test_cases}}) { + if ($tc =~ s/__FAILUREMESSAGETODO__/ cdata($ctx->{sysout}) /ges) { + push @fixedcases, \$tc; # inhibits escaping! + } else { + push @fixedcases, $tc; + } + } + + # use "unescaped"; we have already fixed escaping on these strings. + # note that a reference means 'this is unescaped', bizarrely. + push @{$ctx->{testsuites}}, $xmlgenunescaped->testsuite($testsuite, + @fixedcases, + \("\n".cdata($ctx->{sysout})."\n"), + \("")); + + _new_ctx($ctx); +}; + +sub cdata { + my $s = shift; + $s =~ s/\]\]>/\](warning: defanged by tap-to-junit-xml)\]>/gs; + return ''; +} + +sub _get_properties { + my $xmlgen = shift; + my @props; + foreach my $key ( sort keys %ENV ) { + push @props, $xmlgen->property( { name => "$key", value => $ENV{$key} } ); + } + return @props; +} + +sub test_name_to_classname { + my $safe = shift; + $safe =~ s/[^-:_A-Za-z0-9]+/_/gs; + $safe = "$safe_suite_name.$safe"; # a "directory" for the suite name + $safe; +} + +__END__ + +# JUnit references: +# http://www.nabble.com/JUnit-4-XML-schematized--td13946472.html +# http://jra1mw.cvs.cern.ch:8180/cgi-bin/jra1mw.cgi/org.glite.testing.unit/config/JUnitXSchema.xsd?view=markup +# skipped tests: +# https://hudson.dev.java.net/issues/show_bug.cgi?id=1251 +# Hudson source: +# http://fisheye5.cenqua.com/browse/hudson/hudson/main/core/src/main/java/hudson/tasks/junit/CaseResult.java