1#! /usr/bin/env perl 2# Copyright 2015-2022 The OpenSSL Project Authors. All Rights Reserved. 3# 4# Licensed under the Apache License 2.0 (the "License"). You may not use 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 8 9use strict; 10use warnings; 11 12# Recognise VERBOSE aka V which is common on other projects. 13# Additionally, recognise VERBOSE_FAILURE aka VF aka REPORT_FAILURES 14# and recognise VERBOSE_FAILURE_PROGRESS aka VFP aka REPORT_FAILURES_PROGRESS. 15BEGIN { 16 $ENV{HARNESS_VERBOSE} = "yes" if $ENV{VERBOSE} || $ENV{V}; 17 $ENV{HARNESS_VERBOSE_FAILURE} = "yes" 18 if $ENV{VERBOSE_FAILURE} || $ENV{VF} || $ENV{REPORT_FAILURES}; 19 $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} = "yes" 20 if ($ENV{VERBOSE_FAILURE_PROGRESS} || $ENV{VFP} 21 || $ENV{REPORT_FAILURES_PROGRESS}); 22} 23 24use File::Spec::Functions qw/catdir catfile curdir abs2rel rel2abs/; 25use File::Basename; 26use FindBin; 27use lib "$FindBin::Bin/../util/perl"; 28use OpenSSL::Glob; 29 30my $srctop = $ENV{SRCTOP} || $ENV{TOP}; 31my $bldtop = $ENV{BLDTOP} || $ENV{TOP}; 32my $recipesdir = catdir($srctop, "test", "recipes"); 33my $libdir = rel2abs(catdir($srctop, "util", "perl")); 34my $jobs = $ENV{HARNESS_JOBS} // 1; 35 36$ENV{OPENSSL_CONF} = rel2abs(catfile($srctop, "apps", "openssl.cnf")); 37$ENV{OPENSSL_CONF_INCLUDE} = rel2abs(catdir($bldtop, "test")); 38$ENV{OPENSSL_MODULES} = rel2abs(catdir($bldtop, "providers")); 39$ENV{OPENSSL_ENGINES} = rel2abs(catdir($bldtop, "engines")); 40$ENV{CTLOG_FILE} = rel2abs(catfile($srctop, "test", "ct", "log_list.cnf")); 41 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 47my %tapargs = 48 ( verbosity => $ENV{HARNESS_VERBOSE} ? 1 : 0, 49 lib => [ $libdir ], 50 switches => '-w', 51 merge => 1, 52 timer => $ENV{HARNESS_TIMER} ? 1 : 0, 53 ); 54 55if ($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} 63 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 67my %openssl_args = (); 68 69$openssl_args{'failure_verbosity'} = $ENV{HARNESS_VERBOSE} ? 0 : 70 $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} ? 2 : 71 1; # $ENV{HARNESS_VERBOSE_FAILURE} 72print "Warning: HARNESS_VERBOSE overrides HARNESS_VERBOSE_FAILURE*\n" 73 if ($ENV{HARNESS_VERBOSE} && ($ENV{HARNESS_VERBOSE_FAILURE} 74 || $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS})); 75print "Warning: HARNESS_VERBOSE_FAILURE_PROGRESS overrides HARNESS_VERBOSE_FAILURE\n" 76 if ($ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} && $ENV{HARNESS_VERBOSE_FAILURE}); 77 78my $outfilename = $ENV{HARNESS_TAP_COPY}; 79open $openssl_args{'tap_copy'}, ">$outfilename" 80 or die "Trying to create $outfilename: $!\n" 81 if defined $outfilename; 82 83my @alltests = find_matching_tests("*"); 84my %tests = (); 85 86sub reorder { 87 my $key = pop; 88 89 # for parallel test runs, do slow tests first 90 if ($jobs > 1 && $key =~ m/test_ssl_new|test_fuzz/) { 91 $key =~ s/(\d+)-/01-/; 92 } 93 return $key; 94} 95 96my $initial_arg = 1; 97foreach my $arg (@ARGV ? @ARGV : ('alltests')) { 98 if ($arg eq 'list') { 99 foreach (@alltests) { 100 (my $x = basename($_)) =~ s|^[0-9][0-9]-(.*)\.t$|$1|; 101 print $x,"\n"; 102 } 103 exit 0; 104 } 105 if ($arg eq 'alltests') { 106 warn "'alltests' encountered, ignoring everything before that...\n" 107 unless $initial_arg; 108 %tests = map { $_ => 1 } @alltests; 109 } elsif ($arg =~ m/^(-?)(.*)/) { 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 } 132 } else { 133 warn "I don't know what '$arg' is about, ignoring...\n"; 134 } 135 136 $initial_arg = 0; 137} 138 139# prep recipes are mandatory and need to be always run first 140my @preps = glob(catfile($recipesdir,"00-prep_*.t")); 141foreach my $test (@preps) { 142 delete $tests{$test}; 143} 144 145sub find_matching_tests { 146 my ($glob) = @_; 147 148 if ($glob =~ m|^[\d\[\]\?\-]+$|) { 149 return glob(catfile($recipesdir,"$glob-*.t")); 150 } 151 152 return glob(catfile($recipesdir,"*-$glob.t")); 153} 154 155# The following is quite a bit of hackery to adapt to both TAP::Harness 156# and Test::Harness, depending on what's available. 157# The TAP::Harness hack allows support for HARNESS_VERBOSE_FAILURE* and 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 164my $package; 165my $eres; 166 167$eres = eval { 168 package TAP::Parser::OpenSSL; 169 use parent -norequire, 'TAP::Parser'; 170 require TAP::Parser; 171 172 sub new { 173 my $class = shift; 174 my %opts = %{ shift() }; 175 my $failure_verbosity = $openssl_args{failure_verbosity}; 176 my @plans = (); # initial level, no plan yet 177 my $output_buffer = ""; 178 my $in_indirect = 0; 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 = (); 185 if ($failure_verbosity > 0 || defined $openssl_args{tap_copy}) { 186 $callbacks{ALL} = sub { # on each line of test output 187 my $self = shift; 188 my $fh = $openssl_args{tap_copy}; 189 print $fh $self->as_string, "\n" 190 if defined $fh; 191 192 my $failure_verbosity = $openssl_args{failure_verbosity}; 193 if ($failure_verbosity > 0) { 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; 198 199 # workaround for parser not coping with sub-test indentation 200 if ($self->is_unknown) { 201 my $level = $#plans; 202 my $indent = $level < 0 ? "" : " " x ($level * 4); 203 204 ($is_plan, $tests_planned) = (1, $1) 205 if ($self->as_string =~ m/^$indent 1\.\.(\d+)/); 206 ($is_test, $is_ok) = (1, !$1) 207 if ($self->as_string =~ m/^$indent(not )?ok /); 208 } 209 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; 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) { 219 if ($in_indirect != 1) { 220 print "::group::Indirect Leaks\n"; 221 } 222 $in_indirect = 1; 223 } 224 print "$_\n"; 225 if ($_ =~ /.*Indirect leak of.*/ != 1) { 226 if ($_ =~ /^ #.*/ == 0) { 227 if ($in_indirect != 0) { 228 print "\n::endgroup::\n"; 229 } 230 $in_indirect = 0; 231 } 232 } 233 } 234 } else { 235 print $output_buffer if !$is_ok; 236 } 237 print "\n".$self->as_string 238 if !$is_ok || $failure_verbosity == 2; 239 print "\n# ------------------------------------------------------------------------------" if !$is_ok; 240 $output_buffer = ""; 241 } elsif ($self->as_string ne "") { 242 # typically is_comment or is_unknown 243 $output_buffer .= "\n".$self->as_string; 244 } 245 } 246 } 247 } 248 249 if ($failure_verbosity > 0) { 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 } 260 # Echo any trailing comments etc. 261 print "$output_buffer"; 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 } 273 274 package TAP::Harness::OpenSSL; 275 use parent -norequire, 'TAP::Harness'; 276 require TAP::Harness; 277 278 package main; 279 280 $tapargs{parser_class} = "TAP::Parser::OpenSSL"; 281 $package = 'TAP::Harness::OpenSSL'; 282}; 283 284unless (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} 328 329unless (defined $eres) { 330 print $@,"\n" if $@; 331 print $!,"\n" if $!; 332 exit 127; 333} 334 335my $harness = $package->new(\%tapargs); 336my $ret = 337 $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] } 338 @preps); 339 340if (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} 345 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. 349if (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} 363 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. 367
