1*b0d17251Schristos# Copyright 2016-2021 The OpenSSL Project Authors. All Rights Reserved. 253060421Schristos# 3*b0d17251Schristos# Licensed under the Apache License 2.0 (the "License"). You may not use 453060421Schristos# this file except in compliance with the License. You can obtain a copy 553060421Schristos# in the file LICENSE in the source distribution or at 653060421Schristos# https://www.openssl.org/source/license.html 753060421Schristos 853060421Schristospackage OpenSSL::Test; 953060421Schristos 1053060421Schristosuse strict; 1153060421Schristosuse warnings; 1253060421Schristos 1353060421Schristosuse Test::More 0.96; 1453060421Schristos 1553060421Schristosuse Exporter; 1653060421Schristosuse vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); 17*b0d17251Schristos$VERSION = "1.0"; 1853060421Schristos@ISA = qw(Exporter); 1913d40330Schristos@EXPORT = (@Test::More::EXPORT, qw(setup run indir cmd app fuzz test 2013d40330Schristos perlapp perltest subtest)); 2153060421Schristos@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file 2253060421Schristos srctop_dir srctop_file 2313d40330Schristos data_file data_dir 24*b0d17251Schristos result_file result_dir 25*b0d17251Schristos pipe with cmdstr 26*b0d17251Schristos openssl_versions 27*b0d17251Schristos ok_nofips is_nofips isnt_nofips)); 2853060421Schristos 2953060421Schristos=head1 NAME 3053060421Schristos 3153060421SchristosOpenSSL::Test - a private extension of Test::More 3253060421Schristos 3353060421Schristos=head1 SYNOPSIS 3453060421Schristos 3553060421Schristos use OpenSSL::Test; 3653060421Schristos 3753060421Schristos setup("my_test_name"); 3853060421Schristos 39*b0d17251Schristos plan tests => 2; 40*b0d17251Schristos 4153060421Schristos ok(run(app(["openssl", "version"])), "check for openssl presence"); 4253060421Schristos 4353060421Schristos indir "subdir" => sub { 4453060421Schristos ok(run(test(["sometest", "arg1"], stdout => "foo.txt")), 4553060421Schristos "run sometest with output to foo.txt"); 4653060421Schristos }; 4753060421Schristos 4853060421Schristos=head1 DESCRIPTION 4953060421Schristos 5053060421SchristosThis module is a private extension of L<Test::More> for testing OpenSSL. 5153060421SchristosIn addition to the Test::More functions, it also provides functions that 5253060421Schristoseasily find the diverse programs within a OpenSSL build tree, as well as 5353060421Schristossome other useful functions. 5453060421Schristos 5553060421SchristosThis module I<depends> on the environment variables C<$TOP> or C<$SRCTOP> 5653060421Schristosand C<$BLDTOP>. Without one of the combinations it refuses to work. 5753060421SchristosSee L</ENVIRONMENT> below. 5853060421Schristos 5953060421SchristosWith each test recipe, a parallel data directory with (almost) the same name 6053060421Schristosas the recipe is possible in the source directory tree. For example, for a 6153060421Schristosrecipe C<$SRCTOP/test/recipes/99-foo.t>, there could be a directory 6253060421SchristosC<$SRCTOP/test/recipes/99-foo_data/>. 6353060421Schristos 6453060421Schristos=cut 6553060421Schristos 6653060421Schristosuse File::Copy; 6753060421Schristosuse File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir 68*b0d17251Schristos catdir catfile splitpath catpath devnull abs2rel/; 6953060421Schristosuse File::Path 2.00 qw/rmtree mkpath/; 7053060421Schristosuse File::Basename; 717d004720Schristosuse Cwd qw/getcwd abs_path/; 72*b0d17251Schristosuse OpenSSL::Util; 7353060421Schristos 7413d40330Schristosmy $level = 0; 7553060421Schristos 7653060421Schristos# The name of the test. This is set by setup() and is used in the other 7753060421Schristos# functions to verify that setup() has been used. 7853060421Schristosmy $test_name = undef; 7953060421Schristos 8053060421Schristos# Directories we want to keep track of TOP, APPS, TEST and RESULTS are the 8153060421Schristos# ones we're interested in, corresponding to the environment variables TOP 8253060421Schristos# (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D. 8353060421Schristosmy %directories = (); 8453060421Schristos 8553060421Schristos# The environment variables that gave us the contents in %directories. These 8653060421Schristos# get modified whenever we change directories, so that subprocesses can use 8753060421Schristos# the values of those environment variables as well 8853060421Schristosmy @direnv = (); 8953060421Schristos 9053060421Schristos# A bool saying if we shall stop all testing if the current recipe has failing 9153060421Schristos# tests or not. This is set by setup() if the environment variable STOPTEST 9253060421Schristos# is defined with a non-empty value. 9353060421Schristosmy $end_with_bailout = 0; 9453060421Schristos 9553060421Schristos# A set of hooks that is affected by with() and may be used in diverse places. 9653060421Schristos# All hooks are expected to be CODE references. 9753060421Schristosmy %hooks = ( 9853060421Schristos 9953060421Schristos # exit_checker is used by run() directly after completion of a command. 10053060421Schristos # it receives the exit code from that command and is expected to return 10113d40330Schristos # 1 (for success) or 0 (for failure). This is the status value that run() 10213d40330Schristos # will give back (through the |statusvar| reference and as returned value 10313d40330Schristos # when capture => 1 doesn't apply). 10453060421Schristos exit_checker => sub { return shift == 0 ? 1 : 0 }, 10553060421Schristos 10653060421Schristos ); 10753060421Schristos 10853060421Schristos# Debug flag, to be set manually when needed 10953060421Schristosmy $debug = 0; 11053060421Schristos 11153060421Schristos=head2 Main functions 11253060421Schristos 11353060421SchristosThe following functions are exported by default when using C<OpenSSL::Test>. 11453060421Schristos 11553060421Schristos=cut 11653060421Schristos 11753060421Schristos=over 4 11853060421Schristos 11953060421Schristos=item B<setup "NAME"> 12053060421Schristos 12153060421SchristosC<setup> is used for initial setup, and it is mandatory that it's used. 12253060421SchristosIf it's not used in a OpenSSL test recipe, the rest of the recipe will 12353060421Schristosmost likely refuse to run. 12453060421Schristos 12553060421SchristosC<setup> checks for environment variables (see L</ENVIRONMENT> below), 12653060421Schristoschecks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir> 12753060421Schristosinto the results directory (defined by the C<$RESULT_D> environment 128*b0d17251Schristosvariable if defined, otherwise C<$BLDTOP/test-runs> or C<$TOP/test-runs>, 129*b0d17251Schristoswhichever is defined). 13053060421Schristos 13153060421Schristos=back 13253060421Schristos 13353060421Schristos=cut 13453060421Schristos 13553060421Schristossub setup { 13653060421Schristos my $old_test_name = $test_name; 13753060421Schristos $test_name = shift; 138*b0d17251Schristos my %opts = @_; 13953060421Schristos 14053060421Schristos BAIL_OUT("setup() must receive a name") unless $test_name; 14153060421Schristos warn "setup() detected test name change. Innocuous, so we continue...\n" 14253060421Schristos if $old_test_name && $old_test_name ne $test_name; 14353060421Schristos 14453060421Schristos return if $old_test_name; 14553060421Schristos 14653060421Schristos BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined") 14753060421Schristos unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP}); 14853060421Schristos BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...") 14953060421Schristos if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP}); 15053060421Schristos 15153060421Schristos __env(); 15253060421Schristos 15353060421Schristos BAIL_OUT("setup() expects the file Configure in the source top directory") 15453060421Schristos unless -f srctop_file("Configure"); 15553060421Schristos 156*b0d17251Schristos note "The results of this test will end up in $directories{RESULTS}" 157*b0d17251Schristos unless $opts{quiet}; 158*b0d17251Schristos 15953060421Schristos __cwd($directories{RESULTS}); 16053060421Schristos} 16153060421Schristos 16253060421Schristos=over 4 16353060421Schristos 16453060421Schristos=item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS> 16553060421Schristos 16653060421SchristosC<indir> is used to run a part of the recipe in a different directory than 16753060421Schristosthe one C<setup> moved into, usually a subdirectory, given by SUBDIR. 16853060421SchristosThe part of the recipe that's run there is given by the codeblock BLOCK. 16953060421Schristos 17053060421SchristosC<indir> takes some additional options OPTS that affect the subdirectory: 17153060421Schristos 17253060421Schristos=over 4 17353060421Schristos 17453060421Schristos=item B<create =E<gt> 0|1> 17553060421Schristos 1764ce06407SchristosWhen set to 1 (or any value that perl perceives as true), the subdirectory 17753060421Schristoswill be created if it doesn't already exist. This happens before BLOCK 17853060421Schristosis executed. 17953060421Schristos 18053060421Schristos=back 18153060421Schristos 18253060421SchristosAn example: 18353060421Schristos 18453060421Schristos indir "foo" => sub { 18553060421Schristos ok(run(app(["openssl", "version"]), stdout => "foo.txt")); 18653060421Schristos if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) { 18753060421Schristos my $line = <RESULT>; 18853060421Schristos close RESULT; 18953060421Schristos is($line, qr/^OpenSSL 1\./, 19053060421Schristos "check that we're using OpenSSL 1.x.x"); 19153060421Schristos } 192*b0d17251Schristos }, create => 1; 19353060421Schristos 19453060421Schristos=back 19553060421Schristos 19653060421Schristos=cut 19753060421Schristos 19853060421Schristossub indir { 19953060421Schristos my $subdir = shift; 20053060421Schristos my $codeblock = shift; 20153060421Schristos my %opts = @_; 20253060421Schristos 20353060421Schristos my $reverse = __cwd($subdir,%opts); 20453060421Schristos BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into") 20553060421Schristos unless $reverse; 20653060421Schristos 20753060421Schristos $codeblock->(); 20853060421Schristos 20953060421Schristos __cwd($reverse); 21053060421Schristos} 21153060421Schristos 21253060421Schristos=over 4 21353060421Schristos 21413d40330Schristos=item B<cmd ARRAYREF, OPTS> 21553060421Schristos 21613d40330SchristosThis functions build up a platform dependent command based on the 21713d40330Schristosinput. It takes a reference to a list that is the executable or 21813d40330Schristosscript and its arguments, and some additional options (described 21913d40330Schristosfurther on). Where necessary, the command will be wrapped in a 22013d40330Schristossuitable environment to make sure the correct shared libraries are 22113d40330Schristosused (currently only on Unix). 22253060421Schristos 22313d40330SchristosIt returns a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>. 22453060421Schristos 225*b0d17251SchristosThe options that C<cmd> (as well as its derivatives described below) can take 226*b0d17251Schristosare in the form of hash values: 22753060421Schristos 22853060421Schristos=over 4 22953060421Schristos 23053060421Schristos=item B<stdin =E<gt> PATH> 23153060421Schristos 23253060421Schristos=item B<stdout =E<gt> PATH> 23353060421Schristos 23453060421Schristos=item B<stderr =E<gt> PATH> 23553060421Schristos 23653060421SchristosIn all three cases, the corresponding standard input, output or error is 23753060421Schristosredirected from (for stdin) or to (for the others) a file given by the 23853060421Schristosstring PATH, I<or>, if the value is C<undef>, C</dev/null> or similar. 23953060421Schristos 24053060421Schristos=back 24153060421Schristos 24213d40330Schristos=item B<app ARRAYREF, OPTS> 24313d40330Schristos 24413d40330Schristos=item B<test ARRAYREF, OPTS> 24513d40330Schristos 24613d40330SchristosBoth of these are specific applications of C<cmd>, with just a couple 24713d40330Schristosof small difference: 24813d40330Schristos 24913d40330SchristosC<app> expects to find the given command (the first item in the given list 25013d40330Schristosreference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps> 25113d40330Schristosor C<$BLDTOP/apps>). 25213d40330Schristos 25313d40330SchristosC<test> expects to find the given command (the first item in the given list 25413d40330Schristosreference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test> 25513d40330Schristosor C<$BLDTOP/test>). 25613d40330Schristos 25713d40330SchristosAlso, for both C<app> and C<test>, the command may be prefixed with 25813d40330Schristosthe content of the environment variable C<$EXE_SHELL>, which is useful 25913d40330Schristosin case OpenSSL has been cross compiled. 26013d40330Schristos 26153060421Schristos=item B<perlapp ARRAYREF, OPTS> 26253060421Schristos 26353060421Schristos=item B<perltest ARRAYREF, OPTS> 26453060421Schristos 26513d40330SchristosThese are also specific applications of C<cmd>, where the interpreter 26613d40330Schristosis predefined to be C<perl>, and they expect the script to be 26713d40330Schristosinterpreted to reside in the same location as C<app> and C<test>. 26813d40330Schristos 26913d40330SchristosC<perlapp> and C<perltest> will also take the following option: 27053060421Schristos 27153060421Schristos=over 4 27253060421Schristos 27353060421Schristos=item B<interpreter_args =E<gt> ARRAYref> 27453060421Schristos 27513d40330SchristosThe array reference is a set of arguments for the interpreter rather 27613d40330Schristosthan the script. Take care so that none of them can be seen as a 27713d40330Schristosscript! Flags and their eventual arguments only! 27853060421Schristos 27953060421Schristos=back 28053060421Schristos 28153060421SchristosAn example: 28253060421Schristos 28353060421Schristos ok(run(perlapp(["foo.pl", "arg1"], 28453060421Schristos interpreter_args => [ "-I", srctop_dir("test") ]))); 28553060421Schristos 28653060421Schristos=back 28753060421Schristos 28813d40330Schristos=begin comment 28913d40330Schristos 29013d40330SchristosOne might wonder over the complexity of C<apps>, C<fuzz>, C<test>, ... 29113d40330Schristoswith all the lazy evaluations and all that. The reason for this is that 29213d40330Schristoswe want to make sure the directory in which those programs are found are 29313d40330Schristoscorrect at the time these commands are used. Consider the following code 29413d40330Schristossnippet: 29513d40330Schristos 29613d40330Schristos my $cmd = app(["openssl", ...]); 29713d40330Schristos 29813d40330Schristos indir "foo", sub { 29913d40330Schristos ok(run($cmd), "Testing foo") 30013d40330Schristos }; 30113d40330Schristos 30213d40330SchristosIf there wasn't this lazy evaluation, the directory where C<openssl> is 30313d40330Schristosfound would be incorrect at the time C<run> is called, because it was 30413d40330Schristoscalculated before we moved into the directory "foo". 30513d40330Schristos 30613d40330Schristos=end comment 30713d40330Schristos 30853060421Schristos=cut 30953060421Schristos 31013d40330Schristossub cmd { 31113d40330Schristos my $cmd = shift; 31213d40330Schristos my %opts = @_; 31313d40330Schristos return sub { 31413d40330Schristos my $num = shift; 31513d40330Schristos # Make a copy to not destroy the caller's array 31613d40330Schristos my @cmdargs = ( @$cmd ); 31713d40330Schristos my @prog = __wrap_cmd(shift @cmdargs, $opts{exe_shell} // ()); 31813d40330Schristos 319*b0d17251Schristos return __decorate_cmd($num, [ @prog, fixup_cmd_elements(@cmdargs) ], 32013d40330Schristos %opts); 32113d40330Schristos } 32213d40330Schristos} 32313d40330Schristos 32453060421Schristossub app { 32553060421Schristos my $cmd = shift; 32653060421Schristos my %opts = @_; 32713d40330Schristos return sub { 32813d40330Schristos my @cmdargs = ( @{$cmd} ); 32913d40330Schristos my @prog = __fixup_prg(__apps_file(shift @cmdargs, __exeext())); 33013d40330Schristos return cmd([ @prog, @cmdargs ], 33113d40330Schristos exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift); 33213d40330Schristos } 33353060421Schristos} 33453060421Schristos 33553060421Schristossub fuzz { 33653060421Schristos my $cmd = shift; 33753060421Schristos my %opts = @_; 33813d40330Schristos return sub { 33913d40330Schristos my @cmdargs = ( @{$cmd} ); 34013d40330Schristos my @prog = __fixup_prg(__fuzz_file(shift @cmdargs, __exeext())); 34113d40330Schristos return cmd([ @prog, @cmdargs ], 34213d40330Schristos exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift); 34313d40330Schristos } 34453060421Schristos} 34553060421Schristos 34653060421Schristossub test { 34753060421Schristos my $cmd = shift; 34853060421Schristos my %opts = @_; 34913d40330Schristos return sub { 35013d40330Schristos my @cmdargs = ( @{$cmd} ); 35113d40330Schristos my @prog = __fixup_prg(__test_file(shift @cmdargs, __exeext())); 35213d40330Schristos return cmd([ @prog, @cmdargs ], 35313d40330Schristos exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift); 35413d40330Schristos } 35553060421Schristos} 35653060421Schristos 35753060421Schristossub perlapp { 35853060421Schristos my $cmd = shift; 35953060421Schristos my %opts = @_; 36013d40330Schristos return sub { 36113d40330Schristos my @interpreter_args = defined $opts{interpreter_args} ? 36213d40330Schristos @{$opts{interpreter_args}} : (); 36313d40330Schristos my @interpreter = __fixup_prg($^X); 36413d40330Schristos my @cmdargs = ( @{$cmd} ); 36513d40330Schristos my @prog = __apps_file(shift @cmdargs, undef); 36613d40330Schristos return cmd([ @interpreter, @interpreter_args, 36713d40330Schristos @prog, @cmdargs ], %opts) -> (shift); 36813d40330Schristos } 36953060421Schristos} 37053060421Schristos 37153060421Schristossub perltest { 37253060421Schristos my $cmd = shift; 37353060421Schristos my %opts = @_; 37413d40330Schristos return sub { 37513d40330Schristos my @interpreter_args = defined $opts{interpreter_args} ? 37613d40330Schristos @{$opts{interpreter_args}} : (); 37713d40330Schristos my @interpreter = __fixup_prg($^X); 37813d40330Schristos my @cmdargs = ( @{$cmd} ); 37913d40330Schristos my @prog = __test_file(shift @cmdargs, undef); 38013d40330Schristos return cmd([ @interpreter, @interpreter_args, 38113d40330Schristos @prog, @cmdargs ], %opts) -> (shift); 38213d40330Schristos } 38353060421Schristos} 38453060421Schristos 38553060421Schristos=over 4 38653060421Schristos 38753060421Schristos=item B<run CODEREF, OPTS> 38853060421Schristos 38913d40330SchristosCODEREF is expected to be the value return by C<cmd> or any of its 39013d40330Schristosderivatives, anything else will most likely cause an error unless you 39113d40330Schristosknow what you're doing. 39253060421Schristos 39353060421SchristosC<run> executes the command returned by CODEREF and return either the 394*b0d17251Schristosresulting standard output (if the option C<capture> is set true) or a boolean 39513d40330Schristosindicating if the command succeeded or not. 39653060421Schristos 39753060421SchristosThe options that C<run> can take are in the form of hash values: 39853060421Schristos 39953060421Schristos=over 4 40053060421Schristos 40153060421Schristos=item B<capture =E<gt> 0|1> 40253060421Schristos 403*b0d17251SchristosIf true, the command will be executed with a perl backtick, 404*b0d17251Schristosand C<run> will return the resulting standard output as an array of lines. 405*b0d17251SchristosIf false or not given, the command will be executed with C<system()>, 406*b0d17251Schristosand C<run> will return 1 if the command was successful or 0 if it wasn't. 40753060421Schristos 40813d40330Schristos=item B<prefix =E<gt> EXPR> 40913d40330Schristos 41013d40330SchristosIf specified, EXPR will be used as a string to prefix the output from the 41113d40330Schristoscommand. This is useful if the output contains lines starting with C<ok > 41213d40330Schristosor C<not ok > that can disturb Test::Harness. 41313d40330Schristos 41413d40330Schristos=item B<statusvar =E<gt> VARREF> 41513d40330Schristos 41613d40330SchristosIf used, B<VARREF> must be a reference to a scalar variable. It will be 41713d40330Schristosassigned a boolean indicating if the command succeeded or not. This is 41813d40330Schristosparticularly useful together with B<capture>. 41913d40330Schristos 42053060421Schristos=back 42153060421Schristos 422*b0d17251SchristosUsually 1 indicates that the command was successful and 0 indicates failure. 42353060421SchristosFor further discussion on what is considered a successful command or not, see 42453060421Schristosthe function C<with> further down. 42553060421Schristos 42653060421Schristos=back 42753060421Schristos 42853060421Schristos=cut 42953060421Schristos 43053060421Schristossub run { 43153060421Schristos my ($cmd, $display_cmd) = shift->(0); 43253060421Schristos my %opts = @_; 43353060421Schristos 43453060421Schristos return () if !$cmd; 43553060421Schristos 43653060421Schristos my $prefix = ""; 43753060421Schristos if ( $^O eq "VMS" ) { # VMS 43853060421Schristos $prefix = "pipe "; 43953060421Schristos } 44053060421Schristos 44153060421Schristos my @r = (); 44253060421Schristos my $r = 0; 44353060421Schristos my $e = 0; 44453060421Schristos 44513d40330Schristos die "OpenSSL::Test::run(): statusvar value not a scalar reference" 44613d40330Schristos if $opts{statusvar} && ref($opts{statusvar}) ne "SCALAR"; 44713d40330Schristos 448*b0d17251Schristos # For some reason, program output, or even output from this function 449*b0d17251Schristos # somehow isn't caught by TAP::Harness (TAP::Parser?) on VMS, so we're 450*b0d17251Schristos # silencing it specifically there until further notice. 451*b0d17251Schristos my $save_STDOUT; 452*b0d17251Schristos my $save_STDERR; 453*b0d17251Schristos if ($^O eq 'VMS') { 45453060421Schristos # In non-verbose, we want to shut up the command interpreter, in case 45553060421Schristos # it has something to complain about. On VMS, it might complain both 45653060421Schristos # on stdout and stderr 45753060421Schristos if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { 45853060421Schristos open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!"; 45953060421Schristos open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!"; 46053060421Schristos open STDOUT, ">", devnull(); 46153060421Schristos open STDERR, ">", devnull(); 46253060421Schristos } 463*b0d17251Schristos } 46453060421Schristos 46513d40330Schristos $ENV{HARNESS_OSSL_LEVEL} = $level + 1; 46613d40330Schristos 46753060421Schristos # The dance we do with $? is the same dance the Unix shells appear to 46853060421Schristos # do. For example, a program that gets aborted (and therefore signals 46953060421Schristos # SIGABRT = 6) will appear to exit with the code 134. We mimic this 47053060421Schristos # to make it easier to compare with a manual run of the command. 47113d40330Schristos if ($opts{capture} || defined($opts{prefix})) { 47213d40330Schristos my $pipe; 47313d40330Schristos local $_; 47413d40330Schristos 47513d40330Schristos open($pipe, '-|', "$prefix$cmd") or die "Can't start command: $!"; 47613d40330Schristos while(<$pipe>) { 47713d40330Schristos my $l = ($opts{prefix} // "") . $_; 47853060421Schristos if ($opts{capture}) { 47913d40330Schristos push @r, $l; 48053060421Schristos } else { 48113d40330Schristos print STDOUT $l; 48213d40330Schristos } 48313d40330Schristos } 48413d40330Schristos close $pipe; 48513d40330Schristos } else { 48613d40330Schristos $ENV{HARNESS_OSSL_PREFIX} = "# "; 48753060421Schristos system("$prefix$cmd"); 48813d40330Schristos delete $ENV{HARNESS_OSSL_PREFIX}; 48913d40330Schristos } 49053060421Schristos $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); 49153060421Schristos $r = $hooks{exit_checker}->($e); 49213d40330Schristos if ($opts{statusvar}) { 49313d40330Schristos ${$opts{statusvar}} = $r; 49453060421Schristos } 49553060421Schristos 496*b0d17251Schristos # Restore STDOUT / STDERR on VMS 497*b0d17251Schristos if ($^O eq 'VMS') { 49853060421Schristos if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { 49953060421Schristos close STDOUT; 50053060421Schristos close STDERR; 50153060421Schristos open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!"; 50253060421Schristos open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!"; 50353060421Schristos } 50453060421Schristos 50553060421Schristos print STDERR "$prefix$display_cmd => $e\n" 50653060421Schristos if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; 507*b0d17251Schristos } else { 508*b0d17251Schristos print STDERR "$prefix$display_cmd => $e\n"; 509*b0d17251Schristos } 51053060421Schristos 51153060421Schristos # At this point, $? stops being interesting, and unfortunately, 51253060421Schristos # there are Test::More versions that get picky if we leave it 51353060421Schristos # non-zero. 51453060421Schristos $? = 0; 51553060421Schristos 51653060421Schristos if ($opts{capture}) { 51753060421Schristos return @r; 51853060421Schristos } else { 51953060421Schristos return $r; 52053060421Schristos } 52153060421Schristos} 52253060421Schristos 52353060421SchristosEND { 52453060421Schristos my $tb = Test::More->builder; 52553060421Schristos my $failure = scalar(grep { $_ == 0; } $tb->summary); 52653060421Schristos if ($failure && $end_with_bailout) { 52753060421Schristos BAIL_OUT("Stoptest!"); 52853060421Schristos } 52953060421Schristos} 53053060421Schristos 53153060421Schristos=head2 Utility functions 53253060421Schristos 53353060421SchristosThe following functions are exported on request when using C<OpenSSL::Test>. 53453060421Schristos 53553060421Schristos # To only get the bldtop_file and srctop_file functions. 53653060421Schristos use OpenSSL::Test qw/bldtop_file srctop_file/; 53753060421Schristos 53853060421Schristos # To only get the bldtop_file function in addition to the default ones. 53953060421Schristos use OpenSSL::Test qw/:DEFAULT bldtop_file/; 54053060421Schristos 54153060421Schristos=cut 54253060421Schristos 54353060421Schristos# Utility functions, exported on request 54453060421Schristos 54553060421Schristos=over 4 54653060421Schristos 54753060421Schristos=item B<bldtop_dir LIST> 54853060421Schristos 54953060421SchristosLIST is a list of directories that make up a path from the top of the OpenSSL 55053060421Schristosbuild directory (as indicated by the environment variable C<$TOP> or 55153060421SchristosC<$BLDTOP>). 55253060421SchristosC<bldtop_dir> returns the resulting directory as a string, adapted to the local 55353060421Schristosoperating system. 55453060421Schristos 55553060421Schristos=back 55653060421Schristos 55753060421Schristos=cut 55853060421Schristos 55953060421Schristossub bldtop_dir { 56053060421Schristos return __bldtop_dir(@_); # This caters for operating systems that have 56153060421Schristos # a very distinct syntax for directories. 56253060421Schristos} 56353060421Schristos 56453060421Schristos=over 4 56553060421Schristos 56653060421Schristos=item B<bldtop_file LIST, FILENAME> 56753060421Schristos 56853060421SchristosLIST is a list of directories that make up a path from the top of the OpenSSL 56953060421Schristosbuild directory (as indicated by the environment variable C<$TOP> or 57053060421SchristosC<$BLDTOP>) and FILENAME is the name of a file located in that directory path. 57153060421SchristosC<bldtop_file> returns the resulting file path as a string, adapted to the local 57253060421Schristosoperating system. 57353060421Schristos 57453060421Schristos=back 57553060421Schristos 57653060421Schristos=cut 57753060421Schristos 57853060421Schristossub bldtop_file { 57953060421Schristos return __bldtop_file(@_); 58053060421Schristos} 58153060421Schristos 58253060421Schristos=over 4 58353060421Schristos 58453060421Schristos=item B<srctop_dir LIST> 58553060421Schristos 58653060421SchristosLIST is a list of directories that make up a path from the top of the OpenSSL 58753060421Schristossource directory (as indicated by the environment variable C<$TOP> or 58853060421SchristosC<$SRCTOP>). 58953060421SchristosC<srctop_dir> returns the resulting directory as a string, adapted to the local 59053060421Schristosoperating system. 59153060421Schristos 59253060421Schristos=back 59353060421Schristos 59453060421Schristos=cut 59553060421Schristos 59653060421Schristossub srctop_dir { 59753060421Schristos return __srctop_dir(@_); # This caters for operating systems that have 59853060421Schristos # a very distinct syntax for directories. 59953060421Schristos} 60053060421Schristos 60153060421Schristos=over 4 60253060421Schristos 60353060421Schristos=item B<srctop_file LIST, FILENAME> 60453060421Schristos 60553060421SchristosLIST is a list of directories that make up a path from the top of the OpenSSL 60653060421Schristossource directory (as indicated by the environment variable C<$TOP> or 60753060421SchristosC<$SRCTOP>) and FILENAME is the name of a file located in that directory path. 60853060421SchristosC<srctop_file> returns the resulting file path as a string, adapted to the local 60953060421Schristosoperating system. 61053060421Schristos 61153060421Schristos=back 61253060421Schristos 61353060421Schristos=cut 61453060421Schristos 61553060421Schristossub srctop_file { 61653060421Schristos return __srctop_file(@_); 61753060421Schristos} 61853060421Schristos 61953060421Schristos=over 4 62053060421Schristos 62113d40330Schristos=item B<data_dir LIST> 62213d40330Schristos 62313d40330SchristosLIST is a list of directories that make up a path from the data directory 62413d40330Schristosassociated with the test (see L</DESCRIPTION> above). 62513d40330SchristosC<data_dir> returns the resulting directory as a string, adapted to the local 62613d40330Schristosoperating system. 62713d40330Schristos 62813d40330Schristos=back 62913d40330Schristos 63013d40330Schristos=cut 63113d40330Schristos 63213d40330Schristossub data_dir { 63313d40330Schristos return __data_dir(@_); 63413d40330Schristos} 63513d40330Schristos 63613d40330Schristos=over 4 63713d40330Schristos 63853060421Schristos=item B<data_file LIST, FILENAME> 63953060421Schristos 64053060421SchristosLIST is a list of directories that make up a path from the data directory 64153060421Schristosassociated with the test (see L</DESCRIPTION> above) and FILENAME is the name 64253060421Schristosof a file located in that directory path. C<data_file> returns the resulting 64353060421Schristosfile path as a string, adapted to the local operating system. 64453060421Schristos 64553060421Schristos=back 64653060421Schristos 64753060421Schristos=cut 64853060421Schristos 64953060421Schristossub data_file { 65053060421Schristos return __data_file(@_); 65153060421Schristos} 65253060421Schristos 65353060421Schristos=over 4 65453060421Schristos 655*b0d17251Schristos=item B<result_dir> 656*b0d17251Schristos 657*b0d17251SchristosC<result_dir> returns the directory where test output files should be placed 658*b0d17251Schristosas a string, adapted to the local operating system. 659*b0d17251Schristos 660*b0d17251Schristos=back 661*b0d17251Schristos 662*b0d17251Schristos=cut 663*b0d17251Schristos 664*b0d17251Schristossub result_dir { 665*b0d17251Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 666*b0d17251Schristos 667*b0d17251Schristos return catfile($directories{RESULTS}); 668*b0d17251Schristos} 669*b0d17251Schristos 670*b0d17251Schristos=over 4 671*b0d17251Schristos 672*b0d17251Schristos=item B<result_file FILENAME> 673*b0d17251Schristos 674*b0d17251SchristosFILENAME is the name of a test output file. 675*b0d17251SchristosC<result_file> returns the path of the given file as a string, 676*b0d17251Schristosprepending to the file name the path to the directory where test output files 677*b0d17251Schristosshould be placed, adapted to the local operating system. 678*b0d17251Schristos 679*b0d17251Schristos=back 680*b0d17251Schristos 681*b0d17251Schristos=cut 682*b0d17251Schristos 683*b0d17251Schristossub result_file { 684*b0d17251Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 685*b0d17251Schristos 686*b0d17251Schristos my $f = pop; 687*b0d17251Schristos return catfile(result_dir(),@_,$f); 688*b0d17251Schristos} 689*b0d17251Schristos 690*b0d17251Schristos=over 4 691*b0d17251Schristos 69253060421Schristos=item B<pipe LIST> 69353060421Schristos 69453060421SchristosLIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe> 69553060421Schristoscreates a new command composed of all the given commands put together in a 69653060421Schristospipe. C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>, 69753060421Schristosto be passed to C<run> for execution. 69853060421Schristos 69953060421Schristos=back 70053060421Schristos 70153060421Schristos=cut 70253060421Schristos 70353060421Schristossub pipe { 70453060421Schristos my @cmds = @_; 70553060421Schristos return 70653060421Schristos sub { 70753060421Schristos my @cs = (); 70853060421Schristos my @dcs = (); 70953060421Schristos my @els = (); 71053060421Schristos my $counter = 0; 71153060421Schristos foreach (@cmds) { 71253060421Schristos my ($c, $dc, @el) = $_->(++$counter); 71353060421Schristos 71453060421Schristos return () if !$c; 71553060421Schristos 71653060421Schristos push @cs, $c; 71753060421Schristos push @dcs, $dc; 71853060421Schristos push @els, @el; 71953060421Schristos } 72053060421Schristos return ( 72153060421Schristos join(" | ", @cs), 72253060421Schristos join(" | ", @dcs), 72353060421Schristos @els 72453060421Schristos ); 72553060421Schristos }; 72653060421Schristos} 72753060421Schristos 72853060421Schristos=over 4 72953060421Schristos 73053060421Schristos=item B<with HASHREF, CODEREF> 73153060421Schristos 73213d40330SchristosC<with> will temporarily install hooks given by the HASHREF and then execute 73353060421Schristosthe given CODEREF. Hooks are usually expected to have a coderef as value. 73453060421Schristos 73553060421SchristosThe currently available hoosk are: 73653060421Schristos 73753060421Schristos=over 4 73853060421Schristos 73953060421Schristos=item B<exit_checker =E<gt> CODEREF> 74053060421Schristos 74153060421SchristosThis hook is executed after C<run> has performed its given command. The 74253060421SchristosCODEREF receives the exit code as only argument and is expected to return 74353060421Schristos1 (if the exit code indicated success) or 0 (if the exit code indicated 74453060421Schristosfailure). 74553060421Schristos 74653060421Schristos=back 74753060421Schristos 74853060421Schristos=back 74953060421Schristos 75053060421Schristos=cut 75153060421Schristos 75253060421Schristossub with { 75353060421Schristos my $opts = shift; 75453060421Schristos my %opts = %{$opts}; 75553060421Schristos my $codeblock = shift; 75653060421Schristos 75753060421Schristos my %saved_hooks = (); 75853060421Schristos 75953060421Schristos foreach (keys %opts) { 76053060421Schristos $saved_hooks{$_} = $hooks{$_} if exists($hooks{$_}); 76153060421Schristos $hooks{$_} = $opts{$_}; 76253060421Schristos } 76353060421Schristos 76453060421Schristos $codeblock->(); 76553060421Schristos 76653060421Schristos foreach (keys %saved_hooks) { 76753060421Schristos $hooks{$_} = $saved_hooks{$_}; 76853060421Schristos } 76953060421Schristos} 77053060421Schristos 77153060421Schristos=over 4 77253060421Schristos 77353060421Schristos=item B<cmdstr CODEREF, OPTS> 77453060421Schristos 77553060421SchristosC<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the 77653060421Schristoscommand as a string. 77753060421Schristos 77813d40330SchristosC<cmdstr> takes some additional options OPTS that affect the string returned: 77953060421Schristos 78053060421Schristos=over 4 78153060421Schristos 78253060421Schristos=item B<display =E<gt> 0|1> 78353060421Schristos 78453060421SchristosWhen set to 0, the returned string will be with all decorations, such as a 78553060421Schristospossible redirect of stderr to the null device. This is suitable if the 78653060421Schristosstring is to be used directly in a recipe. 78753060421Schristos 78853060421SchristosWhen set to 1, the returned string will be without extra decorations. This 78953060421Schristosis suitable for display if that is desired (doesn't confuse people with all 79053060421Schristosinternal stuff), or if it's used to pass a command down to a subprocess. 79153060421Schristos 79253060421SchristosDefault: 0 79353060421Schristos 79453060421Schristos=back 79553060421Schristos 79653060421Schristos=back 79753060421Schristos 79853060421Schristos=cut 79953060421Schristos 80053060421Schristossub cmdstr { 80153060421Schristos my ($cmd, $display_cmd) = shift->(0); 80253060421Schristos my %opts = @_; 80353060421Schristos 80453060421Schristos if ($opts{display}) { 80553060421Schristos return $display_cmd; 80653060421Schristos } else { 80753060421Schristos return $cmd; 80853060421Schristos } 80953060421Schristos} 81053060421Schristos 81153060421Schristos=over 4 81253060421Schristos 813132cc1c4Schristos=over 4 814132cc1c4Schristos 815132cc1c4Schristos=item B<openssl_versions> 816132cc1c4Schristos 817*b0d17251SchristosReturns a list of two version numbers, the first representing the build 818*b0d17251Schristosversion, the second representing the library version. See opensslv.h for 819*b0d17251Schristosmore information on those numbers. 820132cc1c4Schristos 821132cc1c4Schristos=back 822132cc1c4Schristos 823132cc1c4Schristos=cut 824132cc1c4Schristos 825132cc1c4Schristosmy @versions = (); 826132cc1c4Schristossub openssl_versions { 827132cc1c4Schristos unless (@versions) { 828132cc1c4Schristos my %lines = 829132cc1c4Schristos map { s/\R$//; 830*b0d17251Schristos /^(.*): (.*)$/; 831*b0d17251Schristos $1 => $2 } 832132cc1c4Schristos run(test(['versions']), capture => 1); 833132cc1c4Schristos @versions = ( $lines{'Build version'}, $lines{'Library version'} ); 834132cc1c4Schristos } 835132cc1c4Schristos return @versions; 836132cc1c4Schristos} 837132cc1c4Schristos 838*b0d17251Schristos=over 4 839*b0d17251Schristos 840*b0d17251Schristos=item B<ok_nofips EXPR, TEST_NAME> 841*b0d17251Schristos 842*b0d17251SchristosC<ok_nofips> is equivalent to using C<ok> when the environment variable 843*b0d17251SchristosC<FIPS_MODE> is undefined, otherwise it is equivalent to C<not ok>. This can be 844*b0d17251Schristosused for C<ok> tests that must fail when testing a FIPS provider. The parameters 845*b0d17251Schristosare the same as used by C<ok> which is an expression EXPR followed by the test 846*b0d17251Schristosdescription TEST_NAME. 847*b0d17251Schristos 848*b0d17251SchristosAn example: 849*b0d17251Schristos 850*b0d17251Schristos ok_nofips(run(app(["md5.pl"])), "md5 should fail in fips mode"); 851*b0d17251Schristos 852*b0d17251Schristos=item B<is_nofips EXPR1, EXPR2, TEST_NAME> 853*b0d17251Schristos 854*b0d17251SchristosC<is_nofips> is equivalent to using C<is> when the environment variable 855*b0d17251SchristosC<FIPS_MODE> is undefined, otherwise it is equivalent to C<isnt>. This can be 856*b0d17251Schristosused for C<is> tests that must fail when testing a FIPS provider. The parameters 857*b0d17251Schristosare the same as used by C<is> which has 2 arguments EXPR1 and EXPR2 that can be 858*b0d17251Schristoscompared using eq or ne, followed by a test description TEST_NAME. 859*b0d17251Schristos 860*b0d17251SchristosAn example: 861*b0d17251Schristos 862*b0d17251Schristos is_nofips(ultimate_answer(), 42, "Meaning of Life"); 863*b0d17251Schristos 864*b0d17251Schristos=item B<isnt_nofips EXPR1, EXPR2, TEST_NAME> 865*b0d17251Schristos 866*b0d17251SchristosC<isnt_nofips> is equivalent to using C<isnt> when the environment variable 867*b0d17251SchristosC<FIPS_MODE> is undefined, otherwise it is equivalent to C<is>. This can be 868*b0d17251Schristosused for C<isnt> tests that must fail when testing a FIPS provider. The 869*b0d17251Schristosparameters are the same as used by C<isnt> which has 2 arguments EXPR1 and EXPR2 870*b0d17251Schristosthat can be compared using ne or eq, followed by a test description TEST_NAME. 871*b0d17251Schristos 872*b0d17251SchristosAn example: 873*b0d17251Schristos 874*b0d17251Schristos isnt_nofips($foo, '', "Got some foo"); 875*b0d17251Schristos 876*b0d17251Schristos=back 877*b0d17251Schristos 878*b0d17251Schristos=cut 879*b0d17251Schristos 880*b0d17251Schristossub ok_nofips { 881*b0d17251Schristos return ok(!$_[0], @_[1..$#_]) if defined $ENV{FIPS_MODE}; 882*b0d17251Schristos return ok($_[0], @_[1..$#_]); 883*b0d17251Schristos} 884*b0d17251Schristos 885*b0d17251Schristossub is_nofips { 886*b0d17251Schristos return isnt($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE}; 887*b0d17251Schristos return is($_[0], $_[1], @_[2..$#_]); 888*b0d17251Schristos} 889*b0d17251Schristos 890*b0d17251Schristossub isnt_nofips { 891*b0d17251Schristos return is($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE}; 892*b0d17251Schristos return isnt($_[0], $_[1], @_[2..$#_]); 893*b0d17251Schristos} 894*b0d17251Schristos 89553060421Schristos###################################################################### 89653060421Schristos# private functions. These are never exported. 89753060421Schristos 89853060421Schristos=head1 ENVIRONMENT 89953060421Schristos 90053060421SchristosOpenSSL::Test depends on some environment variables. 90153060421Schristos 90253060421Schristos=over 4 90353060421Schristos 90453060421Schristos=item B<TOP> 90553060421Schristos 90653060421SchristosThis environment variable is mandatory. C<setup> will check that it's 90753060421Schristosdefined and that it's a directory that contains the file C<Configure>. 90853060421SchristosIf this isn't so, C<setup> will C<BAIL_OUT>. 90953060421Schristos 91053060421Schristos=item B<BIN_D> 91153060421Schristos 91253060421SchristosIf defined, its value should be the directory where the openssl application 91353060421Schristosis located. Defaults to C<$TOP/apps> (adapted to the operating system). 91453060421Schristos 91553060421Schristos=item B<TEST_D> 91653060421Schristos 91753060421SchristosIf defined, its value should be the directory where the test applications 91853060421Schristosare located. Defaults to C<$TOP/test> (adapted to the operating system). 91953060421Schristos 92053060421Schristos=item B<STOPTEST> 92153060421Schristos 92253060421SchristosIf defined, it puts testing in a different mode, where a recipe with 92353060421Schristosfailures will result in a C<BAIL_OUT> at the end of its run. 92453060421Schristos 925*b0d17251Schristos=item B<FIPS_MODE> 926*b0d17251Schristos 927*b0d17251SchristosIf defined it indicates that the FIPS provider is being tested. Tests may use 928*b0d17251SchristosB<ok_nofips>, B<is_nofips> and B<isnt_nofips> to invert test results 929*b0d17251Schristosi.e. Some tests may only work in non FIPS mode. 930*b0d17251Schristos 93153060421Schristos=back 93253060421Schristos 93353060421Schristos=cut 93453060421Schristos 93553060421Schristossub __env { 93653060421Schristos (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i; 93753060421Schristos 9384ce06407Schristos $directories{SRCTOP} = abs_path($ENV{SRCTOP} || $ENV{TOP}); 9394ce06407Schristos $directories{BLDTOP} = abs_path($ENV{BLDTOP} || $ENV{TOP}); 94053060421Schristos $directories{BLDAPPS} = $ENV{BIN_D} || __bldtop_dir("apps"); 94153060421Schristos $directories{SRCAPPS} = __srctop_dir("apps"); 94253060421Schristos $directories{BLDFUZZ} = __bldtop_dir("fuzz"); 94353060421Schristos $directories{SRCFUZZ} = __srctop_dir("fuzz"); 94453060421Schristos $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test"); 94553060421Schristos $directories{SRCTEST} = __srctop_dir("test"); 94653060421Schristos $directories{SRCDATA} = __srctop_dir("test", "recipes", 94753060421Schristos $recipe_datadir); 948*b0d17251Schristos $directories{RESULTTOP} = $ENV{RESULT_D} || __bldtop_dir("test-runs"); 949*b0d17251Schristos $directories{RESULTS} = catdir($directories{RESULTTOP}, $test_name); 950*b0d17251Schristos 951*b0d17251Schristos # Create result directory dynamically 952*b0d17251Schristos rmtree($directories{RESULTS}, { safe => 0, keep_root => 1 }); 953*b0d17251Schristos mkpath($directories{RESULTS}); 954*b0d17251Schristos 955*b0d17251Schristos # All directories are assumed to exist, except for SRCDATA. If that one 956*b0d17251Schristos # doesn't exist, just drop it. 957*b0d17251Schristos delete $directories{SRCDATA} unless -d $directories{SRCDATA}; 95853060421Schristos 95953060421Schristos push @direnv, "TOP" if $ENV{TOP}; 96053060421Schristos push @direnv, "SRCTOP" if $ENV{SRCTOP}; 96153060421Schristos push @direnv, "BLDTOP" if $ENV{BLDTOP}; 96253060421Schristos push @direnv, "BIN_D" if $ENV{BIN_D}; 96353060421Schristos push @direnv, "TEST_D" if $ENV{TEST_D}; 96453060421Schristos push @direnv, "RESULT_D" if $ENV{RESULT_D}; 96553060421Schristos 96653060421Schristos $end_with_bailout = $ENV{STOPTEST} ? 1 : 0; 96753060421Schristos}; 96853060421Schristos 96913d40330Schristos# __srctop_file and __srctop_dir are helpers to build file and directory 97013d40330Schristos# names on top of the source directory. They depend on $SRCTOP, and 97113d40330Schristos# therefore on the proper use of setup() and when needed, indir(). 97213d40330Schristos# __bldtop_file and __bldtop_dir do the same thing but relative to $BLDTOP. 97313d40330Schristos# __srctop_file and __bldtop_file take the same kind of argument as 97413d40330Schristos# File::Spec::Functions::catfile. 97513d40330Schristos# Similarly, __srctop_dir and __bldtop_dir take the same kind of argument 97613d40330Schristos# as File::Spec::Functions::catdir 97753060421Schristossub __srctop_file { 97853060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 97953060421Schristos 98053060421Schristos my $f = pop; 9817d004720Schristos return abs2rel(catfile($directories{SRCTOP},@_,$f),getcwd); 98253060421Schristos} 98353060421Schristos 98453060421Schristossub __srctop_dir { 98553060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 98653060421Schristos 9877d004720Schristos return abs2rel(catdir($directories{SRCTOP},@_), getcwd); 98853060421Schristos} 98953060421Schristos 99053060421Schristossub __bldtop_file { 99153060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 99253060421Schristos 99353060421Schristos my $f = pop; 9947d004720Schristos return abs2rel(catfile($directories{BLDTOP},@_,$f), getcwd); 99553060421Schristos} 99653060421Schristos 99753060421Schristossub __bldtop_dir { 99853060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 99953060421Schristos 10007d004720Schristos return abs2rel(catdir($directories{BLDTOP},@_), getcwd); 100153060421Schristos} 100253060421Schristos 100313d40330Schristos# __exeext is a function that returns the platform dependent file extension 100413d40330Schristos# for executable binaries, or the value of the environment variable $EXE_EXT 100513d40330Schristos# if that one is defined. 100653060421Schristossub __exeext { 100753060421Schristos my $ext = ""; 100853060421Schristos if ($^O eq "VMS" ) { # VMS 100953060421Schristos $ext = ".exe"; 101053060421Schristos } elsif ($^O eq "MSWin32") { # Windows 101153060421Schristos $ext = ".exe"; 101253060421Schristos } 101353060421Schristos return $ENV{"EXE_EXT"} || $ext; 101453060421Schristos} 101553060421Schristos 101613d40330Schristos# __test_file, __apps_file and __fuzz_file return the full path to a file 101713d40330Schristos# relative to the test/, apps/ or fuzz/ directory in the build tree or the 101813d40330Schristos# source tree, depending on where the file is found. Note that when looking 101913d40330Schristos# in the build tree, the file name with an added extension is looked for, if 102013d40330Schristos# an extension is given. The intent is to look for executable binaries (in 102113d40330Schristos# the build tree) or possibly scripts (in the source tree). 102213d40330Schristos# These functions all take the same arguments as File::Spec::Functions::catfile, 102313d40330Schristos# *plus* a mandatory extension argument. This extension argument can be undef, 102413d40330Schristos# and is ignored in such a case. 102553060421Schristossub __test_file { 102653060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 102753060421Schristos 102813d40330Schristos my $e = pop || ""; 102953060421Schristos my $f = pop; 103013d40330Schristos my $out = catfile($directories{BLDTEST},@_,$f . $e); 103153060421Schristos $out = catfile($directories{SRCTEST},@_,$f) unless -f $out; 103213d40330Schristos return $out; 103353060421Schristos} 103453060421Schristos 103553060421Schristossub __apps_file { 103653060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 103753060421Schristos 103813d40330Schristos my $e = pop || ""; 103953060421Schristos my $f = pop; 104013d40330Schristos my $out = catfile($directories{BLDAPPS},@_,$f . $e); 104113d40330Schristos $out = catfile($directories{SRCAPPS},@_,$f) unless -f $out; 104253060421Schristos return $out; 104353060421Schristos} 104453060421Schristos 104553060421Schristossub __fuzz_file { 104653060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 104753060421Schristos 104813d40330Schristos my $e = pop || ""; 104953060421Schristos my $f = pop; 105013d40330Schristos my $out = catfile($directories{BLDFUZZ},@_,$f . $e); 105113d40330Schristos $out = catfile($directories{SRCFUZZ},@_,$f) unless -f $out; 105253060421Schristos return $out; 105353060421Schristos} 105453060421Schristos 105553060421Schristossub __data_file { 105653060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 105753060421Schristos 1058*b0d17251Schristos return undef unless exists $directories{SRCDATA}; 1059*b0d17251Schristos 106053060421Schristos my $f = pop; 106153060421Schristos return catfile($directories{SRCDATA},@_,$f); 106253060421Schristos} 106353060421Schristos 106413d40330Schristossub __data_dir { 106513d40330Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 106613d40330Schristos 1067*b0d17251Schristos return undef unless exists $directories{SRCDATA}; 1068*b0d17251Schristos 106913d40330Schristos return catdir($directories{SRCDATA},@_); 107013d40330Schristos} 107113d40330Schristos 107213d40330Schristos# __cwd DIR 107313d40330Schristos# __cwd DIR, OPTS 107413d40330Schristos# 107513d40330Schristos# __cwd changes directory to DIR (string) and changes all the relative 107613d40330Schristos# entries in %directories accordingly. OPTS is an optional series of 107713d40330Schristos# hash style arguments to alter __cwd's behavior: 107813d40330Schristos# 107913d40330Schristos# create = 0|1 The directory we move to is created if 1, not if 0. 108013d40330Schristos 108153060421Schristossub __cwd { 108253060421Schristos my $dir = catdir(shift); 108353060421Schristos my %opts = @_; 1084*b0d17251Schristos 1085*b0d17251Schristos # If the directory is to be created, we must do that before using 1086*b0d17251Schristos # abs_path(). 1087*b0d17251Schristos $dir = canonpath($dir); 1088*b0d17251Schristos if ($opts{create}) { 1089*b0d17251Schristos mkpath($dir); 1090*b0d17251Schristos } 1091*b0d17251Schristos 1092*b0d17251Schristos my $abscurdir = abs_path(curdir()); 1093*b0d17251Schristos my $absdir = abs_path($dir); 109453060421Schristos my $reverse = abs2rel($abscurdir, $absdir); 109553060421Schristos 109653060421Schristos # PARANOIA: if we're not moving anywhere, we do nothing more 109753060421Schristos if ($abscurdir eq $absdir) { 109853060421Schristos return $reverse; 109953060421Schristos } 110053060421Schristos 110153060421Schristos # Do not support a move to a different volume for now. Maybe later. 110253060421Schristos BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported") 110353060421Schristos if $reverse eq $abscurdir; 110453060421Schristos 110553060421Schristos # If someone happened to give a directory that leads back to the current, 110653060421Schristos # it's extremely silly to do anything more, so just simulate that we did 110753060421Schristos # move. 110853060421Schristos # In this case, we won't even clean it out, for safety's sake. 110953060421Schristos return "." if $reverse eq ""; 111053060421Schristos 111153060421Schristos # We are recalculating the directories we keep track of, but need to save 111253060421Schristos # away the result for after having moved into the new directory. 111353060421Schristos my %tmp_directories = (); 111453060421Schristos my %tmp_ENV = (); 111553060421Schristos 111653060421Schristos # For each of these directory variables, figure out where they are relative 111753060421Schristos # to the directory we want to move to if they aren't absolute (if they are, 111853060421Schristos # they don't change!) 111953060421Schristos my @dirtags = sort keys %directories; 112053060421Schristos foreach (@dirtags) { 112153060421Schristos if (!file_name_is_absolute($directories{$_})) { 1122*b0d17251Schristos my $oldpath = abs_path($directories{$_}); 1123*b0d17251Schristos my $newpath = abs2rel($oldpath, $absdir); 1124*b0d17251Schristos if ($debug) { 1125*b0d17251Schristos print STDERR "DEBUG: [dir $_] old path: $oldpath\n"; 1126*b0d17251Schristos print STDERR "DEBUG: [dir $_] new base: $absdir\n"; 1127*b0d17251Schristos print STDERR "DEBUG: [dir $_] resulting new path: $newpath\n"; 1128*b0d17251Schristos } 112953060421Schristos $tmp_directories{$_} = $newpath; 113053060421Schristos } 113153060421Schristos } 113253060421Schristos 113353060421Schristos # Treat each environment variable that was used to get us the values in 113453060421Schristos # %directories the same was as the paths in %directories, so any sub 113553060421Schristos # process can use their values properly as well 113653060421Schristos foreach (@direnv) { 113753060421Schristos if (!file_name_is_absolute($ENV{$_})) { 1138*b0d17251Schristos my $oldpath = abs_path($ENV{$_}); 1139*b0d17251Schristos my $newpath = abs2rel($oldpath, $absdir); 1140*b0d17251Schristos if ($debug) { 1141*b0d17251Schristos print STDERR "DEBUG: [env $_] old path: $oldpath\n"; 1142*b0d17251Schristos print STDERR "DEBUG: [env $_] new base: $absdir\n"; 1143*b0d17251Schristos print STDERR "DEBUG: [env $_] resulting new path: $newpath\n"; 1144*b0d17251Schristos } 114553060421Schristos $tmp_ENV{$_} = $newpath; 114653060421Schristos } 114753060421Schristos } 114853060421Schristos 114953060421Schristos # Should we just bail out here as well? I'm unsure. 115053060421Schristos return undef unless chdir($dir); 115153060421Schristos 115253060421Schristos # We put back new values carefully. Doing the obvious 115313d40330Schristos # %directories = ( %tmp_directories ) 115453060421Schristos # will clear out any value that happens to be an absolute path 115553060421Schristos foreach (keys %tmp_directories) { 115653060421Schristos $directories{$_} = $tmp_directories{$_}; 115753060421Schristos } 115853060421Schristos foreach (keys %tmp_ENV) { 115953060421Schristos $ENV{$_} = $tmp_ENV{$_}; 116053060421Schristos } 116153060421Schristos 116253060421Schristos if ($debug) { 116353060421Schristos print STDERR "DEBUG: __cwd(), directories and files:\n"; 1164*b0d17251Schristos print STDERR " Moving from $abscurdir\n"; 1165*b0d17251Schristos print STDERR " Moving to $absdir\n"; 1166*b0d17251Schristos print STDERR "\n"; 116753060421Schristos print STDERR " \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n"; 116853060421Schristos print STDERR " \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n"; 1169*b0d17251Schristos print STDERR " \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n" 1170*b0d17251Schristos if exists $directories{SRCDATA}; 117153060421Schristos print STDERR " \$directories{RESULTS} = \"$directories{RESULTS}\"\n"; 117253060421Schristos print STDERR " \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n"; 117353060421Schristos print STDERR " \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n"; 117453060421Schristos print STDERR " \$directories{SRCTOP} = \"$directories{SRCTOP}\"\n"; 117553060421Schristos print STDERR " \$directories{BLDTOP} = \"$directories{BLDTOP}\"\n"; 117653060421Schristos print STDERR "\n"; 117753060421Schristos print STDERR " the way back is \"$reverse\"\n"; 117853060421Schristos } 117953060421Schristos 118053060421Schristos return $reverse; 118153060421Schristos} 118253060421Schristos 118313d40330Schristos# __wrap_cmd CMD 118413d40330Schristos# __wrap_cmd CMD, EXE_SHELL 118513d40330Schristos# 118613d40330Schristos# __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure 118713d40330Schristos# the command gets executed with an appropriate environment. If EXE_SHELL 118813d40330Schristos# is given, it is used as the beginning command. 118913d40330Schristos# 119013d40330Schristos# __wrap_cmd returns a list that should be used to build up a larger list 119113d40330Schristos# of command tokens, or be joined together like this: 119213d40330Schristos# 119313d40330Schristos# join(" ", __wrap_cmd($cmd)) 119413d40330Schristossub __wrap_cmd { 119513d40330Schristos my $cmd = shift; 119653060421Schristos my $exe_shell = shift; 119753060421Schristos 1198*b0d17251Schristos my @prefix = (); 119953060421Schristos 120053060421Schristos if (defined($exe_shell)) { 1201*b0d17251Schristos # If $exe_shell is defined, trust it 120213d40330Schristos @prefix = ( $exe_shell ); 1203*b0d17251Schristos } else { 1204*b0d17251Schristos # Otherwise, use the standard wrapper 1205*b0d17251Schristos my $std_wrapper = __bldtop_file("util", "wrap.pl"); 1206*b0d17251Schristos 1207*b0d17251Schristos if ($^O eq "VMS" || $^O eq "MSWin32") { 1208*b0d17251Schristos # On VMS and Windows, we run the perl executable explicitly, 1209*b0d17251Schristos # with necessary fixups. We might not need that for Windows, 1210*b0d17251Schristos # but that depends on if the user has associated the '.pl' 1211*b0d17251Schristos # extension with a perl interpreter, so better be safe. 1212*b0d17251Schristos @prefix = ( __fixup_prg($^X), $std_wrapper ); 1213*b0d17251Schristos } else { 1214*b0d17251Schristos # Otherwise, we assume Unix semantics, and trust that the #! 1215*b0d17251Schristos # line activates perl for us. 1216*b0d17251Schristos @prefix = ( $std_wrapper ); 1217*b0d17251Schristos } 121853060421Schristos } 121953060421Schristos 122013d40330Schristos return (@prefix, $cmd); 122153060421Schristos} 122213d40330Schristos 122313d40330Schristos# __fixup_prg PROG 122413d40330Schristos# 122513d40330Schristos# __fixup_prg does whatever fixup is needed to execute an executable binary 122613d40330Schristos# given by PROG (string). 122713d40330Schristos# 122813d40330Schristos# __fixup_prg returns a string with the possibly prefixed program path spec. 122913d40330Schristossub __fixup_prg { 123013d40330Schristos my $prog = shift; 123113d40330Schristos 1232*b0d17251Schristos return join(' ', fixup_cmd($prog)); 123353060421Schristos} 123453060421Schristos 123513d40330Schristos# __decorate_cmd NUM, CMDARRAYREF 123613d40330Schristos# 123713d40330Schristos# __decorate_cmd takes a command number NUM and a command token array 123813d40330Schristos# CMDARRAYREF, builds up a command string from them and decorates it 123913d40330Schristos# with necessary redirections. 124013d40330Schristos# __decorate_cmd returns a list of two strings, one with the command 124113d40330Schristos# string to actually be used, the other to be displayed for the user. 124213d40330Schristos# The reason these strings might differ is that we redirect stderr to 124313d40330Schristos# the null device unless we're verbose and unless the user has 124413d40330Schristos# explicitly specified a stderr redirection. 124513d40330Schristossub __decorate_cmd { 124653060421Schristos BAIL_OUT("Must run setup() first") if (! $test_name); 124753060421Schristos 124853060421Schristos my $num = shift; 124913d40330Schristos my $cmd = shift; 125053060421Schristos my %opts = @_; 125153060421Schristos 125213d40330Schristos my $cmdstr = join(" ", @$cmd); 125353060421Schristos my $null = devnull(); 125453060421Schristos my $fileornull = sub { $_[0] ? $_[0] : $null; }; 125553060421Schristos my $stdin = ""; 125653060421Schristos my $stdout = ""; 125753060421Schristos my $stderr = ""; 125853060421Schristos my $saved_stderr = undef; 125953060421Schristos $stdin = " < ".$fileornull->($opts{stdin}) if exists($opts{stdin}); 126053060421Schristos $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout}); 126153060421Schristos $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr}); 126253060421Schristos 126313d40330Schristos my $display_cmd = "$cmdstr$stdin$stdout$stderr"; 126453060421Schristos 1265*b0d17251Schristos # VMS program output escapes TAP::Parser 1266*b0d17251Schristos if ($^O eq 'VMS') { 126753060421Schristos $stderr=" 2> ".$null 126853060421Schristos unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; 1269*b0d17251Schristos } 127053060421Schristos 127113d40330Schristos $cmdstr .= "$stdin$stdout$stderr"; 127253060421Schristos 127353060421Schristos if ($debug) { 127413d40330Schristos print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n"; 127513d40330Schristos print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n"; 127653060421Schristos } 127753060421Schristos 127813d40330Schristos return ($cmdstr, $display_cmd); 127953060421Schristos} 128053060421Schristos 128153060421Schristos=head1 SEE ALSO 128253060421Schristos 128353060421SchristosL<Test::More>, L<Test::Harness> 128453060421Schristos 128553060421Schristos=head1 AUTHORS 128653060421Schristos 128713d40330SchristosRichard Levitte E<lt>levitte@openssl.orgE<gt> with assistance and 128853060421Schristosinspiration from Andy Polyakov E<lt>appro@openssl.org<gt>. 128953060421Schristos 129053060421Schristos=cut 129153060421Schristos 129213d40330Schristosno warnings 'redefine'; 129313d40330Schristossub subtest { 129413d40330Schristos $level++; 129513d40330Schristos 129613d40330Schristos Test::More::subtest @_; 129713d40330Schristos 129813d40330Schristos $level--; 129913d40330Schristos}; 130013d40330Schristos 130153060421Schristos1; 1302