xref: /netbsd-src/crypto/external/bsd/openssl/dist/util/perl/OpenSSL/Test.pm (revision b0d1725196a7921d003d2c66a14f186abda4176b)
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