OpenSSL::Test: If __cwd() is to create the directory, do it early

[openssl.git] / util / perl / OpenSSL / Test.pm

diff --git a/util/perl/OpenSSL/Test.pm b/util/perl/OpenSSL/Test.pm
index 4dc1bad188644a653a12eb081cd6b62c9bba4e02..00aa4d841e65e2dd002409ca627f752a63c0c754 100644 (file)
--- a/util/perl/OpenSSL/Test.pm
+++ b/util/perl/OpenSSL/Test.pm
@@ -1,4 +1,4 @@
-# Copyright 2016-2020 The OpenSSL Project Authors. All Rights Reserved.
+# Copyright 2016-2021 The OpenSSL Project Authors. All Rights Reserved.
 #
 # Licensed under the Apache License 2.0 (the "License").  You may not use
 # this file except in compliance with the License.  You can obtain a copy
@@ -65,8 +65,7 @@ C<$SRCTOP/test/recipes/99-foo_data/>.
 
 use File::Copy;
 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
-                             catdir catfile splitpath catpath devnull abs2rel
-                             rel2abs/;
+                             catdir catfile splitpath catpath devnull abs2rel/;
 use File::Path 2.00 qw/rmtree mkpath/;
 use File::Basename;
 use Cwd qw/getcwd abs_path/;
@@ -996,6 +995,10 @@ sub __env {
     rmtree($directories{RESULTS}, { safe => 0, keep_root => 1 });
     mkpath($directories{RESULTS});
 
+    # All directories are assumed to exist, except for SRCDATA.  If that one
+    # doesn't exist, just drop it.
+    delete $directories{SRCDATA} unless -d $directories{SRCDATA};
+
     push @direnv, "TOP"       if $ENV{TOP};
     push @direnv, "SRCTOP"    if $ENV{SRCTOP};
     push @direnv, "BLDTOP"    if $ENV{BLDTOP};
@@ -1095,6 +1098,8 @@ sub __fuzz_file {
 sub __data_file {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 
+    return undef unless exists $directories{SRCDATA};
+
     my $f = pop;
     return catfile($directories{SRCDATA},@_,$f);
 }
@@ -1102,6 +1107,8 @@ sub __data_file {
 sub __data_dir {
     BAIL_OUT("Must run setup() first") if (! $test_name);
 
+    return undef unless exists $directories{SRCDATA};
+
     return catdir($directories{SRCDATA},@_);
 }
 
@@ -1117,8 +1124,16 @@ sub __data_dir {
 sub __cwd {
     my $dir = catdir(shift);
     my %opts = @_;
-    my $abscurdir = rel2abs(curdir());
-    my $absdir = rel2abs($dir);
+
+    # If the directory is to be created, we must do that before using
+    # abs_path().
+    $dir = canonpath($dir);
+    if ($opts{create}) {
+       mkpath($dir);
+    }
+
+    my $abscurdir = abs_path(curdir());
+    my $absdir = abs_path($dir);
     my $reverse = abs2rel($abscurdir, $absdir);
 
     # PARANOIA: if we're not moving anywhere, we do nothing more
@@ -1136,11 +1151,6 @@ sub __cwd {
     # In this case, we won't even clean it out, for safety's sake.
     return "." if $reverse eq "";
 
-    $dir = canonpath($dir);
-    if ($opts{create}) {
-       mkpath($dir);
-    }
-
     # We are recalculating the directories we keep track of, but need to save
     # away the result for after having moved into the new directory.
     my %tmp_directories = ();
@@ -1152,7 +1162,13 @@ sub __cwd {
     my @dirtags = sort keys %directories;
     foreach (@dirtags) {
        if (!file_name_is_absolute($directories{$_})) {
-           my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
+           my $oldpath = abs_path($directories{$_});
+           my $newpath = abs2rel($oldpath, $absdir);
+           if ($debug) {
+               print STDERR "DEBUG: [dir $_] old path: $oldpath\n";
+               print STDERR "DEBUG: [dir $_] new base: $absdir\n";
+               print STDERR "DEBUG: [dir $_] resulting new path: $newpath\n";
+           }
            $tmp_directories{$_} = $newpath;
        }
     }
@@ -1162,7 +1178,13 @@ sub __cwd {
     # process can use their values properly as well
     foreach (@direnv) {
        if (!file_name_is_absolute($ENV{$_})) {
-           my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir));
+           my $oldpath = abs_path($ENV{$_});
+           my $newpath = abs2rel($oldpath, $absdir);
+           if ($debug) {
+               print STDERR "DEBUG: [env $_] old path: $oldpath\n";
+               print STDERR "DEBUG: [env $_] new base: $absdir\n";
+               print STDERR "DEBUG: [env $_] resulting new path: $newpath\n";
+           }
            $tmp_ENV{$_} = $newpath;
        }
     }
@@ -1182,16 +1204,19 @@ sub __cwd {
 
     if ($debug) {
        print STDERR "DEBUG: __cwd(), directories and files:\n";
-       print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
-       print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
-       print STDERR "  \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n";
-       print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\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 "  Moving from $abscurdir\n";
+       print STDERR "  Moving to $absdir\n";
+       print STDERR "\n";
+       print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
+       print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
+       print STDERR "  \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n"
+            if exists $directories{SRCDATA};
+       print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\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";
     }
 
@@ -1232,7 +1257,7 @@ sub __wrap_cmd {
             # In the Windows case, we run perl explicitly.  We might not
             # need it, but that depends on if the user has associated the
             # '.pl' extension with a perl interpreter, so better be safe.
-            @prefix = ( $^X, $std_wrapper );
+            @prefix = ( __fixup_prg($^X), $std_wrapper );
         } else {
             # Otherwise, we assume Unix semantics, and trust that the #!
             # line activates perl for us.