X-Git-Url: https://git.openssl.org/gitweb/?a=blobdiff_plain;f=test%2Ftestlib%2FOpenSSL%2FTest.pm;h=2cfb22a6533a9a143a1b9f6f878c76b46cc6778b;hb=81b538e51e34e258af96ebaf147c0059ef855829;hp=ecac93f8dbc1a14a612e1a76e3250118e5133939;hpb=fa657fc8df1744d1531aba2e269e03d73a12fda9;p=openssl.git diff --git a/test/testlib/OpenSSL/Test.pm b/test/testlib/OpenSSL/Test.pm index ecac93f8db..2cfb22a653 100644 --- a/test/testlib/OpenSSL/Test.pm +++ b/test/testlib/OpenSSL/Test.pm @@ -1,3 +1,10 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + package OpenSSL::Test; use strict; @@ -60,6 +67,11 @@ my $test_name = undef; # (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D. my %directories = (); +# The environment variables that gave us the contents in %directories. These +# get modified whenever we change directories, so that subprocesses can use +# the values of those environment variables as well +my @direnv = (); + # A bool saying if we shall stop all testing if the current recipe has failing # tests or not. This is set by setup() if the environment variable STOPTEST # is defined with a non-empty value. @@ -244,7 +256,23 @@ string PATH, I, if the value is C, C or similar. =item B Both these functions function the same way as B and B, except -that they expect the command to be a perl script. +that they expect the command to be a perl script. Also, they support one +more option: + +=over 4 + +=item B ARRAYref> + +The array reference is a set of arguments for perl rather than the script. +Take care so that none of them can be seen as a script! Flags and their +eventual arguments only! + +=back + +An example: + + ok(run(perlapp(["foo.pl", "arg1"], + interpreter_args => [ "-I", srctop_dir("test") ]))); =back @@ -324,15 +352,42 @@ sub run { my @r = (); my $r = 0; my $e = 0; + + # In non-verbose, we want to shut up the command interpreter, in case + # it has something to complain about. On VMS, it might complain both + # on stdout and stderr + my $save_STDOUT; + my $save_STDERR; + if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { + open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!"; + open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!"; + open STDOUT, ">", devnull(); + open STDERR, ">", devnull(); + } + + # The dance we do with $? is the same dance the Unix shells appear to + # do. For example, a program that gets aborted (and therefore signals + # SIGABRT = 6) will appear to exit with the code 134. We mimic this + # to make it easier to compare with a manual run of the command. if ($opts{capture}) { @r = `$prefix$cmd`; - $e = $? >> 8; + $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); } else { system("$prefix$cmd"); - $e = $? >> 8; + $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); $r = $hooks{exit_checker}->($e); } + if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { + close STDOUT; + close STDERR; + open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!"; + open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!"; + } + + print STDERR "$prefix$display_cmd => $e\n" + if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; + # At this point, $? stops being interesting, and unfortunately, # there are Test::More versions that get picky if we leave it # non-zero. @@ -524,19 +579,42 @@ sub with { =over 4 -=item B +=item B C takes a CODEREF from C or C and simply returns the command as a string. +C takes some additiona options OPTS that affect the string returned: + +=over 4 + +=item B 0|1> + +When set to 0, the returned string will be with all decorations, such as a +possible redirect of stderr to the null device. This is suitable if the +string is to be used directly in a recipe. + +When set to 1, the returned string will be without extra decorations. This +is suitable for display if that is desired (doesn't confuse people with all +internal stuff), or if it's used to pass a command down to a subprocess. + +Default: 0 + +=back + =back =cut sub cmdstr { my ($cmd, $display_cmd) = shift->(0); + my %opts = @_; - return $display_cmd; + if ($opts{display}) { + return $display_cmd; + } else { + return $cmd; + } } =over 4 @@ -621,9 +699,18 @@ failures will result in a C at the end of its run. sub __env { $directories{SRCTOP} = $ENV{SRCTOP} || $ENV{TOP}; $directories{BLDTOP} = $ENV{BLDTOP} || $ENV{TOP}; - $directories{APPS} = $ENV{BIN_D} || __bldtop_dir("apps"); - $directories{TEST} = $ENV{TEST_D} || __bldtop_dir("test"); - $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST}; + $directories{BLDAPPS} = $ENV{BIN_D} || __bldtop_dir("apps"); + $directories{SRCAPPS} = __srctop_dir("apps"); + $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test"); + $directories{SRCTEST} = __srctop_dir("test"); + $directories{RESULTS} = $ENV{RESULT_D} || $directories{BLDTEST}; + + push @direnv, "TOP" if $ENV{TOP}; + push @direnv, "SRCTOP" if $ENV{SRCTOP}; + push @direnv, "BLDTOP" if $ENV{BLDTOP}; + push @direnv, "BIN_D" if $ENV{BIN_D}; + push @direnv, "TEST_D" if $ENV{TEST_D}; + push @direnv, "RESULT_D" if $ENV{RESULT_D}; $end_with_bailout = $ENV{STOPTEST} ? 1 : 0; }; @@ -654,32 +741,50 @@ sub __bldtop_dir { return catdir($directories{BLDTOP},@_); } +sub __exeext { + my $ext = ""; + if ($^O eq "VMS" ) { # VMS + $ext = ".exe"; + } elsif ($^O eq "MSWin32") { # Windows + $ext = ".exe"; + } + return $ENV{"EXE_EXT"} || $ext; +} + sub __test_file { BAIL_OUT("Must run setup() first") if (! $test_name); my $f = pop; - return catfile($directories{TEST},@_,$f); + $f = catfile($directories{BLDTEST},@_,$f . __exeext()); + $f = catfile($directories{SRCTEST},@_,$f) unless -x $f; + return $f; } sub __perltest_file { BAIL_OUT("Must run setup() first") if (! $test_name); my $f = pop; - return ($^X, catfile($directories{TEST},@_,$f)); + $f = catfile($directories{BLDTEST},@_,$f); + $f = catfile($directories{SRCTEST},@_,$f) unless -f $f; + return ($^X, $f); } sub __apps_file { BAIL_OUT("Must run setup() first") if (! $test_name); my $f = pop; - return catfile($directories{APPS},@_,$f); + $f = catfile($directories{BLDAPPS},@_,$f . __exeext()); + $f = catfile($directories{SRCAPPS},@_,$f) unless -x $f; + return $f; } sub __perlapps_file { BAIL_OUT("Must run setup() first") if (! $test_name); my $f = pop; - return ($^X, catfile($directories{APPS},@_,$f)); + $f = catfile($directories{BLDAPPS},@_,$f); + $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f; + return ($^X, $f); } sub __results_file { @@ -734,11 +839,23 @@ sub __cwd { } } + # Treat each environment variable that was used to get us the values in + # %directories the same was as the paths in %directories, so any sub + # process can use their values properly as well + foreach (@direnv) { + if (!file_name_is_absolute($ENV{$_})) { + my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir)); + $ENV{$_} = $newpath; + } + } + if ($debug) { print STDERR "DEBUG: __cwd(), directories and files:\n"; - print STDERR " \$directories{TEST} = \"$directories{TEST}\"\n"; + print STDERR " \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n"; + print STDERR " \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n"; print STDERR " \$directories{RESULTS} = \"$directories{RESULTS}\"\n"; - print STDERR " \$directories{APPS} = \"$directories{APPS}\"\n"; + print STDERR " \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n"; + print STDERR " \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n"; print STDERR " \$directories{SRCTOP} = \"$directories{SRCTOP}\"\n"; print STDERR " \$directories{BLDTOP} = \"$directories{BLDTOP}\"\n"; print STDERR "\n"; @@ -754,23 +871,20 @@ sub __fixup_cmd { my $exe_shell = shift; my $prefix = __bldtop_file("util", "shlib_wrap.sh")." "; - my $ext = $ENV{"EXE_EXT"} || ""; if (defined($exe_shell)) { $prefix = "$exe_shell "; } elsif ($^O eq "VMS" ) { # VMS $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []"); - $ext = ".exe"; } elsif ($^O eq "MSWin32") { # Windows $prefix = ""; - $ext = ".exe"; } # We test both with and without extension. The reason # is that we might be passed a complete file spec, with # extension. if ( ! -x $prog ) { - my $prog = "$prog$ext"; + my $prog = "$prog"; if ( ! -x $prog ) { $prog = undef; } @@ -796,6 +910,7 @@ sub __build_cmd { my $path_builder = shift; # Make a copy to not destroy the caller's array my @cmdarray = ( @{$_[0]} ); shift; + my %opts = @_; # We do a little dance, as $path_builder might return a list of # more than one. If so, only the first is to be considered a @@ -815,8 +930,9 @@ sub __build_cmd { } } my @args = (@prog, @cmdarray); - - my %opts = @_; + if (defined($opts{interpreter_args})) { + unshift @args, @{$opts{interpreter_args}}; + } return () if !$cmd;