1#! /usr/bin/env perl 2# Copyright 2015-2020 The OpenSSL Project Authors. All Rights Reserved. 3# 4# Licensed under the OpenSSL license (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 and V which is common on other projects. 13BEGIN { 14 $ENV{HARNESS_VERBOSE} = "yes" if $ENV{VERBOSE} || $ENV{V}; 15} 16 17use File::Spec::Functions qw/catdir catfile curdir abs2rel rel2abs/; 18use File::Basename; 19use FindBin; 20use lib "$FindBin::Bin/../util/perl"; 21use OpenSSL::Glob; 22 23my $TAP_Harness = eval { require TAP::Harness } ? "TAP::Harness" 24 : "OpenSSL::TAP::Harness"; 25 26my $srctop = $ENV{SRCTOP} || $ENV{TOP}; 27my $bldtop = $ENV{BLDTOP} || $ENV{TOP}; 28my $recipesdir = catdir($srctop, "test", "recipes"); 29my $libdir = rel2abs(catdir($srctop, "util", "perl")); 30 31$ENV{OPENSSL_CONF} = catdir($srctop, "apps", "openssl.cnf"); 32 33my %tapargs = 34 ( verbosity => $ENV{VERBOSE} || $ENV{V} || $ENV{HARNESS_VERBOSE} ? 1 : 0, 35 lib => [ $libdir ], 36 switches => '-w', 37 merge => 1 38 ); 39 40my @alltests = find_matching_tests("*"); 41my %tests = (); 42 43my $initial_arg = 1; 44foreach my $arg (@ARGV ? @ARGV : ('alltests')) { 45 if ($arg eq 'list') { 46 foreach (@alltests) { 47 (my $x = basename($_)) =~ s|^[0-9][0-9]-(.*)\.t$|$1|; 48 print $x,"\n"; 49 } 50 exit 0; 51 } 52 if ($arg eq 'alltests') { 53 warn "'alltests' encountered, ignoring everything before that...\n" 54 unless $initial_arg; 55 %tests = map { $_ => 1 } @alltests; 56 } elsif ($arg =~ m/^(-?)(.*)/) { 57 my $sign = $1; 58 my $test = $2; 59 my @matches = find_matching_tests($test); 60 61 # If '-foo' is the first arg, it's short for 'alltests -foo' 62 if ($sign eq '-' && $initial_arg) { 63 %tests = map { $_ => 1 } @alltests; 64 } 65 66 if (scalar @matches == 0) { 67 warn "Test $test found no match, skipping ", 68 ($sign eq '-' ? "removal" : "addition"), 69 "...\n"; 70 } else { 71 foreach $test (@matches) { 72 if ($sign eq '-') { 73 delete $tests{$test}; 74 } else { 75 $tests{$test} = 1; 76 } 77 } 78 } 79 } else { 80 warn "I don't know what '$arg' is about, ignoring...\n"; 81 } 82 83 $initial_arg = 0; 84} 85 86my $harness = $TAP_Harness->new(\%tapargs); 87my $ret = $harness->runtests(map { abs2rel($_, rel2abs(curdir())); } 88 sort keys %tests); 89 90# $ret->has_errors may be any number, not just 0 or 1. On VMS, numbers 91# from 2 and on are used as is as VMS statuses, which has severity encoded 92# in the lower 3 bits. 0 and 1, on the other hand, generate SUCCESS and 93# FAILURE, so for correct reporting on all platforms, we make sure the only 94# exit codes are 0 and 1. Double-bang is the trick to do so. 95exit !!$ret->has_errors if (ref($ret) eq "TAP::Parser::Aggregator"); 96 97# If this isn't a TAP::Parser::Aggregator, it's the pre-TAP test harness, 98# which simply dies at the end if any test failed, so we don't need to bother 99# with any exit code in that case. 100 101sub find_matching_tests { 102 my ($glob) = @_; 103 104 if ($glob =~ m|^[\d\[\]\?\-]+$|) { 105 return glob(catfile($recipesdir,"$glob-*.t")); 106 } 107 return glob(catfile($recipesdir,"*-$glob.t")); 108} 109 110 111# Fake TAP::Harness in case it's not loaded 112use Test::Harness; 113package OpenSSL::TAP::Harness; 114 115sub new { 116 my $class = shift; 117 my %args = %{ shift() }; 118 119 return bless { %args }, $class; 120} 121 122sub runtests { 123 my $self = shift; 124 125 my @switches = (); 126 if ($self->{switches}) { 127 push @switches, $self->{switches}; 128 } 129 if ($self->{lib}) { 130 foreach (@{$self->{lib}}) { 131 my $l = $_; 132 133 # It seems that $switches is getting interpreted with 'eval' or 134 # something like that, and that we need to take care of backslashes 135 # or they will disappear along the way. 136 $l =~ s|\\|\\\\|g if $^O eq "MSWin32"; 137 push @switches, "-I$l"; 138 } 139 } 140 141 $Test::Harness::switches = join(' ', @switches); 142 Test::Harness::runtests(@_); 143} 144