Merge changes from PathTools: 'Update to support VMS in Unix compatible mode and/or file names using extended character sets' (PathTools RT #42154)

2 files changed, 54 insertions, 9 deletions

diff --git a/ext/Cwd/Changes b/ext/Cwd/Changes
index dec9c5701e..1c3438127f 100644
--- a/ext/Cwd/Changes
+++ b/ext/Cwd/Changes
@@ -1,5 +1,9 @@
 Revision history for Perl distribution PathTools.
 
+- Apply patch from John Malmberg: (RT #42154)
+  "Update to support VMS in Unix compatible mode and/or file names using
+   extended character sets."
+
 3.29 - Wed Oct 29 20:48:11 2008
 
 - Promote to stable release.
diff --git a/ext/Cwd/t/cwd.t b/ext/Cwd/t/cwd.t
index 7d5f67f19e..8e86c4dece 100644
--- a/ext/Cwd/t/cwd.t
+++ b/ext/Cwd/t/cwd.t
@@ -16,7 +16,30 @@ use File::Path;
 
 use lib File::Spec->catdir('t', 'lib');
 use Test::More;
-require VMS::Filespec if $^O eq 'VMS';
+
+my $IsVMS = $^O eq 'VMS';
+my $IsMacOS = $^O eq 'MacOS';
+
+my $vms_unix_rpt = 0;
+my $vms_efs = 0;
+my $vms_mode = 0;
+
+if ($IsVMS) {
+    require VMS::Filespec;
+    use Carp;
+    use Carp::Heavy;
+    $vms_mode = 1;
+    if (eval 'require VMS::Feature') {
+        $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
+        $vms_efs = VMS::Feature::current("efs_charset");
+    } else {
+        my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+        my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+        $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; 
+        $vms_efs = $efs_charset =~ /^[ET1]/i; 
+    }
+    $vms_mode = 0 if ($vms_unix_rpt);
+}
 
 my $tests = 30;
 # _perl_abs_path() currently only works when the directory separator
@@ -30,8 +53,6 @@ SKIP: {
   like $INC{'Cwd.pm'}, qr{blib}i, "Cwd should be loaded from blib/ during testing";
 }
 
-my $IsVMS = $^O eq 'VMS';
-my $IsMacOS = $^O eq 'MacOS';
 
 # check imports
 can_ok('main', qw(cwd getcwd fastcwd fastgetcwd));
@@ -80,8 +101,17 @@ SKIP: {
 
     # Win32's cd returns native C:\ style
     $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare");
-    # DCL SHOW DEFAULT has leading spaces
-    $start =~ s/^\s+// if $IsVMS;
+    if ($IsVMS) {
+        # DCL SHOW DEFAULT has leading spaces
+        $start =~ s/^\s+//;
+
+        # When in UNIX report mode, need to convert to compare it.
+        if ($vms_unix_rpt) {
+            $start = VMS::Filespec::unixpath($start);
+            # Remove trailing slash.
+            $start =~ s#/$##;
+        }
+    }
     SKIP: {
         skip("'$pwd_cmd' failed, nothing to test against", 4) if $?;
         skip("/afs seen, paths unlikely to match", 4) if $start =~ m|/afs/|;
@@ -144,9 +174,9 @@ for (1..@test_dirs) {
 rmtree($test_dirs[0], 0, 0);
 
 {
-  my $check = ($IsVMS   ? qr|\b((?i)t)\]$| :
-	       $IsMacOS ? qr|\bt:$| :
-			  qr|\bt$| );
+  my $check = ($vms_mode ? qr|\b((?i)t)\]$| :
+	       $IsMacOS  ? qr|\bt:$| :
+			   qr|\bt$| );
   
   like($ENV{PWD}, $check);
 }
@@ -169,7 +199,18 @@ SKIP: {
 
     my $abs_path      =  Cwd::abs_path($file);
     my $fast_abs_path =  Cwd::fast_abs_path($file);
-    my $want          =  quotemeta( File::Spec->rel2abs($Test_Dir) );
+    my $want          =  quotemeta(
+                           File::Spec->rel2abs( $Test_Dir )
+                         );
+    if ($^O eq 'VMS') {
+       # Not easy to predict the physical volume name
+       $want = $ENV{PERL_CORE} ? $Test_Dir : File::Spec->catdir('t', $Test_Dir);
+
+       # So just use the relative volume name
+       $want =~ s/^\[//;
+
+       $want = quotemeta($want);
+    }
 
     like($abs_path,      qr|$want$|i);
     like($fast_abs_path, qr|$want$|i);