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