diff options
| -rw-r--r-- | test/testlib/OpenSSL/Test.pm | 88 |
1 files changed, 77 insertions, 11 deletions
diff --git a/test/testlib/OpenSSL/Test.pm b/test/testlib/OpenSSL/Test.pm index e4218c55f5..491984cee4 100644 --- a/test/testlib/OpenSSL/Test.pm +++ b/test/testlib/OpenSSL/Test.pm @@ -9,7 +9,7 @@ use Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); $VERSION = "0.7"; @ISA = qw(Exporter); -@EXPORT = (@Test::More::EXPORT, qw(setup indir app test run)); +@EXPORT = (@Test::More::EXPORT, qw(setup indir app perlapp test perltest run)); @EXPORT_OK = (@Test::More::EXPORT_OK, qw(top_dir top_file pipe with cmdstr quotify)); @@ -76,6 +76,9 @@ 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; @@ -224,6 +227,13 @@ string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar. =back +=item B<perlapp ARRAYREF, OPTS> + +=item B<perltest ARRAYREF, OPTS> + +Both these functions function the same way as B<app> and B<test>, except +that they expect the command to be a perl script. + =back =cut @@ -242,6 +252,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<run CODEREF, OPTS> @@ -587,6 +611,13 @@ sub __test_file { return catfile($directories{TEST},@_,$f); } +sub __perltest_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return ($^X, catfile($directories{TEST},@_,$f)); +} + sub __apps_file { BAIL_OUT("Must run setup() first") if (! $test_name); @@ -594,6 +625,13 @@ sub __apps_file { return catfile($directories{APPS},@_,$f); } +sub __perlapps_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return ($^X, catfile($directories{APPS},@_,$f)); +} + sub __results_file { BAIL_OUT("Must run setup() first") if (! $test_name); @@ -650,7 +688,7 @@ sub __cwd { } } - if (0) { + if ($debug) { print STDERR "DEBUG: __cwd(), directories and files:\n"; print STDERR " \$directories{TEST} = \"$directories{TEST}\"\n"; print STDERR " \$directories{RESULTS} = \"$directories{RESULTS}\"\n"; @@ -682,13 +720,22 @@ sub __fixup_cmd { } # 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$ext"; + 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"; @@ -702,8 +749,22 @@ 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; + + # 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 + my @prog = ($path_builder->(shift @cmdarray)); + my $cmd = __fixup_cmd(shift @prog); + if (@prog) { + if ( ! -f $prog[0] ) { + print STDERR "$prog[0] not found\n"; + $cmd = undef; + } + } + my @args = (@prog, @cmdarray); + my %opts = @_; return () if !$cmd; @@ -730,6 +791,11 @@ sub __build_cmd { my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr"; $cmd .= "$arg_str$stdin$stdout 2> $errlog"; + if ($debug) { + print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n"; + print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n"; + } + return ($cmd, $display_cmd, $errlog => $saved_stderr); } |