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