run_tests.pl 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366
  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. use strict;
  9. use warnings;
  10. # Recognise VERBOSE aka V which is common on other projects.
  11. # Additionally, recognise VERBOSE_FAILURE aka VF aka REPORT_FAILURES
  12. # and recognise VERBOSE_FAILURE_PROGRESS aka VFP aka REPORT_FAILURES_PROGRESS.
  13. BEGIN {
  14. $ENV{HARNESS_VERBOSE} = "yes" if $ENV{VERBOSE} || $ENV{V};
  15. $ENV{HARNESS_VERBOSE_FAILURE} = "yes"
  16. if $ENV{VERBOSE_FAILURE} || $ENV{VF} || $ENV{REPORT_FAILURES};
  17. $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} = "yes"
  18. if ($ENV{VERBOSE_FAILURE_PROGRESS} || $ENV{VFP}
  19. || $ENV{REPORT_FAILURES_PROGRESS});
  20. }
  21. use File::Spec::Functions qw/catdir catfile curdir abs2rel rel2abs/;
  22. use File::Basename;
  23. use FindBin;
  24. use lib "$FindBin::Bin/../util/perl";
  25. use OpenSSL::Glob;
  26. my $srctop = $ENV{SRCTOP} || $ENV{TOP};
  27. my $bldtop = $ENV{BLDTOP} || $ENV{TOP};
  28. my $recipesdir = catdir($srctop, "test", "recipes");
  29. my $libdir = rel2abs(catdir($srctop, "util", "perl"));
  30. my $jobs = $ENV{HARNESS_JOBS} // 1;
  31. $ENV{OPENSSL_CONF} = rel2abs(catfile($srctop, "apps", "openssl.cnf"));
  32. $ENV{OPENSSL_CONF_INCLUDE} = rel2abs(catdir($bldtop, "test"));
  33. $ENV{OPENSSL_MODULES} = rel2abs(catdir($bldtop, "providers"));
  34. $ENV{OPENSSL_ENGINES} = rel2abs(catdir($bldtop, "engines"));
  35. $ENV{CTLOG_FILE} = rel2abs(catfile($srctop, "test", "ct", "log_list.cnf"));
  36. # On platforms that support this, this will ensure malloc returns data that is
  37. # set to a non-zero value. Can be helpful for detecting uninitialized reads in
  38. # some situations.
  39. $ENV{'MALLOC_PERTURB_'} = '128' if !defined $ENV{'MALLOC_PERTURB_'};
  40. my %tapargs =
  41. ( verbosity => $ENV{HARNESS_VERBOSE} ? 1 : 0,
  42. lib => [ $libdir ],
  43. switches => '-w',
  44. merge => 1,
  45. timer => $ENV{HARNESS_TIMER} ? 1 : 0,
  46. );
  47. if ($jobs > 1) {
  48. if ($ENV{HARNESS_VERBOSE}) {
  49. print "Warning: HARNESS_JOBS > 1 ignored with HARNESS_VERBOSE\n";
  50. } else {
  51. $tapargs{jobs} = $jobs;
  52. print "Using HARNESS_JOBS=$jobs\n";
  53. }
  54. }
  55. # Additional OpenSSL special TAP arguments. Because we can't pass them via
  56. # TAP::Harness->new(), they will be accessed directly, see the
  57. # TAP::Parser::OpenSSL implementation further down
  58. my %openssl_args = ();
  59. $openssl_args{'failure_verbosity'} = $ENV{HARNESS_VERBOSE} ? 0 :
  60. $ENV{HARNESS_VERBOSE_FAILURE_PROGRESS} ? 2 :
  61. 1; # $ENV{HARNESS_VERBOSE_FAILURE}
  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});
  67. my $outfilename = $ENV{HARNESS_TAP_COPY};
  68. open $openssl_args{'tap_copy'}, ">$outfilename"
  69. or die "Trying to create $outfilename: $!\n"
  70. if defined $outfilename;
  71. my @alltests = find_matching_tests("*");
  72. my %tests = ();
  73. sub reorder {
  74. my $key = pop;
  75. # for parallel test runs, do slow tests first
  76. if ($jobs > 1 && $key =~ m/test_ssl_new|test_fuzz/) {
  77. $key =~ s/(\d+)-/01-/;
  78. }
  79. return $key;
  80. }
  81. my $initial_arg = 1;
  82. foreach my $arg (@ARGV ? @ARGV : ('alltests')) {
  83. if ($arg eq 'list') {
  84. foreach (@alltests) {
  85. (my $x = basename($_)) =~ s|^[0-9][0-9]-(.*)\.t$|$1|;
  86. print $x,"\n";
  87. }
  88. exit 0;
  89. }
  90. if ($arg eq 'alltests') {
  91. warn "'alltests' encountered, ignoring everything before that...\n"
  92. unless $initial_arg;
  93. %tests = map { $_ => 1 } @alltests;
  94. } elsif ($arg =~ m/^(-?)(.*)/) {
  95. my $sign = $1;
  96. my $test = $2;
  97. my @matches = find_matching_tests($test);
  98. # If '-foo' is the first arg, it's short for 'alltests -foo'
  99. if ($sign eq '-' && $initial_arg) {
  100. %tests = map { $_ => 1 } @alltests;
  101. }
  102. if (scalar @matches == 0) {
  103. warn "Test $test found no match, skipping ",
  104. ($sign eq '-' ? "removal" : "addition"),
  105. "...\n";
  106. } else {
  107. foreach $test (@matches) {
  108. if ($sign eq '-') {
  109. delete $tests{$test};
  110. } else {
  111. $tests{$test} = 1;
  112. }
  113. }
  114. }
  115. } else {
  116. warn "I don't know what '$arg' is about, ignoring...\n";
  117. }
  118. $initial_arg = 0;
  119. }
  120. # prep recipes are mandatory and need to be always run first
  121. my @preps = glob(catfile($recipesdir,"00-prep_*.t"));
  122. foreach my $test (@preps) {
  123. delete $tests{$test};
  124. }
  125. sub find_matching_tests {
  126. my ($glob) = @_;
  127. if ($glob =~ m|^[\d\[\]\?\-]+$|) {
  128. return glob(catfile($recipesdir,"$glob-*.t"));
  129. }
  130. return glob(catfile($recipesdir,"*-$glob.t"));
  131. }
  132. # The following is quite a bit of hackery to adapt to both TAP::Harness
  133. # and Test::Harness, depending on what's available.
  134. # The TAP::Harness hack allows support for HARNESS_VERBOSE_FAILURE* and
  135. # HARNESS_TAP_COPY, while the Test::Harness hack can't, because the pre
  136. # TAP::Harness Test::Harness simply doesn't have support for this sort of
  137. # thing.
  138. #
  139. # We use eval to avoid undue interruption if TAP::Harness isn't present.
  140. my $package;
  141. my $eres;
  142. $eres = eval {
  143. package TAP::Parser::OpenSSL;
  144. use parent -norequire, 'TAP::Parser';
  145. require TAP::Parser;
  146. sub new {
  147. my $class = shift;
  148. my %opts = %{ shift() };
  149. my $failure_verbosity = $openssl_args{failure_verbosity};
  150. my @plans = (); # initial level, no plan yet
  151. my $output_buffer = "";
  152. my $in_indirect = 0;
  153. # We rely heavily on perl closures to make failure verbosity work
  154. # We need to do so, because there's no way to safely pass extra
  155. # objects down all the way to the TAP::Parser::Result object
  156. my @failure_output = ();
  157. my %callbacks = ();
  158. if ($failure_verbosity > 0 || defined $openssl_args{tap_copy}) {
  159. $callbacks{ALL} = sub { # on each line of test output
  160. my $self = shift;
  161. my $fh = $openssl_args{tap_copy};
  162. print $fh $self->as_string, "\n"
  163. if defined $fh;
  164. my $failure_verbosity = $openssl_args{failure_verbosity};
  165. if ($failure_verbosity > 0) {
  166. my $is_plan = $self->is_plan;
  167. my $tests_planned = $is_plan && $self->tests_planned;
  168. my $is_test = $self->is_test;
  169. my $is_ok = $is_test && $self->is_ok;
  170. # workaround for parser not coping with sub-test indentation
  171. if ($self->is_unknown) {
  172. my $level = $#plans;
  173. my $indent = $level < 0 ? "" : " " x ($level * 4);
  174. ($is_plan, $tests_planned) = (1, $1)
  175. if ($self->as_string =~ m/^$indent 1\.\.(\d+)/);
  176. ($is_test, $is_ok) = (1, !$1)
  177. if ($self->as_string =~ m/^$indent(not )?ok /);
  178. }
  179. if ($is_plan) {
  180. push @plans, $tests_planned;
  181. $output_buffer = ""; # ignore comments etc. until plan
  182. } elsif ($is_test) { # result of a test
  183. pop @plans if @plans && --($plans[-1]) <= 0;
  184. if ($output_buffer =~ /.*Indirect leak of.*/ == 1) {
  185. my @asan_array = split("\n", $output_buffer);
  186. foreach (@asan_array) {
  187. if ($_ =~ /.*Indirect leak of.*/ == 1) {
  188. if ($in_indirect != 1) {
  189. print "::group::Indirect Leaks\n";
  190. }
  191. $in_indirect = 1;
  192. }
  193. print "$_\n";
  194. if ($_ =~ /.*Indirect leak of.*/ != 1) {
  195. if ($_ =~ /^ #.*/ == 0) {
  196. if ($in_indirect != 0) {
  197. print "\n::endgroup::\n";
  198. }
  199. $in_indirect = 0;
  200. }
  201. }
  202. }
  203. } else {
  204. print $output_buffer if !$is_ok;
  205. }
  206. print "\n".$self->as_string
  207. if !$is_ok || $failure_verbosity == 2;
  208. print "\n# ------------------------------------------------------------------------------" if !$is_ok;
  209. $output_buffer = "";
  210. } elsif ($self->as_string ne "") {
  211. # typically is_comment or is_unknown
  212. $output_buffer .= "\n".$self->as_string;
  213. }
  214. }
  215. }
  216. }
  217. if ($failure_verbosity > 0) {
  218. $callbacks{EOF} = sub {
  219. my $self = shift;
  220. # We know we are a TAP::Parser::Aggregator object
  221. if (scalar $self->failed > 0 && @failure_output) {
  222. # We add an extra empty line, because in the case of a
  223. # progress counter, we're still at the end of that progress
  224. # line.
  225. print $_, "\n" foreach (("", @failure_output));
  226. }
  227. # Echo any trailing comments etc.
  228. print "$output_buffer";
  229. };
  230. }
  231. if (keys %callbacks) {
  232. # If %opts already has a callbacks element, the order here
  233. # ensures we do not override it
  234. %opts = ( callbacks => { %callbacks }, %opts );
  235. }
  236. return $class->SUPER::new({ %opts });
  237. }
  238. package TAP::Harness::OpenSSL;
  239. use parent -norequire, 'TAP::Harness';
  240. require TAP::Harness;
  241. package main;
  242. $tapargs{parser_class} = "TAP::Parser::OpenSSL";
  243. $package = 'TAP::Harness::OpenSSL';
  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. sub new {
  251. my $class = shift;
  252. my %args = %{ shift() };
  253. return bless { %args }, $class;
  254. }
  255. sub runtests {
  256. my $self = shift;
  257. # Pre TAP::Harness Test::Harness doesn't support [ filename, name ]
  258. # elements, so convert such elements to just be the filename
  259. my @args = map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @_;
  260. my @switches = ();
  261. if ($self->{switches}) {
  262. push @switches, $self->{switches};
  263. }
  264. if ($self->{lib}) {
  265. foreach (@{$self->{lib}}) {
  266. my $l = $_;
  267. # It seems that $switches is getting interpreted with 'eval'
  268. # or something like that, and that we need to take care of
  269. # backslashes or they will disappear along the way.
  270. $l =~ s|\\|\\\\|g if $^O eq "MSWin32";
  271. push @switches, "-I$l";
  272. }
  273. }
  274. $Test::Harness::switches = join(' ', @switches);
  275. Test::Harness::runtests(@args);
  276. }
  277. package main;
  278. $package = 'TAP::Harness::fake';
  279. };
  280. }
  281. unless (defined $eres) {
  282. print $@,"\n" if $@;
  283. print $!,"\n" if $!;
  284. exit 127;
  285. }
  286. my $harness = $package->new(\%tapargs);
  287. my $ret =
  288. $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] }
  289. @preps);
  290. if (ref($ret) ne "TAP::Parser::Aggregator" || !$ret->has_errors) {
  291. $ret =
  292. $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] }
  293. sort { reorder($a) cmp reorder($b) } keys %tests);
  294. }
  295. # If this is a TAP::Parser::Aggregator, $ret->has_errors is the count of
  296. # tests that failed. We don't bother with that exact number, just exit
  297. # with an appropriate exit code when it isn't zero.
  298. if (ref($ret) eq "TAP::Parser::Aggregator") {
  299. exit 0 unless $ret->has_errors;
  300. exit 1 unless $^O eq 'VMS';
  301. # On VMS, perl converts an exit 1 to SS$_ABORT (%SYSTEM-F-ABORT), which
  302. # is a bit harsh. As per perl recommendations, we explicitly use the
  303. # same VMS status code as typical C programs would for exit(1), except
  304. # we set the error severity rather than success.
  305. # Ref: https://perldoc.perl.org/perlport#exit
  306. # https://perldoc.perl.org/perlvms#$?
  307. exit 0x35a000 # C facility code
  308. + 8 # 1 << 3 (to make space for the 3 severity bits)
  309. + 2 # severity: E(rror)
  310. + 0x10000000; # bit 28 set => the shell stays silent
  311. }
  312. # If this isn't a TAP::Parser::Aggregator, it's the pre-TAP test harness,
  313. # which simply dies at the end if any test failed, so we don't need to bother
  314. # with any exit code in that case.