Have OpenSSL::Test handle perl scripts like any program

Since we're building some of our perl scripts and the result might not
end up in apps/ (*), we may need to treat them like the compile
programs we use for testing.

This introduces perlapp() and perltest(), which behave like app() and
test(), but will add the perl executable in the command line.

-----

(*) For example, with a mk1mf build, the result will end up in $(BIN_D)

Reviewed-by: Matt Caswell <matt@openssl.org>

diff --git a/test/testlib/OpenSSL/Test.pm b/test/testlib/OpenSSL/Test.pm
index e4218c55f5d4322580d4a1ce4bbf1da7edc5e7a6..491984cee4c59cd2d9fd59cd3bb2d7bb88a63934 100644 (file)
--- 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);
 }