]>
Commit | Line | Data |
---|---|---|
e0a65194 | 1 | #! /usr/bin/env perl |
fecb3aae | 2 | # Copyright 2015-2022 The OpenSSL Project Authors. All Rights Reserved. |
e0a65194 | 3 | # |
909f1a2e | 4 | # Licensed under the Apache License 2.0 (the "License"). You may not use |
e0a65194 RS |
5 | # this file except in compliance with the License. You can obtain a copy |
6 | # in the file LICENSE in the source distribution or at | |
7 | # https://www.openssl.org/source/license.html | |
aec27d4d RL |
8 | |
9 | use strict; | |
10 | use warnings; | |
11 | ||
e4522e10 | 12 | # Recognise VERBOSE aka V which is common on other projects. |
94fcec09 DDO |
13 | # Additionally, recognise VERBOSE_FAILURE aka VF aka REPORT_FAILURES |
14 | # and recognise VERBOSE_FAILURE_PROGRESS aka VFP aka REPORT_FAILURES_PROGRESS. | |
be6bdab6 DSH |
15 | BEGIN { |
16 | $ENV{HARNESS_VERBOSE} = "yes" if $ENV{VERBOSE} || $ENV{V}; | |
94fcec09 DDO |
17 | $ENV{HARNESS_VERBOSE_FAILURE} = "yes" |
18 | if $ENV{VERBOSE_FAILURE} || $ENV{VF} || $ENV{REPORT_FAILURES}; | |
e4522e10 | 19 | $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} = "yes" |
94fcec09 DDO |
20 | if ($ENV{VERBOSE_FAILURE_PROGRESS} || $ENV{VFP} |
21 | || $ENV{REPORT_FAILURES_PROGRESS}); | |
be6bdab6 DSH |
22 | } |
23 | ||
aec27d4d RL |
24 | use File::Spec::Functions qw/catdir catfile curdir abs2rel rel2abs/; |
25 | use File::Basename; | |
8d2214c0 RL |
26 | use FindBin; |
27 | use lib "$FindBin::Bin/../util/perl"; | |
28 | use OpenSSL::Glob; | |
76e0d0b2 | 29 | |
42e0ccdf RL |
30 | my $srctop = $ENV{SRCTOP} || $ENV{TOP}; |
31 | my $bldtop = $ENV{BLDTOP} || $ENV{TOP}; | |
32 | my $recipesdir = catdir($srctop, "test", "recipes"); | |
cb6afcd6 | 33 | my $libdir = rel2abs(catdir($srctop, "util", "perl")); |
ef0f01c0 | 34 | my $jobs = $ENV{HARNESS_JOBS} // 1; |
aec27d4d | 35 | |
afb254d0 | 36 | $ENV{OPENSSL_CONF} = rel2abs(catfile($srctop, "apps", "openssl.cnf")); |
7c499c7d | 37 | $ENV{OPENSSL_CONF_INCLUDE} = rel2abs(catdir($bldtop, "test")); |
6ed34b3e MC |
38 | $ENV{OPENSSL_MODULES} = rel2abs(catdir($bldtop, "providers")); |
39 | $ENV{OPENSSL_ENGINES} = rel2abs(catdir($bldtop, "engines")); | |
afb254d0 | 40 | $ENV{CTLOG_FILE} = rel2abs(catfile($srctop, "test", "ct", "log_list.cnf")); |
d1ae34e9 | 41 | |
c1b364ce MC |
42 | # On platforms that support this, this will ensure malloc returns data that is |
43 | # set to a non-zero value. Can be helpful for detecting uninitialized reads in | |
44 | # some situations. | |
45 | $ENV{'MALLOC_PERTURB_'} = '128' if !defined $ENV{'MALLOC_PERTURB_'}; | |
46 | ||
76e0d0b2 | 47 | my %tapargs = |
e3d9a6b5 RL |
48 | ( verbosity => $ENV{HARNESS_VERBOSE} ? 1 : 0, |
49 | lib => [ $libdir ], | |
50 | switches => '-w', | |
51 | merge => 1, | |
1baad060 | 52 | timer => $ENV{HARNESS_TIMER} ? 1 : 0, |
76e0d0b2 | 53 | ); |
aec27d4d | 54 | |
835f3526 P |
55 | if ($jobs > 1) { |
56 | if ($ENV{HARNESS_VERBOSE}) { | |
57 | print "Warning: HARNESS_JOBS > 1 ignored with HARNESS_VERBOSE\n"; | |
58 | } else { | |
59 | $tapargs{jobs} = $jobs; | |
60 | print "Using HARNESS_JOBS=$jobs\n"; | |
61 | } | |
62 | } | |
a20c9075 | 63 | |
e3d9a6b5 RL |
64 | # Additional OpenSSL special TAP arguments. Because we can't pass them via |
65 | # TAP::Harness->new(), they will be accessed directly, see the | |
66 | # TAP::Parser::OpenSSL implementation further down | |
67 | my %openssl_args = (); | |
68 | ||
317ffa57 | 69 | $openssl_args{'failure_verbosity'} = $ENV{HARNESS_VERBOSE} ? 0 : |
e4522e10 DDO |
70 | $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} ? 2 : |
71 | 1; # $ENV{HARNESS_VERBOSE_FAILURE} | |
72 | print "Warning: HARNESS_VERBOSE overrides HARNESS_VERBOSE_FAILURE*\n" | |
73 | if ($ENV{HARNESS_VERBOSE} && ($ENV{HARNESS_VERBOSE_FAILURE} | |
74 | || $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS})); | |
75 | print "Warning: HARNESS_VERBOSE_FAILURE_PROGRESS overrides HARNESS_VERBOSE_FAILURE\n" | |
76 | if ($ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} && $ENV{HARNESS_VERBOSE_FAILURE}); | |
e3d9a6b5 RL |
77 | |
78 | my $outfilename = $ENV{HARNESS_TAP_COPY}; | |
79 | open $openssl_args{'tap_copy'}, ">$outfilename" | |
80 | or die "Trying to create $outfilename: $!\n" | |
81 | if defined $outfilename; | |
82 | ||
90aeaf6b RL |
83 | my @alltests = find_matching_tests("*"); |
84 | my %tests = (); | |
85 | ||
1e76cb00 DDO |
86 | sub reorder { |
87 | my $key = pop; | |
88 | ||
89 | # for parallel test runs, do slow tests first | |
b91a13f4 | 90 | if ($jobs > 1 && $key =~ m/test_ssl_new|test_fuzz/) { |
7e8d6baf | 91 | $key =~ s/(\d+)-/01-/; |
1e76cb00 DDO |
92 | } |
93 | return $key; | |
94 | } | |
95 | ||
90aeaf6b RL |
96 | my $initial_arg = 1; |
97 | foreach my $arg (@ARGV ? @ARGV : ('alltests')) { | |
98 | if ($arg eq 'list') { | |
1e76cb00 DDO |
99 | foreach (@alltests) { |
100 | (my $x = basename($_)) =~ s|^[0-9][0-9]-(.*)\.t$|$1|; | |
101 | print $x,"\n"; | |
102 | } | |
103 | exit 0; | |
aec27d4d | 104 | } |
90aeaf6b | 105 | if ($arg eq 'alltests') { |
1e76cb00 DDO |
106 | warn "'alltests' encountered, ignoring everything before that...\n" |
107 | unless $initial_arg; | |
108 | %tests = map { $_ => 1 } @alltests; | |
90aeaf6b | 109 | } elsif ($arg =~ m/^(-?)(.*)/) { |
1e76cb00 DDO |
110 | my $sign = $1; |
111 | my $test = $2; | |
112 | my @matches = find_matching_tests($test); | |
113 | ||
114 | # If '-foo' is the first arg, it's short for 'alltests -foo' | |
115 | if ($sign eq '-' && $initial_arg) { | |
116 | %tests = map { $_ => 1 } @alltests; | |
117 | } | |
118 | ||
119 | if (scalar @matches == 0) { | |
120 | warn "Test $test found no match, skipping ", | |
121 | ($sign eq '-' ? "removal" : "addition"), | |
122 | "...\n"; | |
123 | } else { | |
124 | foreach $test (@matches) { | |
125 | if ($sign eq '-') { | |
126 | delete $tests{$test}; | |
127 | } else { | |
128 | $tests{$test} = 1; | |
129 | } | |
130 | } | |
131 | } | |
90aeaf6b | 132 | } else { |
1e76cb00 | 133 | warn "I don't know what '$arg' is about, ignoring...\n"; |
90aeaf6b RL |
134 | } |
135 | ||
136 | $initial_arg = 0; | |
aec27d4d RL |
137 | } |
138 | ||
7e8d6baf TM |
139 | # prep recipes are mandatory and need to be always run first |
140 | my @preps = glob(catfile($recipesdir,"00-prep_*.t")); | |
141 | foreach my $test (@preps) { | |
142 | delete $tests{$test}; | |
143 | } | |
144 | ||
90aeaf6b RL |
145 | sub find_matching_tests { |
146 | my ($glob) = @_; | |
aec27d4d | 147 | |
e5fd8ca4 | 148 | if ($glob =~ m|^[\d\[\]\?\-]+$|) { |
7e8d6baf | 149 | return glob(catfile($recipesdir,"$glob-*.t")); |
e5fd8ca4 | 150 | } |
7e8d6baf TM |
151 | |
152 | return glob(catfile($recipesdir,"*-$glob.t")); | |
1780e6d9 | 153 | } |
76e0d0b2 | 154 | |
e3d9a6b5 RL |
155 | # The following is quite a bit of hackery to adapt to both TAP::Harness |
156 | # and Test::Harness, depending on what's available. | |
317ffa57 | 157 | # The TAP::Harness hack allows support for HARNESS_VERBOSE_FAILURE* and |
e3d9a6b5 RL |
158 | # HARNESS_TAP_COPY, while the Test::Harness hack can't, because the pre |
159 | # TAP::Harness Test::Harness simply doesn't have support for this sort of | |
160 | # thing. | |
161 | # | |
162 | # We use eval to avoid undue interruption if TAP::Harness isn't present. | |
163 | ||
164 | my $package; | |
165 | my $eres; | |
166 | ||
167 | $eres = eval { | |
168 | package TAP::Parser::OpenSSL; | |
c804f296 RJ |
169 | use parent -norequire, 'TAP::Parser'; |
170 | require TAP::Parser; | |
e3d9a6b5 RL |
171 | |
172 | sub new { | |
173 | my $class = shift; | |
174 | my %opts = %{ shift() }; | |
317ffa57 | 175 | my $failure_verbosity = $openssl_args{failure_verbosity}; |
317ffa57 DDO |
176 | my @plans = (); # initial level, no plan yet |
177 | my $output_buffer = ""; | |
d1093fa9 | 178 | my $in_indirect = 0; |
e3d9a6b5 RL |
179 | |
180 | # We rely heavily on perl closures to make failure verbosity work | |
181 | # We need to do so, because there's no way to safely pass extra | |
182 | # objects down all the way to the TAP::Parser::Result object | |
183 | my @failure_output = (); | |
184 | my %callbacks = (); | |
317ffa57 DDO |
185 | if ($failure_verbosity > 0 || defined $openssl_args{tap_copy}) { |
186 | $callbacks{ALL} = sub { # on each line of test output | |
e3d9a6b5 RL |
187 | my $self = shift; |
188 | my $fh = $openssl_args{tap_copy}; | |
e3d9a6b5 RL |
189 | print $fh $self->as_string, "\n" |
190 | if defined $fh; | |
317ffa57 DDO |
191 | |
192 | my $failure_verbosity = $openssl_args{failure_verbosity}; | |
e4522e10 | 193 | if ($failure_verbosity > 0) { |
317ffa57 DDO |
194 | my $is_plan = $self->is_plan; |
195 | my $tests_planned = $is_plan && $self->tests_planned; | |
196 | my $is_test = $self->is_test; | |
197 | my $is_ok = $is_test && $self->is_ok; | |
93a7d241 DDO |
198 | |
199 | # workaround for parser not coping with sub-test indentation | |
317ffa57 | 200 | if ($self->is_unknown) { |
93a7d241 DDO |
201 | my $level = $#plans; |
202 | my $indent = $level < 0 ? "" : " " x ($level * 4); | |
203 | ||
317ffa57 | 204 | ($is_plan, $tests_planned) = (1, $1) |
93a7d241 | 205 | if ($self->as_string =~ m/^$indent 1\.\.(\d+)/); |
317ffa57 | 206 | ($is_test, $is_ok) = (1, !$1) |
93a7d241 | 207 | if ($self->as_string =~ m/^$indent(not )?ok /); |
317ffa57 | 208 | } |
93a7d241 | 209 | |
317ffa57 DDO |
210 | if ($is_plan) { |
211 | push @plans, $tests_planned; | |
212 | $output_buffer = ""; # ignore comments etc. until plan | |
213 | } elsif ($is_test) { # result of a test | |
214 | pop @plans if @plans && --($plans[-1]) <= 0; | |
d1093fa9 NH |
215 | if ($output_buffer =~ /.*Indirect leak of.*/ == 1) { |
216 | my @asan_array = split("\n", $output_buffer); | |
217 | foreach (@asan_array) { | |
218 | if ($_ =~ /.*Indirect leak of.*/ == 1) { | |
5528bfbc NH |
219 | if ($in_indirect != 1) { |
220 | print "::group::Indirect Leaks\n"; | |
221 | } | |
d1093fa9 | 222 | $in_indirect = 1; |
5528bfbc NH |
223 | } |
224 | print "$_\n"; | |
225 | if ($_ =~ /.*Indirect leak of.*/ != 1) { | |
d1093fa9 | 226 | if ($_ =~ /^ #.*/ == 0) { |
5528bfbc NH |
227 | if ($in_indirect != 0) { |
228 | print "\n::endgroup::\n"; | |
229 | } | |
d1093fa9 NH |
230 | $in_indirect = 0; |
231 | } | |
232 | } | |
d1093fa9 NH |
233 | } |
234 | } else { | |
235 | print $output_buffer if !$is_ok; | |
236 | } | |
6bb74ecb | 237 | print "\n".$self->as_string |
317ffa57 | 238 | if !$is_ok || $failure_verbosity == 2; |
a8125491 | 239 | print "\n# ------------------------------------------------------------------------------" if !$is_ok; |
317ffa57 | 240 | $output_buffer = ""; |
6bb74ecb DDO |
241 | } elsif ($self->as_string ne "") { |
242 | # typically is_comment or is_unknown | |
243 | $output_buffer .= "\n".$self->as_string; | |
317ffa57 DDO |
244 | } |
245 | } | |
246 | } | |
e3d9a6b5 RL |
247 | } |
248 | ||
317ffa57 | 249 | if ($failure_verbosity > 0) { |
e3d9a6b5 RL |
250 | $callbacks{EOF} = sub { |
251 | my $self = shift; | |
252 | ||
253 | # We know we are a TAP::Parser::Aggregator object | |
254 | if (scalar $self->failed > 0 && @failure_output) { | |
255 | # We add an extra empty line, because in the case of a | |
256 | # progress counter, we're still at the end of that progress | |
257 | # line. | |
258 | print $_, "\n" foreach (("", @failure_output)); | |
259 | } | |
317ffa57 | 260 | # Echo any trailing comments etc. |
e4522e10 | 261 | print "$output_buffer"; |
e3d9a6b5 RL |
262 | }; |
263 | } | |
264 | ||
265 | if (keys %callbacks) { | |
266 | # If %opts already has a callbacks element, the order here | |
267 | # ensures we do not override it | |
268 | %opts = ( callbacks => { %callbacks }, %opts ); | |
269 | } | |
270 | ||
271 | return $class->SUPER::new({ %opts }); | |
272 | } | |
76e0d0b2 | 273 | |
e3d9a6b5 | 274 | package TAP::Harness::OpenSSL; |
c804f296 RJ |
275 | use parent -norequire, 'TAP::Harness'; |
276 | require TAP::Harness; | |
e3d9a6b5 RL |
277 | |
278 | package main; | |
279 | ||
280 | $tapargs{parser_class} = "TAP::Parser::OpenSSL"; | |
281 | $package = 'TAP::Harness::OpenSSL'; | |
282 | }; | |
283 | ||
284 | unless (defined $eres) { | |
285 | $eres = eval { | |
286 | # Fake TAP::Harness in case it's not loaded | |
287 | package TAP::Harness::fake; | |
288 | use parent 'Test::Harness'; | |
289 | ||
290 | sub new { | |
291 | my $class = shift; | |
292 | my %args = %{ shift() }; | |
293 | ||
294 | return bless { %args }, $class; | |
295 | } | |
296 | ||
297 | sub runtests { | |
298 | my $self = shift; | |
299 | ||
300 | # Pre TAP::Harness Test::Harness doesn't support [ filename, name ] | |
301 | # elements, so convert such elements to just be the filename | |
302 | my @args = map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @_; | |
303 | ||
304 | my @switches = (); | |
305 | if ($self->{switches}) { | |
306 | push @switches, $self->{switches}; | |
307 | } | |
308 | if ($self->{lib}) { | |
309 | foreach (@{$self->{lib}}) { | |
310 | my $l = $_; | |
311 | ||
312 | # It seems that $switches is getting interpreted with 'eval' | |
313 | # or something like that, and that we need to take care of | |
314 | # backslashes or they will disappear along the way. | |
315 | $l =~ s|\\|\\\\|g if $^O eq "MSWin32"; | |
316 | push @switches, "-I$l"; | |
317 | } | |
318 | } | |
319 | ||
320 | $Test::Harness::switches = join(' ', @switches); | |
321 | Test::Harness::runtests(@args); | |
322 | } | |
323 | ||
324 | package main; | |
325 | $package = 'TAP::Harness::fake'; | |
326 | }; | |
327 | } | |
76e0d0b2 | 328 | |
e3d9a6b5 RL |
329 | unless (defined $eres) { |
330 | print $@,"\n" if $@; | |
331 | print $!,"\n" if $!; | |
332 | exit 127; | |
76e0d0b2 RL |
333 | } |
334 | ||
e3d9a6b5 RL |
335 | my $harness = $package->new(\%tapargs); |
336 | my $ret = | |
7e8d6baf TM |
337 | $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] } |
338 | @preps); | |
fe537f89 HL |
339 | |
340 | if (ref($ret) ne "TAP::Parser::Aggregator" || !$ret->has_errors) { | |
341 | $ret = | |
342 | $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] } | |
343 | sort { reorder($a) cmp reorder($b) } keys %tests); | |
344 | } | |
76e0d0b2 | 345 | |
a515c825 RL |
346 | # If this is a TAP::Parser::Aggregator, $ret->has_errors is the count of |
347 | # tests that failed. We don't bother with that exact number, just exit | |
348 | # with an appropriate exit code when it isn't zero. | |
349 | if (ref($ret) eq "TAP::Parser::Aggregator") { | |
350 | exit 0 unless $ret->has_errors; | |
351 | exit 1 unless $^O eq 'VMS'; | |
352 | # On VMS, perl converts an exit 1 to SS$_ABORT (%SYSTEM-F-ABORT), which | |
353 | # is a bit harsh. As per perl recommendations, we explicitly use the | |
354 | # same VMS status code as typical C programs would for exit(1), except | |
355 | # we set the error severity rather than success. | |
356 | # Ref: https://perldoc.perl.org/perlport#exit | |
357 | # https://perldoc.perl.org/perlvms#$? | |
358 | exit 0x35a000 # C facility code | |
359 | + 8 # 1 << 3 (to make space for the 3 severity bits) | |
360 | + 2 # severity: E(rror) | |
361 | + 0x10000000; # bit 28 set => the shell stays silent | |
362 | } | |
76e0d0b2 | 363 | |
e3d9a6b5 RL |
364 | # If this isn't a TAP::Parser::Aggregator, it's the pre-TAP test harness, |
365 | # which simply dies at the end if any test failed, so we don't need to bother | |
366 | # with any exit code in that case. |