Make OpenSSL::Test a bit more flexible

So far, apps and test programs, were a bit rigidely accessible as
executables or perl scripts.  But what about scripts in some other
language?  Or what about running entirely external programs?  The
answer is certainly not to add new functions to access scripts for
each language or wrapping all the external program calls in our magic!

Instead, this adds a new functions, cmd(), which is useful to access
executables and scripts in a more generalised manner.  app(), test(),
fuzz(), perlapp() and perltest() are rewritten in terms of cmd(), and
serve as examples how to do something similar for other scripting
languages, or constrain the programs to certain directories.

Reviewed-by: Matt Caswell <matt@openssl.org>
(Merged from https://github.com/openssl/openssl/pull/1686)

diff --git a/test/testlib/OpenSSL/Test.pm b/test/testlib/OpenSSL/Test.pm
index 0c3b9104e9190b9f17ee8b8f1a1945929608602d..24219e187ced1d150e208086bc401b4fca22d6c1 100644 (file)
--- a/test/testlib/OpenSSL/Test.pm
+++ b/test/testlib/OpenSSL/Test.pm
@@ -16,8 +16,8 @@ use Exporter;
 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
 $VERSION = "0.8";
 @ISA = qw(Exporter);
 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
 $VERSION = "0.8";
 @ISA = qw(Exporter);

-@EXPORT = (@Test::More::EXPORT, qw(setup indir app fuzz  perlapp test perltest
-                                   run));
+@EXPORT = (@Test::More::EXPORT, qw(setup run indir cmd app fuzz test
+                                   perlapp perltest));

 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
                                          srctop_dir srctop_file
                                          pipe with cmdstr quotify));
 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
                                          srctop_dir srctop_file
                                          pipe with cmdstr quotify));


@@ -218,25 +218,16 @@ sub indir {
 
 =over 4
 
 
 =over 4
 

-=item B<app ARRAYREF, OPTS>
-
-=item B<test ARRAYREF, OPTS>
+=item B<cmd ARRAYREF, OPTS>

 
 

-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<app> 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>
-or C<$BLDTOP/apps>).
-
-C<test> 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>
-or C<$BLDTOP/test>).
+This functions build up a platform dependent command based on the
+input.  It takes a reference to a list that is the executable or
+script and its arguments, and some additional options (described
+further on).

 
 

-Both return a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
+It returns a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.

 
 

-The options that both C<app> and C<test> can take are in the form of hash
-values:
+The options that C<cmd> can take are in the form of hash values:

 
 =over 4
 
 
 =over 4
 


@@ -252,21 +243,42 @@ string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
 
 =back
 
 
 =back
 

+=item B<app ARRAYREF, OPTS>
+
+=item B<test ARRAYREF, OPTS>
+
+Both of these are specific applications of C<cmd>, with just a couple
+of small difference:
+
+C<app> 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>
+or C<$BLDTOP/apps>).
+
+C<test> 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>
+or C<$BLDTOP/test>).
+
+Also, for both C<app> and C<test>, the command may be prefixed with
+the content of the environment variable C<$EXE_SHELL>, which is useful
+in case OpenSSL has been cross compiled.
+

 =item B<perlapp ARRAYREF, OPTS>
 
 =item B<perltest ARRAYREF, OPTS>
 
 =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.  Also, they support one
-more option:
+These are also specific applications of C<cmd>, where the interpreter
+is predefined to be C<perl>, and they expect the script to be
+interpreted to reside in the same location as C<app> and C<test>.
+
+C<perlapp> and C<perltest> will also take the following option:

 
 =over 4
 
 =item B<interpreter_args =E<gt> ARRAYref>
 
 
 =over 4
 
 =item B<interpreter_args =E<gt> 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!
+The array reference is a set of arguments for the interpreter rather
+than the script.  Take care so that none of them can be seen as a
+script!  Flags and their eventual arguments only!

 
 =back
 
 
 =back
 


@@ -277,54 +289,114 @@ An example:
 
 =back
 
 
 =back
 

+=begin comment
+
+One might wonder over the complexity of C<apps>, C<fuzz>, C<test>, ...
+with all the lazy evaluations and all that.  The reason for this is that
+we want to make sure the directory in which those programs are found are
+correct at the time these commands are used.  Consider the following code
+snippet:
+
+  my $cmd = app(["openssl", ...]);
+
+  indir "foo", sub {
+      ok(run($cmd), "Testing foo")
+  };
+
+If there wasn't this lazy evaluation, the directory where C<openssl> is
+found would be incorrect at the time C<run> is called, because it was
+calculated before we moved into the directory "foo".
+
+=end comment
+

 =cut
 
 =cut
 

+sub cmd {
+    my $cmd = shift;
+    my %opts = @_;
+    return sub {
+        my $num = shift;
+        # Make a copy to not destroy the caller's array
+        my @cmdargs = ( @$cmd );
+        my @prog = __wrap_cmd(shift @cmdargs, $opts{exe_shell} // ());
+
+        return __decorate_cmd($num, [ @prog, quotify(@cmdargs) ],
+                              %opts);
+    }
+}
+

 sub app {
     my $cmd = shift;
     my %opts = @_;
 sub app {
     my $cmd = shift;
     my %opts = @_;

-    return sub { my $num = shift;
-                return __build_cmd($num, \&__apps_file, $cmd, %opts); }
+    return sub {
+        my @cmdargs = ( @{$cmd} );
+        my @prog = __fixup_prg(__apps_file(shift @cmdargs, __exeext()));
+        return cmd([ @prog, @cmdargs ],
+                   exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
+    }

 }
 
 sub fuzz {
     my $cmd = shift;
     my %opts = @_;
 }
 
 sub fuzz {
     my $cmd = shift;
     my %opts = @_;

-    return sub { my $num = shift;
-                return __build_cmd($num, \&__fuzz_file, $cmd, %opts); }
+    return sub {
+        my @cmdargs = ( @{$cmd} );
+        my @prog = __fixup_prg(__fuzz_file(shift @cmdargs, __exeext()));
+        return cmd([ @prog, @cmdargs ],
+                   exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
+    }

 }
 
 sub test {
     my $cmd = shift;
     my %opts = @_;
 }
 
 sub test {
     my $cmd = shift;
     my %opts = @_;

-    return sub { my $num = shift;
-                return __build_cmd($num, \&__test_file, $cmd, %opts); }
+    return sub {
+        my @cmdargs = ( @{$cmd} );
+        my @prog = __fixup_prg(__test_file(shift @cmdargs, __exeext()));
+        return cmd([ @prog, @cmdargs ],
+                   exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
+    }

 }
 
 sub perlapp {
     my $cmd = shift;
     my %opts = @_;
 }
 
 sub perlapp {
     my $cmd = shift;
     my %opts = @_;

-    return sub { my $num = shift;
-                return __build_cmd($num, \&__perlapps_file, $cmd, %opts); }
+    return sub {
+        my @interpreter_args = defined $opts{interpreter_args} ?
+            @{$opts{interpreter_args}} : ();
+        my @interpreter = __fixup_prg($^X);
+        my @cmdargs = ( @{$cmd} );
+        my @prog = __apps_file(shift @cmdargs, undef);
+        return cmd([ @interpreter, @interpreter_args,
+                     @prog, @cmdargs ], %opts) -> (shift);
+    }

 }
 
 sub perltest {
     my $cmd = shift;
     my %opts = @_;
 }
 
 sub perltest {
     my $cmd = shift;
     my %opts = @_;

-    return sub { my $num = shift;
-                return __build_cmd($num, \&__perltest_file, $cmd, %opts); }
+    return sub {
+        my @interpreter_args = defined $opts{interpreter_args} ?
+            @{$opts{interpreter_args}} : ();
+        my @interpreter = __fixup_prg($^X);
+        my @cmdargs = ( @{$cmd} );
+        my @prog = __test_file(shift @cmdargs, undef);
+        return cmd([ @interpreter, @interpreter_args,
+                     @prog, @cmdargs ], %opts) -> (shift);
+    }

 }
 
 =over 4
 
 =item B<run CODEREF, OPTS>
 
 }
 
 =over 4
 
 =item B<run CODEREF, OPTS>
 

-This CODEREF is expected to be the value return by C<app> or C<test>,
-anything else will most likely cause an error unless you know what you're
-doing.
+CODEREF is expected to be the value return by C<cmd> or any of its
+derivatives, anything else will most likely cause an error unless you
+know what you're doing.

 
 C<run> executes the command returned by CODEREF and return either the
 
 C<run> executes the command returned by CODEREF and return either the

-resulting output (if the option C<capture> is set true) or a boolean indicating
-if the command succeeded or not.
+resulting output (if the option C<capture> is set true) or a boolean
+indicating if the command succeeded or not.

 
 The options that C<run> can take are in the form of hash values:
 
 
 The options that C<run> can take are in the form of hash values:
 


@@ -764,48 +836,33 @@ sub __exeext {
 sub __test_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 
 sub __test_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 

+    my $e = pop || "";

     my $f = pop;
     my $f = pop;

-    $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;
-    $f = catfile($directories{BLDTEST},@_,$f);
+    $f = catfile($directories{BLDTEST},@_,$f . $e);

     $f = catfile($directories{SRCTEST},@_,$f) unless -f $f;
     $f = catfile($directories{SRCTEST},@_,$f) unless -f $f;

-    return ($^X, $f);
+    return $f;

 }
 
 sub __apps_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 
 }
 
 sub __apps_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 

+    my $e = pop || "";

     my $f = pop;
     my $f = pop;

-    $f = catfile($directories{BLDAPPS},@_,$f . __exeext());
-    $f = catfile($directories{SRCAPPS},@_,$f) unless -x $f;
+    $f = catfile($directories{BLDAPPS},@_,$f . $e);
+    $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f;

     return $f;
 }
 
 sub __fuzz_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 
     return $f;
 }
 
 sub __fuzz_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 

+    my $e = pop || "";

     my $f = pop;
     my $f = pop;

-    $f = catfile($directories{BLDFUZZ},@_,$f . __exeext());
-    $f = catfile($directories{SRCFUZZ},@_,$f) unless -x $f;
+    $f = catfile($directories{BLDFUZZ},@_,$f . $e);
+    $f = catfile($directories{SRCFUZZ},@_,$f) unless -f $f;

     return $f;
 }
 
     return $f;
 }
 

-sub __perlapps_file {
-    BAIL_OUT("Must run setup() first") if (! $test_name);
-
-    my $f = pop;
-    $f = catfile($directories{BLDAPPS},@_,$f);
-    $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f;
-    return ($^X, $f);
-}
-

 sub __results_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 
 sub __results_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 


@@ -900,18 +957,46 @@ sub __cwd {
     return $reverse;
 }
 
     return $reverse;
 }
 

-sub __fixup_cmd {
-    my $prog = shift;
+# __wrap_cmd CMD
+# __wrap_cmd CMD, EXE_SHELL
+#
+# __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure
+# the command gets executed with an appropriate environment.  If EXE_SHELL
+# is given, it is used as the beginning command.
+#
+# __wrap_cmd returns a list that should be used to build up a larger list
+# of command tokens, or be joined together like this:
+#
+#    join(" ", __wrap_cmd($cmd))
+sub __wrap_cmd {
+    my $cmd = shift;

     my $exe_shell = shift;
 
     my $exe_shell = shift;
 

-    my $prefix = __bldtop_file("util", "shlib_wrap.sh")." ";
+    my @prefix = ( __bldtop_file("util", "shlib_wrap.sh") );

 
 

-    if (defined($exe_shell)) {
-       $prefix = "$exe_shell ";
-    } elsif ($^O eq "VMS" ) {  # VMS
+    if(defined($exe_shell)) {
+       @prefix = ( $exe_shell );
+    } elsif ($^O eq "VMS" || $^O eq "MSWin32") {
+       # VMS and Windows don't use any wrapper script for the moment
+       @prefix = ();
+    }
+
+    return (@prefix, $cmd);
+}
+
+# __fixup_prg PROG
+#
+# __fixup_prg does whatever fixup is needed to execute an executable binary
+# given by PROG (string).
+#
+# __fixup_prg returns a string with the possibly prefixed program path spec.
+sub __fixup_prg {
+    my $prog = shift;
+
+    my $prefix = "";
+
+    if ($^O eq "VMS" ) {

        $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
        $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");

-    } elsif ($^O eq "MSWin32") { # Windows
-       $prefix = "";

     }
 
     # We test both with and without extension.  The reason
     }
 
     # We test both with and without extension.  The reason


@@ -937,45 +1022,15 @@ sub __fixup_cmd {
     return undef;
 }
 
     return undef;
 }
 

-sub __build_cmd {
+sub __decorate_cmd {

     BAIL_OUT("Must run setup() first") if (! $test_name);
 
     my $num = shift;
     BAIL_OUT("Must run setup() first") if (! $test_name);
 
     my $num = shift;

-    my $path_builder = shift;
-    # Make a copy to not destroy the caller's array
-    my @cmdarray = ( @{$_[0]} ); shift;
+    my $cmd = shift;

     my %opts = @_;
 
     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 = "";
+    my $cmdstr = join(" ", @$cmd);

     my $null = devnull();
     my $null = devnull();

-
-
-    $arg_str = " ".join(" ", quotify @args) if @args;
-

     my $fileornull = sub { $_[0] ? $_[0] : $null; };
     my $stdin = "";
     my $stdout = "";
     my $fileornull = sub { $_[0] ? $_[0] : $null; };
     my $stdin = "";
     my $stdout = "";


@@ -985,19 +1040,19 @@ sub __build_cmd {
     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
 
     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
 

-    my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
+    my $display_cmd = "$cmdstr$stdin$stdout$stderr";

 
     $stderr=" 2> ".$null
         unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 
 
     $stderr=" 2> ".$null
         unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 

-    $cmd .= "$arg_str$stdin$stdout$stderr";
+    $cmdstr .= "$stdin$stdout$stderr";

 
     if ($debug) {
 
     if ($debug) {

-       print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n";
-       print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n";
+       print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n";
+       print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n";

     }
 
     }
 

-    return ($cmd, $display_cmd);
+    return ($cmdstr, $display_cmd);

 }
 
 =head1 SEE ALSO
 }
 
 =head1 SEE ALSO