]>
Commit | Line | Data |
---|---|---|
e0a65194 | 1 | #! /usr/bin/env perl |
a28d06f3 | 2 | # Copyright 2015-2021 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 | |
6ed34b3e MC |
36 | $ENV{OPENSSL_CONF} = rel2abs(catdir($srctop, "apps", "openssl.cnf")); |
37 | $ENV{OPENSSL_CONF_INCLUDE} = rel2abs(catdir($bldtop, "providers")); | |
38 | $ENV{OPENSSL_MODULES} = rel2abs(catdir($bldtop, "providers")); | |
39 | $ENV{OPENSSL_ENGINES} = rel2abs(catdir($bldtop, "engines")); | |
40 | $ENV{CTLOG_FILE} = rel2abs(catdir($srctop, "test", "ct", "log_list.cnf")); | |
d1ae34e9 | 41 | |
76e0d0b2 | 42 | my %tapargs = |
e3d9a6b5 RL |
43 | ( verbosity => $ENV{HARNESS_VERBOSE} ? 1 : 0, |
44 | lib => [ $libdir ], | |
45 | switches => '-w', | |
46 | merge => 1, | |
1baad060 | 47 | timer => $ENV{HARNESS_TIMER} ? 1 : 0, |
76e0d0b2 | 48 | ); |
aec27d4d | 49 | |
835f3526 P |
50 | if ($jobs > 1) { |
51 | if ($ENV{HARNESS_VERBOSE}) { | |
52 | print "Warning: HARNESS_JOBS > 1 ignored with HARNESS_VERBOSE\n"; | |
53 | } else { | |
54 | $tapargs{jobs} = $jobs; | |
55 | print "Using HARNESS_JOBS=$jobs\n"; | |
56 | } | |
57 | } | |
a20c9075 | 58 | |
e3d9a6b5 RL |
59 | # Additional OpenSSL special TAP arguments. Because we can't pass them via |
60 | # TAP::Harness->new(), they will be accessed directly, see the | |
61 | # TAP::Parser::OpenSSL implementation further down | |
62 | my %openssl_args = (); | |
63 | ||
317ffa57 | 64 | $openssl_args{'failure_verbosity'} = $ENV{HARNESS_VERBOSE} ? 0 : |
e4522e10 DDO |
65 | $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} ? 2 : |
66 | 1; # $ENV{HARNESS_VERBOSE_FAILURE} | |
67 | print "Warning: HARNESS_VERBOSE overrides HARNESS_VERBOSE_FAILURE*\n" | |
68 | if ($ENV{HARNESS_VERBOSE} && ($ENV{HARNESS_VERBOSE_FAILURE} | |
69 | || $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS})); | |
70 | print "Warning: HARNESS_VERBOSE_FAILURE_PROGRESS overrides HARNESS_VERBOSE_FAILURE\n" | |
71 | if ($ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} && $ENV{HARNESS_VERBOSE_FAILURE}); | |
e3d9a6b5 RL |
72 | |
73 | my $outfilename = $ENV{HARNESS_TAP_COPY}; | |
74 | open $openssl_args{'tap_copy'}, ">$outfilename" | |
75 | or die "Trying to create $outfilename: $!\n" | |
76 | if defined $outfilename; | |
77 | ||
90aeaf6b RL |
78 | my @alltests = find_matching_tests("*"); |
79 | my %tests = (); | |
80 | ||
1e76cb00 DDO |
81 | sub reorder { |
82 | my $key = pop; | |
83 | ||
84 | # for parallel test runs, do slow tests first | |
b91a13f4 | 85 | if ($jobs > 1 && $key =~ m/test_ssl_new|test_fuzz/) { |
1e76cb00 DDO |
86 | $key =~ s/(\d+)-/00-/; |
87 | } | |
88 | return $key; | |
89 | } | |
90 | ||
90aeaf6b RL |
91 | my $initial_arg = 1; |
92 | foreach my $arg (@ARGV ? @ARGV : ('alltests')) { | |
93 | if ($arg eq 'list') { | |
1e76cb00 DDO |
94 | foreach (@alltests) { |
95 | (my $x = basename($_)) =~ s|^[0-9][0-9]-(.*)\.t$|$1|; | |
96 | print $x,"\n"; | |
97 | } | |
98 | exit 0; | |
aec27d4d | 99 | } |
90aeaf6b | 100 | if ($arg eq 'alltests') { |
1e76cb00 DDO |
101 | warn "'alltests' encountered, ignoring everything before that...\n" |
102 | unless $initial_arg; | |
103 | %tests = map { $_ => 1 } @alltests; | |
90aeaf6b | 104 | } elsif ($arg =~ m/^(-?)(.*)/) { |
1e76cb00 DDO |
105 | my $sign = $1; |
106 | my $test = $2; | |
107 | my @matches = find_matching_tests($test); | |
108 | ||
109 | # If '-foo' is the first arg, it's short for 'alltests -foo' | |
110 | if ($sign eq '-' && $initial_arg) { | |
111 | %tests = map { $_ => 1 } @alltests; | |
112 | } | |
113 | ||
114 | if (scalar @matches == 0) { | |
115 | warn "Test $test found no match, skipping ", | |
116 | ($sign eq '-' ? "removal" : "addition"), | |
117 | "...\n"; | |
118 | } else { | |
119 | foreach $test (@matches) { | |
120 | if ($sign eq '-') { | |
121 | delete $tests{$test}; | |
122 | } else { | |
123 | $tests{$test} = 1; | |
124 | } | |
125 | } | |
126 | } | |
90aeaf6b | 127 | } else { |
1e76cb00 | 128 | warn "I don't know what '$arg' is about, ignoring...\n"; |
90aeaf6b RL |
129 | } |
130 | ||
131 | $initial_arg = 0; | |
aec27d4d RL |
132 | } |
133 | ||
90aeaf6b RL |
134 | sub find_matching_tests { |
135 | my ($glob) = @_; | |
aec27d4d | 136 | |
e5fd8ca4 RL |
137 | if ($glob =~ m|^[\d\[\]\?\-]+$|) { |
138 | return glob(catfile($recipesdir,"$glob-*.t")); | |
139 | } | |
90aeaf6b | 140 | return glob(catfile($recipesdir,"*-$glob.t")); |
1780e6d9 | 141 | } |
76e0d0b2 | 142 | |
e3d9a6b5 RL |
143 | # The following is quite a bit of hackery to adapt to both TAP::Harness |
144 | # and Test::Harness, depending on what's available. | |
317ffa57 | 145 | # The TAP::Harness hack allows support for HARNESS_VERBOSE_FAILURE* and |
e3d9a6b5 RL |
146 | # HARNESS_TAP_COPY, while the Test::Harness hack can't, because the pre |
147 | # TAP::Harness Test::Harness simply doesn't have support for this sort of | |
148 | # thing. | |
149 | # | |
150 | # We use eval to avoid undue interruption if TAP::Harness isn't present. | |
151 | ||
152 | my $package; | |
153 | my $eres; | |
154 | ||
155 | $eres = eval { | |
156 | package TAP::Parser::OpenSSL; | |
c804f296 RJ |
157 | use parent -norequire, 'TAP::Parser'; |
158 | require TAP::Parser; | |
e3d9a6b5 RL |
159 | |
160 | sub new { | |
161 | my $class = shift; | |
162 | my %opts = %{ shift() }; | |
317ffa57 | 163 | my $failure_verbosity = $openssl_args{failure_verbosity}; |
317ffa57 DDO |
164 | my @plans = (); # initial level, no plan yet |
165 | my $output_buffer = ""; | |
e3d9a6b5 RL |
166 | |
167 | # We rely heavily on perl closures to make failure verbosity work | |
168 | # We need to do so, because there's no way to safely pass extra | |
169 | # objects down all the way to the TAP::Parser::Result object | |
170 | my @failure_output = (); | |
171 | my %callbacks = (); | |
317ffa57 DDO |
172 | if ($failure_verbosity > 0 || defined $openssl_args{tap_copy}) { |
173 | $callbacks{ALL} = sub { # on each line of test output | |
e3d9a6b5 RL |
174 | my $self = shift; |
175 | my $fh = $openssl_args{tap_copy}; | |
e3d9a6b5 RL |
176 | print $fh $self->as_string, "\n" |
177 | if defined $fh; | |
317ffa57 DDO |
178 | |
179 | my $failure_verbosity = $openssl_args{failure_verbosity}; | |
e4522e10 | 180 | if ($failure_verbosity > 0) { |
317ffa57 DDO |
181 | my $is_plan = $self->is_plan; |
182 | my $tests_planned = $is_plan && $self->tests_planned; | |
183 | my $is_test = $self->is_test; | |
184 | my $is_ok = $is_test && $self->is_ok; | |
93a7d241 DDO |
185 | |
186 | # workaround for parser not coping with sub-test indentation | |
317ffa57 | 187 | if ($self->is_unknown) { |
93a7d241 DDO |
188 | my $level = $#plans; |
189 | my $indent = $level < 0 ? "" : " " x ($level * 4); | |
190 | ||
317ffa57 | 191 | ($is_plan, $tests_planned) = (1, $1) |
93a7d241 | 192 | if ($self->as_string =~ m/^$indent 1\.\.(\d+)/); |
317ffa57 | 193 | ($is_test, $is_ok) = (1, !$1) |
93a7d241 | 194 | if ($self->as_string =~ m/^$indent(not )?ok /); |
317ffa57 | 195 | } |
93a7d241 | 196 | |
317ffa57 DDO |
197 | if ($is_plan) { |
198 | push @plans, $tests_planned; | |
199 | $output_buffer = ""; # ignore comments etc. until plan | |
200 | } elsif ($is_test) { # result of a test | |
201 | pop @plans if @plans && --($plans[-1]) <= 0; | |
202 | print $output_buffer if !$is_ok; | |
6bb74ecb | 203 | print "\n".$self->as_string |
317ffa57 | 204 | if !$is_ok || $failure_verbosity == 2; |
a8125491 | 205 | print "\n# ------------------------------------------------------------------------------" if !$is_ok; |
317ffa57 | 206 | $output_buffer = ""; |
6bb74ecb DDO |
207 | } elsif ($self->as_string ne "") { |
208 | # typically is_comment or is_unknown | |
209 | $output_buffer .= "\n".$self->as_string; | |
317ffa57 DDO |
210 | } |
211 | } | |
212 | } | |
e3d9a6b5 RL |
213 | } |
214 | ||
317ffa57 | 215 | if ($failure_verbosity > 0) { |
e3d9a6b5 RL |
216 | $callbacks{EOF} = sub { |
217 | my $self = shift; | |
218 | ||
219 | # We know we are a TAP::Parser::Aggregator object | |
220 | if (scalar $self->failed > 0 && @failure_output) { | |
221 | # We add an extra empty line, because in the case of a | |
222 | # progress counter, we're still at the end of that progress | |
223 | # line. | |
224 | print $_, "\n" foreach (("", @failure_output)); | |
225 | } | |
317ffa57 | 226 | # Echo any trailing comments etc. |
e4522e10 | 227 | print "$output_buffer"; |
e3d9a6b5 RL |
228 | }; |
229 | } | |
230 | ||
231 | if (keys %callbacks) { | |
232 | # If %opts already has a callbacks element, the order here | |
233 | # ensures we do not override it | |
234 | %opts = ( callbacks => { %callbacks }, %opts ); | |
235 | } | |
236 | ||
237 | return $class->SUPER::new({ %opts }); | |
238 | } | |
76e0d0b2 | 239 | |
e3d9a6b5 | 240 | package TAP::Harness::OpenSSL; |
c804f296 RJ |
241 | use parent -norequire, 'TAP::Harness'; |
242 | require TAP::Harness; | |
e3d9a6b5 RL |
243 | |
244 | package main; | |
245 | ||
246 | $tapargs{parser_class} = "TAP::Parser::OpenSSL"; | |
247 | $package = 'TAP::Harness::OpenSSL'; | |
248 | }; | |
249 | ||
250 | unless (defined $eres) { | |
251 | $eres = eval { | |
252 | # Fake TAP::Harness in case it's not loaded | |
253 | package TAP::Harness::fake; | |
254 | use parent 'Test::Harness'; | |
255 | ||
256 | sub new { | |
257 | my $class = shift; | |
258 | my %args = %{ shift() }; | |
259 | ||
260 | return bless { %args }, $class; | |
261 | } | |
262 | ||
263 | sub runtests { | |
264 | my $self = shift; | |
265 | ||
266 | # Pre TAP::Harness Test::Harness doesn't support [ filename, name ] | |
267 | # elements, so convert such elements to just be the filename | |
268 | my @args = map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @_; | |
269 | ||
270 | my @switches = (); | |
271 | if ($self->{switches}) { | |
272 | push @switches, $self->{switches}; | |
273 | } | |
274 | if ($self->{lib}) { | |
275 | foreach (@{$self->{lib}}) { | |
276 | my $l = $_; | |
277 | ||
278 | # It seems that $switches is getting interpreted with 'eval' | |
279 | # or something like that, and that we need to take care of | |
280 | # backslashes or they will disappear along the way. | |
281 | $l =~ s|\\|\\\\|g if $^O eq "MSWin32"; | |
282 | push @switches, "-I$l"; | |
283 | } | |
284 | } | |
285 | ||
286 | $Test::Harness::switches = join(' ', @switches); | |
287 | Test::Harness::runtests(@args); | |
288 | } | |
289 | ||
290 | package main; | |
291 | $package = 'TAP::Harness::fake'; | |
292 | }; | |
293 | } | |
76e0d0b2 | 294 | |
e3d9a6b5 RL |
295 | unless (defined $eres) { |
296 | print $@,"\n" if $@; | |
297 | print $!,"\n" if $!; | |
298 | exit 127; | |
76e0d0b2 RL |
299 | } |
300 | ||
e3d9a6b5 RL |
301 | my $harness = $package->new(\%tapargs); |
302 | my $ret = | |
1e76cb00 DDO |
303 | $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] } |
304 | sort { reorder($a) cmp reorder($b) } keys %tests); | |
76e0d0b2 | 305 | |
e3d9a6b5 RL |
306 | # $ret->has_errors may be any number, not just 0 or 1. On VMS, numbers |
307 | # from 2 and on are used as is as VMS statuses, which has severity encoded | |
308 | # in the lower 3 bits. 0 and 1, on the other hand, generate SUCCESS and | |
309 | # FAILURE, so for currect reporting on all platforms, we make sure the only | |
310 | # exit codes are 0 and 1. Double-bang is the trick to do so. | |
311 | exit !!$ret->has_errors if (ref($ret) eq "TAP::Parser::Aggregator"); | |
76e0d0b2 | 312 | |
e3d9a6b5 RL |
313 | # If this isn't a TAP::Parser::Aggregator, it's the pre-TAP test harness, |
314 | # which simply dies at the end if any test failed, so we don't need to bother | |
315 | # with any exit code in that case. |