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 42my %tapargs = 43 ( verbosity => $ENV{HARNESS_VERBOSE} ? 1 : 0, 44 lib => [ $libdir ], 45 switches => '-w', 46 merge => 1, 47 timer => $ENV{HARNESS_TIMER} ? 1 : 0, 48 ); 49 50if ($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} 58 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 62my %openssl_args = (); 63 64$openssl_args{'failure_verbosity'} = $ENV{HARNESS_VERBOSE} ? 0 : 65 $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} ? 2 : 66 1; # $ENV{HARNESS_VERBOSE_FAILURE} 67print "Warning: HARNESS_VERBOSE overrides HARNESS_VERBOSE_FAILURE*\n" 68 if ($ENV{HARNESS_VERBOSE} && ($ENV{HARNESS_VERBOSE_FAILURE} 69 || $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS})); 70print "Warning: HARNESS_VERBOSE_FAILURE_PROGRESS overrides HARNESS_VERBOSE_FAILURE\n" 71 if ($ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} && $ENV{HARNESS_VERBOSE_FAILURE}); 72 73my $outfilename = $ENV{HARNESS_TAP_COPY}; 74open $openssl_args{'tap_copy'}, ">$outfilename" 75 or die "Trying to create $outfilename: $!\n" 76 if defined $outfilename; 77 78my @alltests = find_matching_tests("*"); 79my %tests = (); 80 81sub reorder { 82 my $key = pop; 83 84 # for parallel test runs, do slow tests first 85 if ($jobs > 1 && $key =~ m/test_ssl_new|test_fuzz/) { 86 $key =~ s/(\d+)-/01-/; 87 } 88 return $key; 89} 90 91my $initial_arg = 1; 92foreach my $arg (@ARGV ? @ARGV : ('alltests')) { 93 if ($arg eq 'list') { 94 foreach (@alltests) { 95 (my $x = basename($_)) =~ s|^[0-9][0-9]-(.*)\.t$|$1|; 96 print $x,"\n"; 97 } 98 exit 0; 99 } 100 if ($arg eq 'alltests') { 101 warn "'alltests' encountered, ignoring everything before that...\n" 102 unless $initial_arg; 103 %tests = map { $_ => 1 } @alltests; 104 } elsif ($arg =~ m/^(-?)(.*)/) { 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 } 127 } else { 128 warn "I don't know what '$arg' is about, ignoring...\n"; 129 } 130 131 $initial_arg = 0; 132} 133 134# prep recipes are mandatory and need to be always run first 135my @preps = glob(catfile($recipesdir,"00-prep_*.t")); 136foreach my $test (@preps) { 137 delete $tests{$test}; 138} 139 140sub find_matching_tests { 141 my ($glob) = @_; 142 143 if ($glob =~ m|^[\d\[\]\?\-]+$|) { 144 return glob(catfile($recipesdir,"$glob-*.t")); 145 } 146 147 return glob(catfile($recipesdir,"*-$glob.t")); 148} 149 150# The following is quite a bit of hackery to adapt to both TAP::Harness 151# and Test::Harness, depending on what's available. 152# The TAP::Harness hack allows support for HARNESS_VERBOSE_FAILURE* and 153# HARNESS_TAP_COPY, while the Test::Harness hack can't, because the pre 154# TAP::Harness Test::Harness simply doesn't have support for this sort of 155# thing. 156# 157# We use eval to avoid undue interruption if TAP::Harness isn't present. 158 159my $package; 160my $eres; 161 162$eres = eval { 163 package TAP::Parser::OpenSSL; 164 use parent -norequire, 'TAP::Parser'; 165 require TAP::Parser; 166 167 sub new { 168 my $class = shift; 169 my %opts = %{ shift() }; 170 my $failure_verbosity = $openssl_args{failure_verbosity}; 171 my @plans = (); # initial level, no plan yet 172 my $output_buffer = ""; 173 174 # We rely heavily on perl closures to make failure verbosity work 175 # We need to do so, because there's no way to safely pass extra 176 # objects down all the way to the TAP::Parser::Result object 177 my @failure_output = (); 178 my %callbacks = (); 179 if ($failure_verbosity > 0 || defined $openssl_args{tap_copy}) { 180 $callbacks{ALL} = sub { # on each line of test output 181 my $self = shift; 182 my $fh = $openssl_args{tap_copy}; 183 print $fh $self->as_string, "\n" 184 if defined $fh; 185 186 my $failure_verbosity = $openssl_args{failure_verbosity}; 187 if ($failure_verbosity > 0) { 188 my $is_plan = $self->is_plan; 189 my $tests_planned = $is_plan && $self->tests_planned; 190 my $is_test = $self->is_test; 191 my $is_ok = $is_test && $self->is_ok; 192 193 # workaround for parser not coping with sub-test indentation 194 if ($self->is_unknown) { 195 my $level = $#plans; 196 my $indent = $level < 0 ? "" : " " x ($level * 4); 197 198 ($is_plan, $tests_planned) = (1, $1) 199 if ($self->as_string =~ m/^$indent 1\.\.(\d+)/); 200 ($is_test, $is_ok) = (1, !$1) 201 if ($self->as_string =~ m/^$indent(not )?ok /); 202 } 203 204 if ($is_plan) { 205 push @plans, $tests_planned; 206 $output_buffer = ""; # ignore comments etc. until plan 207 } elsif ($is_test) { # result of a test 208 pop @plans if @plans && --($plans[-1]) <= 0; 209 print $output_buffer if !$is_ok; 210 print "\n".$self->as_string 211 if !$is_ok || $failure_verbosity == 2; 212 print "\n# ------------------------------------------------------------------------------" if !$is_ok; 213 $output_buffer = ""; 214 } elsif ($self->as_string ne "") { 215 # typically is_comment or is_unknown 216 $output_buffer .= "\n".$self->as_string; 217 } 218 } 219 } 220 } 221 222 if ($failure_verbosity > 0) { 223 $callbacks{EOF} = sub { 224 my $self = shift; 225 226 # We know we are a TAP::Parser::Aggregator object 227 if (scalar $self->failed > 0 && @failure_output) { 228 # We add an extra empty line, because in the case of a 229 # progress counter, we're still at the end of that progress 230 # line. 231 print $_, "\n" foreach (("", @failure_output)); 232 } 233 # Echo any trailing comments etc. 234 print "$output_buffer"; 235 }; 236 } 237 238 if (keys %callbacks) { 239 # If %opts already has a callbacks element, the order here 240 # ensures we do not override it 241 %opts = ( callbacks => { %callbacks }, %opts ); 242 } 243 244 return $class->SUPER::new({ %opts }); 245 } 246 247 package TAP::Harness::OpenSSL; 248 use parent -norequire, 'TAP::Harness'; 249 require TAP::Harness; 250 251 package main; 252 253 $tapargs{parser_class} = "TAP::Parser::OpenSSL"; 254 $package = 'TAP::Harness::OpenSSL'; 255}; 256 257unless (defined $eres) { 258 $eres = eval { 259 # Fake TAP::Harness in case it's not loaded 260 package TAP::Harness::fake; 261 use parent 'Test::Harness'; 262 263 sub new { 264 my $class = shift; 265 my %args = %{ shift() }; 266 267 return bless { %args }, $class; 268 } 269 270 sub runtests { 271 my $self = shift; 272 273 # Pre TAP::Harness Test::Harness doesn't support [ filename, name ] 274 # elements, so convert such elements to just be the filename 275 my @args = map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @_; 276 277 my @switches = (); 278 if ($self->{switches}) { 279 push @switches, $self->{switches}; 280 } 281 if ($self->{lib}) { 282 foreach (@{$self->{lib}}) { 283 my $l = $_; 284 285 # It seems that $switches is getting interpreted with 'eval' 286 # or something like that, and that we need to take care of 287 # backslashes or they will disappear along the way. 288 $l =~ s|\\|\\\\|g if $^O eq "MSWin32"; 289 push @switches, "-I$l"; 290 } 291 } 292 293 $Test::Harness::switches = join(' ', @switches); 294 Test::Harness::runtests(@args); 295 } 296 297 package main; 298 $package = 'TAP::Harness::fake'; 299 }; 300} 301 302unless (defined $eres) { 303 print $@,"\n" if $@; 304 print $!,"\n" if $!; 305 exit 127; 306} 307 308my $harness = $package->new(\%tapargs); 309my $ret = 310 $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] } 311 @preps); 312 313if (ref($ret) ne "TAP::Parser::Aggregator" || !$ret->has_errors) { 314 $ret = 315 $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] } 316 sort { reorder($a) cmp reorder($b) } keys %tests); 317} 318 319# If this is a TAP::Parser::Aggregator, $ret->has_errors is the count of 320# tests that failed. We don't bother with that exact number, just exit 321# with an appropriate exit code when it isn't zero. 322if (ref($ret) eq "TAP::Parser::Aggregator") { 323 exit 0 unless $ret->has_errors; 324 exit 1 unless $^O eq 'VMS'; 325 # On VMS, perl converts an exit 1 to SS$_ABORT (%SYSTEM-F-ABORT), which 326 # is a bit harsh. As per perl recommendations, we explicitly use the 327 # same VMS status code as typical C programs would for exit(1), except 328 # we set the error severity rather than success. 329 # Ref: https://perldoc.perl.org/perlport#exit 330 # https://perldoc.perl.org/perlvms#$? 331 exit 0x35a000 # C facility code 332 + 8 # 1 << 3 (to make space for the 3 severity bits) 333 + 2 # severity: E(rror) 334 + 0x10000000; # bit 28 set => the shell stays silent 335} 336 337# If this isn't a TAP::Parser::Aggregator, it's the pre-TAP test harness, 338# which simply dies at the end if any test failed, so we don't need to bother 339# with any exit code in that case. 340