line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test2::Harness::Renderer::JUnit; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# Test2::Harness itself requires 5.10. |
4
|
2
|
|
|
2
|
|
401154
|
use 5.010000; |
|
2
|
|
|
|
|
16
|
|
5
|
2
|
|
|
2
|
|
14
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
60
|
|
6
|
2
|
|
|
2
|
|
13
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
86
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = '1.000003'; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# This is used frequently during development to determine what different events look like so we can determine how to capture test data. |
11
|
2
|
|
|
2
|
|
1272
|
use Data::Dumper; |
|
2
|
|
|
|
|
13448
|
|
|
2
|
|
|
|
|
151
|
|
12
|
|
|
|
|
|
|
$Data::Dumper::Sortkeys = 1; |
13
|
|
|
|
|
|
|
|
14
|
2
|
|
|
2
|
|
18
|
use File::Spec; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
43
|
|
15
|
2
|
|
|
2
|
|
11
|
use POSIX (); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
37
|
|
16
|
2
|
|
|
2
|
|
1306
|
use Storable qw/dclone/; |
|
2
|
|
|
|
|
6592
|
|
|
2
|
|
|
|
|
129
|
|
17
|
2
|
|
|
2
|
|
1236
|
use XML::Generator (); |
|
2
|
|
|
|
|
19482
|
|
|
2
|
|
|
|
|
53
|
|
18
|
2
|
|
|
2
|
|
16
|
use Carp (); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
80
|
|
19
|
|
|
|
|
|
|
|
20
|
2
|
|
|
2
|
|
958
|
BEGIN { require Test2::Harness::Renderer; our @ISA = ('Test2::Harness::Renderer') } |
|
2
|
|
|
|
|
3032
|
|
21
|
2
|
|
|
|
|
12
|
use Test2::Harness::Util::HashBase qw{ |
22
|
|
|
|
|
|
|
-io -io_err |
23
|
|
|
|
|
|
|
-formatter |
24
|
|
|
|
|
|
|
-show_run_info |
25
|
|
|
|
|
|
|
-show_job_info |
26
|
|
|
|
|
|
|
-show_job_launch |
27
|
|
|
|
|
|
|
-show_job_end |
28
|
|
|
|
|
|
|
-times |
29
|
2
|
|
|
2
|
|
17
|
}; |
|
2
|
|
|
|
|
4
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub init { |
32
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
33
|
|
|
|
|
|
|
|
34
|
0
|
|
|
|
|
|
my $settings = $self->{ +SETTINGS }; |
35
|
|
|
|
|
|
|
|
36
|
0
|
|
|
|
|
|
$self->{'xml'} = XML::Generator->new( ':pretty', ':std', 'escape' => 'always,high-bit,even-entities', 'encoding' => 'UTF-8' ); |
37
|
|
|
|
|
|
|
|
38
|
0
|
|
|
|
|
|
$self->{'xml_content'} = []; |
39
|
|
|
|
|
|
|
|
40
|
0
|
0
|
|
|
|
|
$self->{'allow_passing_todos'} = $ENV{'ALLOW_PASSING_TODOS'} ? 1 : 0; |
41
|
0
|
|
0
|
|
|
|
$self->{'junit_file'} //= $ENV{'JUNIT_TEST_FILE'} || 'junit.xml'; |
|
|
|
0
|
|
|
|
|
42
|
|
|
|
|
|
|
|
43
|
0
|
|
|
|
|
|
$self->{'tests'} = {}; # We need a pointer to each test so we know where to go for each event. |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# This sub is called for every Harness event. We capture the data we need so we can emit the appropriate junit file. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub render_event { |
49
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
50
|
0
|
|
|
|
|
|
my ($event) = @_; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# We modify the event, which would be bad if there were multiple renderers, |
53
|
|
|
|
|
|
|
# so we deep clone it. |
54
|
0
|
|
|
|
|
|
$event = dclone($event); |
55
|
0
|
|
|
|
|
|
my $f = $event->{facet_data}; |
56
|
0
|
|
|
|
|
|
my $job = $f->{harness_job}; |
57
|
0
|
0
|
|
|
|
|
my $job_id = $f->{'harness'}->{'job_id'} or return; |
58
|
0
|
|
0
|
|
|
|
my $job_try = $f->{'harness'}->{'job_try'} // 0; |
59
|
0
|
|
|
|
|
|
my $stamp = $event->{'stamp'}; |
60
|
|
|
|
|
|
|
|
61
|
0
|
0
|
|
|
|
|
if ( !defined $stamp ) { |
62
|
0
|
|
0
|
|
|
|
$f //= 'unknown facet_data'; |
63
|
0
|
|
|
|
|
|
die "No time stamp found for event '$f' ?!?!?!? ...\n" . "Event:\n" . Dumper($event) . "\n" . Carp::longmess(); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# Throw out job events if they are for a previous run and we've already started collecting job |
67
|
|
|
|
|
|
|
# information for a successive run. |
68
|
0
|
0
|
0
|
|
|
|
return if $self->{'tests'}->{$job_id} && $job_try < ( $self->{'tests'}->{$job_id}->{'job_try'} // 0 ); |
|
|
|
0
|
|
|
|
|
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# At job launch we need to start collecting a new junit testdata section. |
71
|
|
|
|
|
|
|
# We throw out anything we've collected to date on a previous run. |
72
|
0
|
0
|
|
|
|
|
if ( $f->{'harness_job_launch'} ) { |
73
|
0
|
|
|
|
|
|
my $full_test_name = $job->{'file'}; |
74
|
0
|
|
|
|
|
|
my $test_file = File::Spec->abs2rel($full_test_name); |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
$self->{'tests'}->{$job_id} = { |
77
|
|
|
|
|
|
|
'name' => $job->{'file'}, |
78
|
|
|
|
|
|
|
'file' => _squeaky_clean($test_file), |
79
|
|
|
|
|
|
|
'job_id' => $job_id, |
80
|
|
|
|
|
|
|
'job_try' => $job_try, |
81
|
0
|
|
|
|
|
|
'job_name' => $f->{'harness_job'}->{'job_name'}, |
82
|
|
|
|
|
|
|
'testcase' => [], |
83
|
|
|
|
|
|
|
'system-out' => '', |
84
|
|
|
|
|
|
|
'system-err' => '', |
85
|
|
|
|
|
|
|
'start' => $stamp, |
86
|
|
|
|
|
|
|
'last_job_start' => $stamp, |
87
|
|
|
|
|
|
|
'testsuite' => { |
88
|
|
|
|
|
|
|
'errors' => 0, |
89
|
|
|
|
|
|
|
'failures' => 0, |
90
|
|
|
|
|
|
|
'tests' => 0, |
91
|
|
|
|
|
|
|
'name' => _get_testsuite_name($test_file), |
92
|
|
|
|
|
|
|
'id' => $job_id, # add a UID in the XML output |
93
|
|
|
|
|
|
|
}, |
94
|
|
|
|
|
|
|
}; |
95
|
|
|
|
|
|
|
|
96
|
0
|
|
|
|
|
|
return; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
0
|
|
|
|
|
|
my $test = $self->{'tests'}->{$job_id}; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# We have all the data. Print the XML. |
102
|
0
|
0
|
|
|
|
|
if ( $f->{'harness_job_end'} ) { |
103
|
0
|
|
|
|
|
|
$self->close_open_failure_testcase( $test, -1 ); |
104
|
0
|
|
|
|
|
|
$test->{'stop'} = $event->{'stamp'}; |
105
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'time'} = $test->{'stop'} - $test->{'start'}; |
106
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'timestamp'} = _timestamp( $test->{'start'} ); |
107
|
|
|
|
|
|
|
|
108
|
0
|
0
|
|
|
|
|
if ( $f->{'errors'} ) { |
109
|
0
|
|
|
|
|
|
my $test_error_messages = ''; |
110
|
0
|
|
|
|
|
|
my $alternative_error = ''; |
111
|
0
|
|
|
|
|
|
foreach my $msg ( @{ $f->{'errors'} } ) { |
|
0
|
|
|
|
|
|
|
112
|
0
|
0
|
|
|
|
|
next unless $msg->{'from_harness'}; |
113
|
0
|
0
|
0
|
|
|
|
next unless $msg->{'tag'} // '' eq 'REASON'; |
114
|
|
|
|
|
|
|
|
115
|
0
|
|
|
|
|
|
my $details = $msg->{details}; |
116
|
0
|
0
|
|
|
|
|
if ( $details =~ m/^Planned for ([0-9]+) assertions?, but saw ([0-9]+)/ ) { |
117
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'errors'} += abs( $1 - $2 ); |
118
|
|
|
|
|
|
|
} |
119
|
0
|
0
|
|
|
|
|
if ( $details =~ m/Test script returned error|Assertion failures were encountered|Subtest failures were encountered/ ) { |
120
|
0
|
|
|
|
|
|
$alternative_error .= "$details\n"; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
else { |
123
|
0
|
|
|
|
|
|
$test_error_messages .= "$details\n"; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
0
|
0
|
0
|
|
|
|
if ($test_error_messages) { |
|
|
0
|
|
|
|
|
|
128
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $self->xml->testcase( |
129
|
0
|
|
|
|
|
|
{ 'name' => "Test Plan Failure", 'time' => $stamp - $test->{'last_job_start'}, 'classname' => $test->{'testsuite'}->{'name'} }, |
130
|
|
|
|
|
|
|
$self->xml->failure($test_error_messages) |
131
|
|
|
|
|
|
|
); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
# We only want to show this alternative error if all of the tests passed but the program still exited non-zero. |
135
|
|
|
|
|
|
|
elsif (!$test->{'testsuite'}->{'errors'} && $alternative_error) { |
136
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'errors'}++; |
137
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $self->xml->testcase( |
138
|
0
|
|
|
|
|
|
{ 'name' => "Program Ended Unexpectedly", 'time' => $stamp - $test->{'last_job_start'}, 'classname' => $test->{'testsuite'}->{'name'} }, |
139
|
|
|
|
|
|
|
$self->xml->failure($alternative_error) |
140
|
|
|
|
|
|
|
); |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $self->xml->testcase( |
145
|
0
|
|
|
|
|
|
{ 'name' => "Tear down.", 'time' => $stamp - $test->{'last_job_start'}, 'classname' => $test->{'testsuite'}->{'name'} }, |
146
|
|
|
|
|
|
|
); |
147
|
|
|
|
|
|
|
|
148
|
0
|
|
|
|
|
|
return; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
0
|
0
|
|
|
|
|
if ( $f->{'plan'} ) { |
152
|
0
|
0
|
|
|
|
|
if ( $f->{'plan'}->{'skip'} ) { |
153
|
0
|
|
|
|
|
|
my $skip = $f->{'plan'}->{'details'}; |
154
|
0
|
|
|
|
|
|
$test->{'system-out'} .= "# SKIP $skip\n"; |
155
|
|
|
|
|
|
|
} |
156
|
0
|
0
|
|
|
|
|
if ( $f->{'plan'}->{'count'} ) { |
157
|
0
|
|
|
|
|
|
$test->{'plan'} = $f->{'plan'}->{'count'}; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
0
|
|
|
|
|
|
return; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
0
|
0
|
|
|
|
|
if ( $f->{'harness_job_exit'} ) { |
164
|
0
|
0
|
|
|
|
|
return unless $f->{'harness_job_exit'}->{'exit'}; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# If we don't see |
167
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'errors'}++; |
168
|
0
|
|
0
|
|
|
|
$test->{'error-msg'} //= $f->{'harness_job_exit'}->{'details'} . "\n"; |
169
|
|
|
|
|
|
|
|
170
|
0
|
|
|
|
|
|
return; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
# We just hit an ok/not ok line. |
174
|
0
|
0
|
|
|
|
|
if ( $f->{'assert'} ) { |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# Ignore subtests |
177
|
0
|
0
|
0
|
|
|
|
return if ( $f->{'hubs'} && $f->{'hubs'}->[0]->{'nested'} ); |
178
|
|
|
|
|
|
|
|
179
|
0
|
|
0
|
|
|
|
my $test_num = sprintf( "%04d", $event->{'assert_count'} || $f->{'assert'}->{'number'} || die Dumper $event); |
180
|
0
|
|
0
|
|
|
|
my $test_name = _squeaky_clean( $f->{'assert'}->{'details'} // 'UNKNOWN_TEST?' ); |
181
|
0
|
0
|
|
|
|
|
my $test_string = defined $test_name ? "$test_num - $test_name" : $test_num; |
182
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'tests'}++; |
183
|
|
|
|
|
|
|
|
184
|
0
|
|
|
|
|
|
$self->close_open_failure_testcase( $test, $test_num ); |
185
|
|
|
|
|
|
|
|
186
|
0
|
0
|
|
|
|
|
warn Dumper $event unless $stamp; |
187
|
|
|
|
|
|
|
|
188
|
0
|
|
|
|
|
|
my $run_time = $stamp - $test->{'last_job_start'}; |
189
|
0
|
|
|
|
|
|
$test->{'last_job_start'} = $stamp; |
190
|
|
|
|
|
|
|
|
191
|
0
|
0
|
0
|
|
|
|
if ( $f->{'amnesty'} && grep { ( $_->{'tag'} // '' ) eq 'TODO' } @{ $f->{'amnesty'} } ) { # All TODO Tests |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
192
|
0
|
0
|
|
|
|
|
if ( !$f->{'assert'}->{'pass'} ) { # Failing TODO |
|
|
0
|
|
|
|
|
|
193
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $self->xml->testcase( { 'name' => "$test_string (TODO)", 'time' => $run_time, 'classname' => $test->{'testsuite'}->{'name'} }, "" ); |
|
0
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
elsif ( $self->{'allow_passing_todos'} ) { # junit parsers don't like passing TODO tests. Let's just not tell them about it if $ENV{ALLOW_PASSING_TODOS} is set. |
196
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $self->xml->testcase( { 'name' => "$test_string (PASSING TODO)", 'time' => $run_time, 'classname' => $test->{'testsuite'}->{'name'} }, "" ); |
|
0
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
else { # Passing TODO (Failure) when not allowed. |
199
|
|
|
|
|
|
|
|
200
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'failures'}++; |
201
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'errors'}++; |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# Grab the first amnesty description that's a TODO message. |
204
|
0
|
|
0
|
|
|
|
my ($todo_message) = map { $_->{'details'} } grep { $_->{'tag'} // '' eq 'TODO' } @{ $f->{'amnesty'} }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
|
206
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $self->xml->testcase( |
207
|
0
|
|
|
|
|
|
{ 'name' => "$test_string (TODO)", 'time' => $run_time, 'classname' => $test->{'testsuite'}->{'name'} }, |
208
|
|
|
|
|
|
|
$self->xml->error( |
209
|
|
|
|
|
|
|
{ 'message' => $todo_message, 'type' => "TodoTestSucceeded" }, |
210
|
|
|
|
|
|
|
$self->_cdata("ok $test_string") |
211
|
|
|
|
|
|
|
) |
212
|
|
|
|
|
|
|
); |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
elsif ( $f->{'assert'}->{'pass'} ) { # Passing test |
217
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $self->xml->testcase( |
218
|
0
|
|
|
|
|
|
{ 'name' => "$test_string", 'time' => $run_time, 'classname' => $test->{'testsuite'}->{'name'} }, |
219
|
|
|
|
|
|
|
"" |
220
|
|
|
|
|
|
|
); |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
else { # Failing Test. |
223
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'failures'}++; |
224
|
0
|
|
|
|
|
|
$test->{'testsuite'}->{'errors'}++; |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
# Trap the test information. We can't generate the XML for this test until we get all the diag information. |
227
|
0
|
|
|
|
|
|
$test->{'last_failure'} = { |
228
|
|
|
|
|
|
|
'test_num' => $test_num, |
229
|
|
|
|
|
|
|
'test_name' => $test_name, |
230
|
|
|
|
|
|
|
'time' => $run_time, |
231
|
|
|
|
|
|
|
'message' => "not ok $test_string\n", |
232
|
|
|
|
|
|
|
}; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
0
|
|
|
|
|
|
return; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
0
|
0
|
0
|
|
|
|
if ( $f->{'info'} && $test->{'last_failure'} ) { |
239
|
0
|
|
|
|
|
|
foreach my $line ( @{ $f->{'info'} } ) { |
|
0
|
|
|
|
|
|
|
240
|
0
|
0
|
|
|
|
|
next unless $line->{'details'}; |
241
|
0
|
|
|
|
|
|
chomp $line->{'details'}; |
242
|
0
|
|
|
|
|
|
$test->{'last_failure'}->{'message'} .= "# $line->{details}\n"; |
243
|
|
|
|
|
|
|
} |
244
|
0
|
|
|
|
|
|
return; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
# This is called when the last run is complete and we're ready to emit the junit file. |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
sub finish { |
252
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
253
|
|
|
|
|
|
|
|
254
|
0
|
0
|
|
|
|
|
open( my $fh, '>:encoding(UTF-8)', $self->{'junit_file'} ) or die("Can't open '$self->{junit_file}' ($!)"); |
255
|
|
|
|
|
|
|
|
256
|
0
|
|
|
|
|
|
my $xml = $self->xml; |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
# These are method calls but you can't do methods with a dash in them so we have to store them as a SV and call it. |
259
|
0
|
|
|
|
|
|
my $out_method = 'system-out'; |
260
|
0
|
|
|
|
|
|
my $err_method = 'system-err'; |
261
|
|
|
|
|
|
|
|
262
|
0
|
|
|
|
|
|
print {$fh} "\n"; |
|
0
|
|
|
|
|
|
|
263
|
0
|
|
|
|
|
|
my @jobs = sort { $a->{'job_name'} <=> $b->{'job_name'} } values %{ $self->{'tests'} }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
264
|
0
|
|
|
|
|
|
foreach my $job (@jobs) { |
265
|
0
|
|
|
|
|
|
print {$fh} $xml->testsuite( |
266
|
|
|
|
|
|
|
$job->{'testsuite'}, |
267
|
0
|
|
|
|
|
|
@{ $job->{'testcase'} }, |
268
|
|
|
|
|
|
|
$xml->$out_method( $self->_cdata( $job->{$out_method} ) ), |
269
|
0
|
|
|
|
|
|
$xml->$err_method( $self->_cdata( $job->{$err_method} ) ), |
270
|
|
|
|
|
|
|
) . "\n"; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
0
|
|
|
|
|
|
print {$fh} "\n"; |
|
0
|
|
|
|
|
|
|
274
|
0
|
|
|
|
|
|
close $fh; |
275
|
|
|
|
|
|
|
|
276
|
0
|
|
|
|
|
|
return; |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# Because we want to test diag messages after a failed test, we delay closing failures |
280
|
|
|
|
|
|
|
# until we see the end of the testcase or until we see a new test number. |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
sub close_open_failure_testcase { |
283
|
0
|
|
|
0
|
1
|
|
my ( $self, $test, $new_test_number ) = @_; |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
# Need to handle failed TODOs |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# The last test wasn't a fail. |
288
|
0
|
0
|
|
|
|
|
return unless $test->{'last_failure'}; |
289
|
|
|
|
|
|
|
|
290
|
0
|
|
|
|
|
|
my $fail = $test->{'last_failure'}; |
291
|
0
|
0
|
|
|
|
|
if ( $fail->{'test_num'} == $new_test_number ) { |
292
|
0
|
|
|
|
|
|
die("The same assert number ($new_test_number) was seen twice for $test->{name}"); |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
0
|
|
|
|
|
|
my $xml = $self->xml; |
296
|
0
|
|
|
|
|
|
push @{ $test->{'testcase'} }, $xml->testcase( |
297
|
|
|
|
|
|
|
{ 'name' => "$fail->{test_num} - $fail->{test_name}", 'time' => $fail->{'time'}, 'classname' => $test->{'testsuite'}->{'name'} }, |
298
|
|
|
|
|
|
|
$xml->failure( |
299
|
|
|
|
|
|
|
{ 'message' => "not ok $fail->{test_num} - $fail->{test_name}", 'type' => 'TestFailed' }, |
300
|
0
|
|
|
|
|
|
$self->_cdata( $fail->{'message'} ) |
301
|
|
|
|
|
|
|
) |
302
|
|
|
|
|
|
|
); |
303
|
|
|
|
|
|
|
|
304
|
0
|
|
|
|
|
|
delete $test->{'last_failure'}; |
305
|
0
|
|
|
|
|
|
return; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub xml { |
309
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
310
|
0
|
|
|
|
|
|
return $self->{'xml'}; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# These helpers were borrowed from https://metacpan.org/pod/TAP::Formatter::JUnit. Thanks! |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
############################################################################### |
316
|
|
|
|
|
|
|
# Generates the name for the entire test suite. |
317
|
|
|
|
|
|
|
sub _get_testsuite_name { |
318
|
0
|
|
|
0
|
|
|
my $name = shift; |
319
|
0
|
|
|
|
|
|
$name =~ s{^\./}{}; |
320
|
0
|
|
|
|
|
|
$name =~ s{^t/}{}; |
321
|
0
|
|
|
|
|
|
return _clean_to_java_class_name($name); |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
############################################################################### |
325
|
|
|
|
|
|
|
# Cleans up the given string, removing any characters that aren't suitable for |
326
|
|
|
|
|
|
|
# use in a Java class name. |
327
|
|
|
|
|
|
|
sub _clean_to_java_class_name { |
328
|
0
|
|
|
0
|
|
|
my $str = shift; |
329
|
0
|
|
|
|
|
|
$str =~ s/[^-:_A-Za-z0-9]+/_/gs; |
330
|
0
|
|
|
|
|
|
return $str; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
############################################################################### |
334
|
|
|
|
|
|
|
# Creates a CDATA block for the given data (which is made squeaky clean first, |
335
|
|
|
|
|
|
|
# so that JUnit parsers like Hudson's don't choke). |
336
|
|
|
|
|
|
|
sub _cdata { |
337
|
0
|
|
|
0
|
|
|
my ( $self, $data ) = @_; |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
# When I first added this conditional, I returned $data and at one point it was returning ^A and breaking the xml parser. |
340
|
0
|
0
|
0
|
|
|
|
return '' if ( !$data or $data !~ m/\S/ms ); |
341
|
|
|
|
|
|
|
|
342
|
0
|
|
|
|
|
|
return $self->xml->xmlcdata( _squeaky_clean($data) ); |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
############################################################################### |
346
|
|
|
|
|
|
|
# Clean a string to the point that JUnit can't possibly have a problem with it. |
347
|
|
|
|
|
|
|
sub _squeaky_clean { |
348
|
0
|
|
|
0
|
|
|
my $string = shift; |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# control characters (except CR and LF) |
351
|
0
|
|
|
|
|
|
$string =~ s/([\x00-\x09\x0b\x0c\x0e-\x1f])/"^".chr(ord($1)+64)/ge; |
|
0
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# high-byte characters |
354
|
0
|
|
|
|
|
|
$string =~ s/([\x7f-\xff])/'[\\x'.sprintf('%02x',ord($1)).']'/ge; |
|
0
|
|
|
|
|
|
|
355
|
0
|
|
|
|
|
|
return $string; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub _timestamp { |
359
|
0
|
|
|
0
|
|
|
my $time = shift; |
360
|
0
|
|
|
|
|
|
return POSIX::strftime( '%Y-%m-%dT%H:%M:%S', localtime( int($time) ) ); |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
1; |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
__END__ |