]>
Commit | Line | Data |
---|---|---|
e0a65194 | 1 | #! /usr/bin/env perl |
6ec5fce2 | 2 | # Copyright 2015-2018 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 | ||
be6bdab6 | 12 | # Recognise VERBOSE and V which is common on other projects. |
e3d9a6b5 | 13 | # Additionally, also recognise VERBOSE_FAILURE and VF. |
be6bdab6 DSH |
14 | BEGIN { |
15 | $ENV{HARNESS_VERBOSE} = "yes" if $ENV{VERBOSE} || $ENV{V}; | |
e3d9a6b5 | 16 | $ENV{HARNESS_VERBOSE_FAILURE} = "yes" if $ENV{VERBOSE_FAILURE} || $ENV{VF}; |
be6bdab6 DSH |
17 | } |
18 | ||
aec27d4d RL |
19 | use File::Spec::Functions qw/catdir catfile curdir abs2rel rel2abs/; |
20 | use File::Basename; | |
8d2214c0 RL |
21 | use FindBin; |
22 | use lib "$FindBin::Bin/../util/perl"; | |
23 | use OpenSSL::Glob; | |
76e0d0b2 | 24 | |
42e0ccdf RL |
25 | my $srctop = $ENV{SRCTOP} || $ENV{TOP}; |
26 | my $bldtop = $ENV{BLDTOP} || $ENV{TOP}; | |
27 | my $recipesdir = catdir($srctop, "test", "recipes"); | |
cb6afcd6 | 28 | my $libdir = rel2abs(catdir($srctop, "util", "perl")); |
aec27d4d | 29 | |
d1ae34e9 KR |
30 | $ENV{OPENSSL_CONF} = catdir($srctop, "apps", "openssl.cnf"); |
31 | ||
76e0d0b2 | 32 | my %tapargs = |
e3d9a6b5 RL |
33 | ( verbosity => $ENV{HARNESS_VERBOSE} ? 1 : 0, |
34 | lib => [ $libdir ], | |
35 | switches => '-w', | |
36 | merge => 1, | |
76e0d0b2 | 37 | ); |
aec27d4d | 38 | |
e3d9a6b5 RL |
39 | # Additional OpenSSL special TAP arguments. Because we can't pass them via |
40 | # TAP::Harness->new(), they will be accessed directly, see the | |
41 | # TAP::Parser::OpenSSL implementation further down | |
42 | my %openssl_args = (); | |
43 | ||
44 | $openssl_args{'failure_verbosity'} = | |
45 | $ENV{HARNESS_VERBOSE_FAILURE} && $tapargs{verbosity} < 1 ? 1 : 0; | |
46 | ||
47 | my $outfilename = $ENV{HARNESS_TAP_COPY}; | |
48 | open $openssl_args{'tap_copy'}, ">$outfilename" | |
49 | or die "Trying to create $outfilename: $!\n" | |
50 | if defined $outfilename; | |
51 | ||
90aeaf6b RL |
52 | my @alltests = find_matching_tests("*"); |
53 | my %tests = (); | |
54 | ||
55 | my $initial_arg = 1; | |
56 | foreach my $arg (@ARGV ? @ARGV : ('alltests')) { | |
57 | if ($arg eq 'list') { | |
58 | foreach (@alltests) { | |
59 | (my $x = basename($_)) =~ s|^[0-9][0-9]-(.*)\.t$|$1|; | |
60 | print $x,"\n"; | |
61 | } | |
62 | exit 0; | |
aec27d4d | 63 | } |
90aeaf6b RL |
64 | if ($arg eq 'alltests') { |
65 | warn "'alltests' encountered, ignoring everything before that...\n" | |
66 | unless $initial_arg; | |
e3d9a6b5 | 67 | %tests = map { $_ => basename($_) } @alltests; |
90aeaf6b RL |
68 | } elsif ($arg =~ m/^(-?)(.*)/) { |
69 | my $sign = $1; | |
70 | my $test = $2; | |
71 | my @matches = find_matching_tests($test); | |
72 | ||
73 | # If '-foo' is the first arg, it's short for 'alltests -foo' | |
74 | if ($sign eq '-' && $initial_arg) { | |
e3d9a6b5 | 75 | %tests = map { $_ => basename($_) } @alltests; |
90aeaf6b RL |
76 | } |
77 | ||
78 | if (scalar @matches == 0) { | |
79 | warn "Test $test found no match, skipping ", | |
80 | ($sign eq '-' ? "removal" : "addition"), | |
81 | "...\n"; | |
82 | } else { | |
83 | foreach $test (@matches) { | |
84 | if ($sign eq '-') { | |
85 | delete $tests{$test}; | |
86 | } else { | |
e3d9a6b5 | 87 | $tests{$test} = basename($test); |
90aeaf6b RL |
88 | } |
89 | } | |
90 | } | |
91 | } else { | |
92 | warn "I don't know what '$arg' is about, ignoring...\n"; | |
93 | } | |
94 | ||
95 | $initial_arg = 0; | |
aec27d4d RL |
96 | } |
97 | ||
90aeaf6b RL |
98 | sub find_matching_tests { |
99 | my ($glob) = @_; | |
aec27d4d | 100 | |
e5fd8ca4 RL |
101 | if ($glob =~ m|^[\d\[\]\?\-]+$|) { |
102 | return glob(catfile($recipesdir,"$glob-*.t")); | |
103 | } | |
90aeaf6b | 104 | return glob(catfile($recipesdir,"*-$glob.t")); |
1780e6d9 | 105 | } |
76e0d0b2 | 106 | |
e3d9a6b5 RL |
107 | # The following is quite a bit of hackery to adapt to both TAP::Harness |
108 | # and Test::Harness, depending on what's available. | |
109 | # The TAP::Harness hack allows support for HARNESS_VERBOSE_FAILURE and | |
110 | # HARNESS_TAP_COPY, while the Test::Harness hack can't, because the pre | |
111 | # TAP::Harness Test::Harness simply doesn't have support for this sort of | |
112 | # thing. | |
113 | # | |
114 | # We use eval to avoid undue interruption if TAP::Harness isn't present. | |
115 | ||
116 | my $package; | |
117 | my $eres; | |
118 | ||
119 | $eres = eval { | |
120 | package TAP::Parser::OpenSSL; | |
121 | use parent 'TAP::Parser'; | |
122 | ||
123 | sub new { | |
124 | my $class = shift; | |
125 | my %opts = %{ shift() }; | |
126 | ||
127 | # We rely heavily on perl closures to make failure verbosity work | |
128 | # We need to do so, because there's no way to safely pass extra | |
129 | # objects down all the way to the TAP::Parser::Result object | |
130 | my @failure_output = (); | |
131 | my %callbacks = (); | |
132 | if ($openssl_args{failure_verbosity} | |
133 | || defined $openssl_args{tap_copy}) { | |
134 | $callbacks{ALL} = sub { | |
135 | my $self = shift; | |
136 | my $fh = $openssl_args{tap_copy}; | |
137 | ||
138 | print $fh $self->as_string, "\n" | |
139 | if defined $fh; | |
140 | push @failure_output, $self->as_string | |
141 | if $openssl_args{failure_verbosity} > 0; | |
142 | }; | |
143 | } | |
144 | ||
145 | if ($openssl_args{failure_verbosity} > 0) { | |
146 | $callbacks{EOF} = sub { | |
147 | my $self = shift; | |
148 | ||
149 | # We know we are a TAP::Parser::Aggregator object | |
150 | if (scalar $self->failed > 0 && @failure_output) { | |
151 | # We add an extra empty line, because in the case of a | |
152 | # progress counter, we're still at the end of that progress | |
153 | # line. | |
154 | print $_, "\n" foreach (("", @failure_output)); | |
155 | } | |
156 | }; | |
157 | } | |
158 | ||
159 | if (keys %callbacks) { | |
160 | # If %opts already has a callbacks element, the order here | |
161 | # ensures we do not override it | |
162 | %opts = ( callbacks => { %callbacks }, %opts ); | |
163 | } | |
164 | ||
165 | return $class->SUPER::new({ %opts }); | |
166 | } | |
76e0d0b2 | 167 | |
e3d9a6b5 RL |
168 | package TAP::Harness::OpenSSL; |
169 | use parent 'TAP::Harness'; | |
170 | ||
171 | package main; | |
172 | ||
173 | $tapargs{parser_class} = "TAP::Parser::OpenSSL"; | |
174 | $package = 'TAP::Harness::OpenSSL'; | |
175 | }; | |
176 | ||
177 | unless (defined $eres) { | |
178 | $eres = eval { | |
179 | # Fake TAP::Harness in case it's not loaded | |
180 | package TAP::Harness::fake; | |
181 | use parent 'Test::Harness'; | |
182 | ||
183 | sub new { | |
184 | my $class = shift; | |
185 | my %args = %{ shift() }; | |
186 | ||
187 | return bless { %args }, $class; | |
188 | } | |
189 | ||
190 | sub runtests { | |
191 | my $self = shift; | |
192 | ||
193 | # Pre TAP::Harness Test::Harness doesn't support [ filename, name ] | |
194 | # elements, so convert such elements to just be the filename | |
195 | my @args = map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @_; | |
196 | ||
197 | my @switches = (); | |
198 | if ($self->{switches}) { | |
199 | push @switches, $self->{switches}; | |
200 | } | |
201 | if ($self->{lib}) { | |
202 | foreach (@{$self->{lib}}) { | |
203 | my $l = $_; | |
204 | ||
205 | # It seems that $switches is getting interpreted with 'eval' | |
206 | # or something like that, and that we need to take care of | |
207 | # backslashes or they will disappear along the way. | |
208 | $l =~ s|\\|\\\\|g if $^O eq "MSWin32"; | |
209 | push @switches, "-I$l"; | |
210 | } | |
211 | } | |
212 | ||
213 | $Test::Harness::switches = join(' ', @switches); | |
214 | Test::Harness::runtests(@args); | |
215 | } | |
216 | ||
217 | package main; | |
218 | $package = 'TAP::Harness::fake'; | |
219 | }; | |
220 | } | |
76e0d0b2 | 221 | |
e3d9a6b5 RL |
222 | unless (defined $eres) { |
223 | print $@,"\n" if $@; | |
224 | print $!,"\n" if $!; | |
225 | exit 127; | |
76e0d0b2 RL |
226 | } |
227 | ||
e3d9a6b5 RL |
228 | my $harness = $package->new(\%tapargs); |
229 | my $ret = | |
230 | $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), $tests{$_} ] } | |
231 | sort keys %tests); | |
76e0d0b2 | 232 | |
e3d9a6b5 RL |
233 | # $ret->has_errors may be any number, not just 0 or 1. On VMS, numbers |
234 | # from 2 and on are used as is as VMS statuses, which has severity encoded | |
235 | # in the lower 3 bits. 0 and 1, on the other hand, generate SUCCESS and | |
236 | # FAILURE, so for currect reporting on all platforms, we make sure the only | |
237 | # exit codes are 0 and 1. Double-bang is the trick to do so. | |
238 | exit !!$ret->has_errors if (ref($ret) eq "TAP::Parser::Aggregator"); | |
76e0d0b2 | 239 | |
e3d9a6b5 RL |
240 | # If this isn't a TAP::Parser::Aggregator, it's the pre-TAP test harness, |
241 | # which simply dies at the end if any test failed, so we don't need to bother | |
242 | # with any exit code in that case. |