X-Git-Url: https://git.openssl.org/gitweb/?p=openssl.git;a=blobdiff_plain;f=test%2Ftestlib%2FOpenSSL%2FTest.pm;h=b0a609fd4d3e382ba625499ef8e095bab130e5a2;hp=c64d68de46c35848ff4d635e50ed5c1b4ce60004;hb=349232d149804dae09987af7612000e30ee7c4cc;hpb=ceffb33db28d067fde07531c3fd36a0ed4b95ded diff --git a/test/testlib/OpenSSL/Test.pm b/test/testlib/OpenSSL/Test.pm index c64d68de46..b0a609fd4d 100644 --- a/test/testlib/OpenSSL/Test.pm +++ b/test/testlib/OpenSSL/Test.pm @@ -7,11 +7,12 @@ use Test::More 0.96; use Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); -$VERSION = "0.7"; +$VERSION = "0.8"; @ISA = qw(Exporter); -@EXPORT = (@Test::More::EXPORT, qw(setup indir app test run)); -@EXPORT_OK = (@Test::More::EXPORT_OK, qw(top_dir top_file pipe with cmdstr - quotify)); +@EXPORT = (@Test::More::EXPORT, qw(setup indir app perlapp test perltest run)); +@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file + srctop_dir srctop_file + pipe with cmdstr quotify)); =head1 NAME @@ -37,8 +38,9 @@ In addition to the Test::More functions, it also provides functions that easily find the diverse programs within a OpenSSL build tree, as well as some other useful functions. -This module I on the environment variable C<$TOP>. Without it, -it refuses to work. See L below. +This module I on the environment variables C<$TOP> or C<$SRCTOP> +and C<$BLDTOP>. Without one of the combinations it refuses to work. +See L below. =cut @@ -46,7 +48,7 @@ use File::Copy; use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir catdir catfile splitpath catpath devnull abs2rel rel2abs/; -use File::Path 2.00 qw/remove_tree mkpath/; +use File::Path 2.00 qw/rmtree mkpath/; # The name of the test. This is set by setup() and is used in the other @@ -55,7 +57,7 @@ my $test_name = undef; # Directories we want to keep track of TOP, APPS, TEST and RESULTS are the # ones we're interested in, corresponding to the environment variables TOP -# (mandatory), BIN_D, TEST_D and RESULT_D. +# (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D. my %directories = (); # A bool saying if we shall stop all testing if the current recipe has failing @@ -76,9 +78,14 @@ my %hooks = ( ); +# Debug flag, to be set manually when needed +my $debug = 0; + # Declare some utility functions that are defined at the end -sub top_file; -sub top_dir; +sub bldtop_file; +sub bldtop_dir; +sub srctop_file; +sub srctop_dir; sub quotify; # Declare some private functions that are defined at the end @@ -86,8 +93,6 @@ sub __env; sub __cwd; sub __apps_file; sub __results_file; -sub __test_log; -sub __cwd; sub __fixup_cmd; sub __build_cmd; @@ -106,29 +111,36 @@ If it's not used in a OpenSSL test recipe, the rest of the recipe will most likely refuse to run. C checks for environment variables (see L below), -check that C<$TOP/Configure> exists, C into the results directory -(defined by the C<$RESULT_D> environment variable if defined, otherwise -C<$TEST_D> if defined, otherwise C<$TOP/test>). +checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C +into the results directory (defined by the C<$RESULT_D> environment +variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever +is defined). =back =cut sub setup { + my $old_test_name = $test_name; $test_name = shift; BAIL_OUT("setup() must receive a name") unless $test_name; - BAIL_OUT("setup() needs \$TOP to be defined") unless $ENV{TOP}; + warn "setup() detected test name change. Innocuous, so we continue...\n" + if $old_test_name && $old_test_name ne $test_name; + + return if $old_test_name; + + BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined") + unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP}); + BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...") + if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP}); __env(); - BAIL_OUT("setup() expects the file Configure in the \$TOP directory") - unless -f top_file("Configure"); + BAIL_OUT("setup() expects the file Configure in the source top directory") + unless -f srctop_file("Configure"); __cwd($directories{RESULTS}); - - # Loop in case we're on a platform with more than one file generation - 1 while unlink(__test_log()); } =over 4 @@ -187,7 +199,7 @@ sub indir { __cwd($reverse); if ($opts{cleanup}) { - remove_tree($subdir, { safe => 0 }); + rmtree($subdir, { safe => 0 }); } } @@ -201,10 +213,12 @@ Both of these functions take a reference to a list that is a command and its arguments, and some additional options (described further on). C expects to find the given command (the first item in the given list -reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>). +reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps> +or C<$BLDTOP/apps>). C expects to find the given command (the first item in the given list -reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>). +reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test> +or C<$BLDTOP/test>). Both return a CODEREF to be used by C, C or C. @@ -225,6 +239,29 @@ string PATH, I, if the value is C, C or similar. =back +=item B + +=item B + +Both these functions function the same way as B and B, except +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 =cut @@ -243,6 +280,20 @@ sub test { return __build_cmd($num, \&__test_file, $cmd, %opts); } } +sub perlapp { + my $cmd = shift; + my %opts = @_; + return sub { my $num = shift; + return __build_cmd($num, \&__perlapps_file, $cmd, %opts); } +} + +sub perltest { + my $cmd = shift; + my %opts = @_; + return sub { my $num = shift; + return __build_cmd($num, \&__perltest_file, $cmd, %opts); } +} + =over 4 =item B @@ -276,7 +327,7 @@ the function C further down. =cut sub run { - my ($cmd, $display_cmd, %errlogs) = shift->(0); + my ($cmd, $display_cmd) = shift->(0); my %opts = @_; return () if !$cmd; @@ -284,36 +335,33 @@ sub run { my $prefix = ""; if ( $^O eq "VMS" ) { # VMS $prefix = "pipe "; - } elsif ($^O eq "MSWin32") { # MSYS - $prefix = "cmd /c "; } my @r = (); my $r = 0; my $e = 0; + + # 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); } + 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. $? = 0; - open ERR, ">>", __test_log(); - { local $| = 1; print ERR "$display_cmd => $e\n"; } - foreach (keys %errlogs) { - copy($_,\*ERR); - copy($_,$errlogs{$_}) if defined($errlogs{$_}); - unlink($_); - } - close ERR; - if ($opts{capture}) { return @r; } else { @@ -333,11 +381,11 @@ END { The following functions are exported on request when using C. - # To only get the top_file function. - use OpenSSL::Test qw/top_file/; + # To only get the bldtop_file and srctop_file functions. + use OpenSSL::Test qw/bldtop_file srctop_file/; - # To only get the top_file function in addition to the default ones. - use OpenSSL::Test qw/:DEFAULT top_file/; + # To only get the bldtop_file function in addition to the default ones. + use OpenSSL::Test qw/:DEFAULT bldtop_file/; =cut @@ -345,38 +393,76 @@ The following functions are exported on request when using C. =over 4 -=item B +=item B + +LIST is a list of directories that make up a path from the top of the OpenSSL +build directory (as indicated by the environment variable C<$TOP> or +C<$BLDTOP>). +C returns the resulting directory as a string, adapted to the local +operating system. + +=back + +=cut + +sub bldtop_dir { + return __bldtop_dir(@_); # This caters for operating systems that have + # a very distinct syntax for directories. +} + +=over 4 + +=item B + +LIST is a list of directories that make up a path from the top of the OpenSSL +build directory (as indicated by the environment variable C<$TOP> or +C<$BLDTOP>) and FILENAME is the name of a file located in that directory path. +C returns the resulting file path as a string, adapted to the local +operating system. + +=back + +=cut + +sub bldtop_file { + return __bldtop_file(@_); +} + +=over 4 + +=item B LIST is a list of directories that make up a path from the top of the OpenSSL -source directory (as indicated by the environment variable C<$TOP>). -C returns the resulting directory as a string, adapted to the local +source directory (as indicated by the environment variable C<$TOP> or +C<$SRCTOP>). +C returns the resulting directory as a string, adapted to the local operating system. =back =cut -sub top_dir { - return __top_file(@_, ""); # This caters for operating systems that have +sub srctop_dir { + return __srctop_dir(@_); # This caters for operating systems that have # a very distinct syntax for directories. } =over 4 -=item B +=item B LIST is a list of directories that make up a path from the top of the OpenSSL -source directory (as indicated by the environment variable C<$TOP>) and -FILENAME is the name of a file located in that directory path. -C returns the resulting file path as a string, adapted to the local +source directory (as indicated by the environment variable C<$TOP> or +C<$SRCTOP>) and FILENAME is the name of a file located in that directory path. +C returns the resulting file path as a string, adapted to the local operating system. =back =cut -sub top_file { - return __top_file(@_); +sub srctop_file { + return __srctop_file(@_); } =over 4 @@ -472,9 +558,9 @@ command as a string. =cut sub cmdstr { - my ($cmd, $display_cmd, %errlogs) = shift->(0); + my ($cmd, $display_cmd) = shift->(0); - return $display_cmd; + return $cmd; } =over 4 @@ -547,11 +633,6 @@ is located. Defaults to C<$TOP/apps> (adapted to the operating system). If defined, its value should be the directory where the test applications are located. Defaults to C<$TOP/test> (adapted to the operating system). -=item B - -If defined, its value should be the directory where the log files are -located. Defaults to C<$TEST_D>. - =item B If defined, it puts testing in a different mode, where a recipe with @@ -562,33 +643,87 @@ failures will result in a C at the end of its run. =cut sub __env { - $directories{TOP} = $ENV{TOP}, - $directories{APPS} = $ENV{BIN_D} || catdir($directories{TOP},"apps"); - $directories{TEST} = $ENV{TEST_D} || catdir($directories{TOP},"test"); - $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST}; + $directories{SRCTOP} = $ENV{SRCTOP} || $ENV{TOP}; + $directories{BLDTOP} = $ENV{BLDTOP} || $ENV{TOP}; + $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}; $end_with_bailout = $ENV{STOPTEST} ? 1 : 0; }; -sub __top_file { +sub __srctop_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return catfile($directories{SRCTOP},@_,$f); +} + +sub __srctop_dir { + BAIL_OUT("Must run setup() first") if (! $test_name); + + return catdir($directories{SRCTOP},@_); +} + +sub __bldtop_file { BAIL_OUT("Must run setup() first") if (! $test_name); my $f = pop; - return catfile($directories{TOP},@_,$f); + return catfile($directories{BLDTOP},@_,$f); +} + +sub __bldtop_dir { + BAIL_OUT("Must run setup() first") if (! $test_name); + + 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 . __exeext(); + $f = catfile($directories{BLDTEST},@_,$f); + $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 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 . __exeext(); + $f = catfile($directories{BLDAPPS},@_,$f); + $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 catfile($directories{APPS},@_,$f); + $f = catfile($directories{BLDAPPS},@_,$f); + $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f; + return ($^X, $f); } sub __results_file { @@ -598,12 +733,8 @@ sub __results_file { return catfile($directories{RESULTS},@_,$f); } -sub __test_log { - return __results_file("$test_name.log"); -} - sub __cwd { - my $dir = shift; + my $dir = catdir(shift); my %opts = @_; my $abscurdir = rel2abs(curdir()); my $absdir = rel2abs($dir); @@ -633,13 +764,13 @@ sub __cwd { return undef unless chdir($dir); if ($opts{cleanup}) { - remove_tree(".", { safe => 0, keep_root => 1 }); + rmtree(".", { safe => 0, keep_root => 1 }); } # For each of these directory variables, figure out where they are relative # to the directory we want to move to if they aren't absolute (if they are, # they don't change!) - my @dirtags = ("TOP", "TEST", "APPS", "RESULTS"); + my @dirtags = sort keys %directories; foreach (@dirtags) { if (!file_name_is_absolute($directories{$_})) { my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir)); @@ -647,13 +778,15 @@ sub __cwd { } } - if (0) { + 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{TOP} = \"$directories{TOP}\"\n"; - print STDERR " \$test_log = \"",__test_log(),"\"\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"; print STDERR " current directory is \"",curdir(),"\"\n"; print STDERR " the way back is \"$reverse\"\n"; @@ -664,26 +797,35 @@ sub __cwd { sub __fixup_cmd { my $prog = shift; + my $exe_shell = shift; - my $prefix = __top_file("util", "shlib_wrap.sh")." "; - my $ext = $ENV{"EXE_EXT"} || ""; + my $prefix = __bldtop_file("util", "shlib_wrap.sh")." "; - if ( $^O eq "VMS" ) { # VMS - $prefix = "mcr "; - $ext = ".exe"; + if (defined($exe_shell)) { + $prefix = "$exe_shell "; + } elsif ($^O eq "VMS" ) { # VMS + $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []"); } elsif ($^O eq "MSWin32") { # Windows $prefix = ""; - $ext = ".exe"; } # We test both with and without extension. The reason - # is that we might, for example, be passed a Perl script - # ending with .pl... - my $file = "$prog$ext"; - if ( -x $file ) { - return $prefix.$file; - } elsif ( -f $prog ) { - return $prog; + # is that we might be passed a complete file spec, with + # extension. + if ( ! -x $prog ) { + my $prog = "$prog"; + if ( ! -x $prog ) { + $prog = undef; + } + } + + if (defined($prog)) { + # Make sure to quotify the program file on platforms that may + # have spaces or similar in their path name. + # To our knowledge, VMS is the exception where quotifying should + # never happem. + ($prog) = quotify($prog) unless $^O eq "VMS"; + return $prefix.$prog; } print STDERR "$prog not found\n"; @@ -697,10 +839,30 @@ sub __build_cmd { my $path_builder = shift; # Make a copy to not destroy the caller's array my @cmdarray = ( @{$_[0]} ); shift; - my $cmd = __fixup_cmd($path_builder->(shift @cmdarray)); - my @args = @cmdarray; 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 + # program to fix up, the rest is part of the arguments. This + # happens for perl scripts, where $path_builder will return + # a list of two, $^X and the script name. + # Also, if $path_builder returned more than one, we don't apply + # the EXE_SHELL environment variable. + my @prog = ($path_builder->(shift @cmdarray)); + my $first = shift @prog; + my $exe_shell = @prog ? undef : $ENV{EXE_SHELL}; + my $cmd = __fixup_cmd($first, $exe_shell); + if (@prog) { + if ( ! -f $prog[0] ) { + print STDERR "$prog[0] not found\n"; + $cmd = undef; + } + } + my @args = (@prog, @cmdarray); + if (defined($opts{interpreter_args})) { + unshift @args, @{$opts{interpreter_args}}; + } + return () if !$cmd; my $arg_str = ""; @@ -718,14 +880,19 @@ sub __build_cmd { $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout}); $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr}); - $saved_stderr = $opts{stderr} if defined($opts{stderr}); - - my $errlog = - __results_file($num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err"); my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr"; - $cmd .= "$arg_str$stdin$stdout 2> $errlog"; - return ($cmd, $display_cmd, $errlog => $saved_stderr); + $stderr=" 2> ".$null + unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; + + $cmd .= "$arg_str$stdin$stdout$stderr"; + + if ($debug) { + print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n"; + print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n"; + } + + return ($cmd, $display_cmd); } =head1 SEE ALSO