run_tests.pl 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344
  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. # We rely heavily on perl closures to make failure verbosity work
  153. # We need to do so, because there's no way to safely pass extra
  154. # objects down all the way to the TAP::Parser::Result object
  155. my @failure_output = ();
  156. my %callbacks = ();
  157. if ($failure_verbosity > 0 || defined $openssl_args{tap_copy}) {
  158. $callbacks{ALL} = sub { # on each line of test output
  159. my $self = shift;
  160. my $fh = $openssl_args{tap_copy};
  161. print $fh $self->as_string, "\n"
  162. if defined $fh;
  163. my $failure_verbosity = $openssl_args{failure_verbosity};
  164. if ($failure_verbosity > 0) {
  165. my $is_plan = $self->is_plan;
  166. my $tests_planned = $is_plan && $self->tests_planned;
  167. my $is_test = $self->is_test;
  168. my $is_ok = $is_test && $self->is_ok;
  169. # workaround for parser not coping with sub-test indentation
  170. if ($self->is_unknown) {
  171. my $level = $#plans;
  172. my $indent = $level < 0 ? "" : " " x ($level * 4);
  173. ($is_plan, $tests_planned) = (1, $1)
  174. if ($self->as_string =~ m/^$indent 1\.\.(\d+)/);
  175. ($is_test, $is_ok) = (1, !$1)
  176. if ($self->as_string =~ m/^$indent(not )?ok /);
  177. }
  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;
  184. print "\n".$self->as_string
  185. if !$is_ok || $failure_verbosity == 2;
  186. print "\n# ------------------------------------------------------------------------------" if !$is_ok;
  187. $output_buffer = "";
  188. } elsif ($self->as_string ne "") {
  189. # typically is_comment or is_unknown
  190. $output_buffer .= "\n".$self->as_string;
  191. }
  192. }
  193. }
  194. }
  195. if ($failure_verbosity > 0) {
  196. $callbacks{EOF} = sub {
  197. my $self = shift;
  198. # We know we are a TAP::Parser::Aggregator object
  199. if (scalar $self->failed > 0 && @failure_output) {
  200. # We add an extra empty line, because in the case of a
  201. # progress counter, we're still at the end of that progress
  202. # line.
  203. print $_, "\n" foreach (("", @failure_output));
  204. }
  205. # Echo any trailing comments etc.
  206. print "$output_buffer";
  207. };
  208. }
  209. if (keys %callbacks) {
  210. # If %opts already has a callbacks element, the order here
  211. # ensures we do not override it
  212. %opts = ( callbacks => { %callbacks }, %opts );
  213. }
  214. return $class->SUPER::new({ %opts });
  215. }
  216. package TAP::Harness::OpenSSL;
  217. use parent -norequire, 'TAP::Harness';
  218. require TAP::Harness;
  219. package main;
  220. $tapargs{parser_class} = "TAP::Parser::OpenSSL";
  221. $package = 'TAP::Harness::OpenSSL';
  222. };
  223. unless (defined $eres) {
  224. $eres = eval {
  225. # Fake TAP::Harness in case it's not loaded
  226. package TAP::Harness::fake;
  227. use parent 'Test::Harness';
  228. sub new {
  229. my $class = shift;
  230. my %args = %{ shift() };
  231. return bless { %args }, $class;
  232. }
  233. sub runtests {
  234. my $self = shift;
  235. # Pre TAP::Harness Test::Harness doesn't support [ filename, name ]
  236. # elements, so convert such elements to just be the filename
  237. my @args = map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @_;
  238. my @switches = ();
  239. if ($self->{switches}) {
  240. push @switches, $self->{switches};
  241. }
  242. if ($self->{lib}) {
  243. foreach (@{$self->{lib}}) {
  244. my $l = $_;
  245. # It seems that $switches is getting interpreted with 'eval'
  246. # or something like that, and that we need to take care of
  247. # backslashes or they will disappear along the way.
  248. $l =~ s|\\|\\\\|g if $^O eq "MSWin32";
  249. push @switches, "-I$l";
  250. }
  251. }
  252. $Test::Harness::switches = join(' ', @switches);
  253. Test::Harness::runtests(@args);
  254. }
  255. package main;
  256. $package = 'TAP::Harness::fake';
  257. };
  258. }
  259. unless (defined $eres) {
  260. print $@,"\n" if $@;
  261. print $!,"\n" if $!;
  262. exit 127;
  263. }
  264. my $harness = $package->new(\%tapargs);
  265. my $ret =
  266. $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] }
  267. @preps);
  268. if (ref($ret) ne "TAP::Parser::Aggregator" || !$ret->has_errors) {
  269. $ret =
  270. $harness->runtests(map { [ abs2rel($_, rel2abs(curdir())), basename($_) ] }
  271. sort { reorder($a) cmp reorder($b) } keys %tests);
  272. }
  273. # If this is a TAP::Parser::Aggregator, $ret->has_errors is the count of
  274. # tests that failed. We don't bother with that exact number, just exit
  275. # with an appropriate exit code when it isn't zero.
  276. if (ref($ret) eq "TAP::Parser::Aggregator") {
  277. exit 0 unless $ret->has_errors;
  278. exit 1 unless $^O eq 'VMS';
  279. # On VMS, perl converts an exit 1 to SS$_ABORT (%SYSTEM-F-ABORT), which
  280. # is a bit harsh. As per perl recommendations, we explicitly use the
  281. # same VMS status code as typical C programs would for exit(1), except
  282. # we set the error severity rather than success.
  283. # Ref: https://perldoc.perl.org/perlport#exit
  284. # https://perldoc.perl.org/perlvms#$?
  285. exit 0x35a000 # C facility code
  286. + 8 # 1 << 3 (to make space for the 3 severity bits)
  287. + 2 # severity: E(rror)
  288. + 0x10000000; # bit 28 set => the shell stays silent
  289. }
  290. # If this isn't a TAP::Parser::Aggregator, it's the pre-TAP test harness,
  291. # which simply dies at the end if any test failed, so we don't need to bother
  292. # with any exit code in that case.