Merge changes from PathTools: 'Update to support VMS in Unix compatible mode and...

diff --git a/ext/Cwd/Changes b/ext/Cwd/Changes
index dec9c57..1c34381 100644 (file)
--- 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 7d5f67f..8e86c4d 100644 (file)
--- 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);

diff --git a/lib/Cwd.pm b/lib/Cwd.pm
index 3bf704f..83239bf 100644 (file)
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -171,7 +171,7 @@ use strict;
 use Exporter;
 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
 
-$VERSION = '3.29';
+$VERSION = '3.29_01';
 my $xs_version = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -202,6 +202,45 @@ if ($^O eq 'os2') {
     return 1;
 }
 
+# Need to look up the feature settings on VMS.  The preferred way is to use the
+# VMS::Feature module, but that may not be available to dual life modules.
+
+my $use_vms_feature;
+BEGIN {
+    if ($^O eq 'VMS') {
+        if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+            $use_vms_feature = 1;
+        }
+    }
+}
+
+# Need to look up the UNIX report mode.  This may become a dynamic mode
+# in the future.
+sub _vms_unix_rpt {
+    my $unix_rpt;
+    if ($use_vms_feature) {
+        $unix_rpt = VMS::Feature::current("filename_unix_report");
+    } else {
+        my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+        $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
+    }
+    return $unix_rpt;
+}
+
+# Need to look up the EFS character set mode.  This may become a dynamic
+# mode in the future.
+sub _vms_efs {
+    my $efs;
+    if ($use_vms_feature) {
+        $efs = VMS::Feature::current("efs_charset");
+    } else {
+        my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
+        $efs = $env_efs =~ /^[ET1]/i; 
+    }
+    return $efs;
+}
+
+
 # If loading the XS stuff doesn't work, we can fall back to pure perl
 eval {
   if ( $] >= 5.006 ) {
@@ -648,23 +687,36 @@ sub _vms_abs_path {
     return $ENV{'DEFAULT'} unless @_;
     my $path = shift;
 
-    if (-l $path) {
-        my $link_target = readlink($path);
-        die "Can't resolve link $path: $!" unless defined $link_target;
-           
-        return _vms_abs_path($link_target);
-    }
+    my $efs = _vms_efs;
+    my $unix_rpt = _vms_unix_rpt;
+
+    if (defined &VMS::Filespec::vmsrealpath) {
+        my $path_unix = 0;
+        my $path_vms = 0;
+
+        $path_unix = 1 if ($path =~ m#(?<=\^)/#);
+        $path_unix = 1 if ($path =~ /^\.\.?$/);
+        $path_vms = 1 if ($path =~ m#[\[<\]]#);
+        $path_vms = 1 if ($path =~ /^--?$/);
+
+        my $unix_mode = $path_unix;
+        if ($efs) {
+            # In case of a tie, the Unix report mode decides.
+            if ($path_vms == $path_unix) {
+                $unix_mode = $unix_rpt;
+            } else {
+                $unix_mode = 0 if $path_vms;
+            }
+        }
 
-    if (defined &VMS::Filespec::vms_realpath) {
-        my $path = $_[0];
-        if ($path =~ m#(?<=\^)/# ) {
+        if ($unix_mode) {
             # Unix format
-            return VMS::Filespec::vms_realpath($path);
+            return VMS::Filespec::unixrealpath($path);
         }
 
        # VMS format
 
-       my $new_path = VMS::Filespec::vms_realname($path); 
+       my $new_path = VMS::Filespec::vmsrealpath($path);
 
        # Perl expects directories to be in directory format
        $new_path = VMS::Filespec::pathify($new_path) if -d $path;
@@ -674,6 +726,13 @@ sub _vms_abs_path {
     # Fallback to older algorithm if correct ones are not
     # available.
 
+    if (-l $path) {
+        my $link_target = readlink($path);
+        die "Can't resolve link $path: $!" unless defined $link_target;
+
+        return _vms_abs_path($link_target);
+    }
+
     # may need to turn foo.dir into [.foo]
     my $pathified = VMS::Filespec::pathify($path);
     $path = $pathified if defined $pathified;

diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm
index d5ee060..51c27c2 100644 (file)
--- a/lib/File/Spec.pm
+++ b/lib/File/Spec.pm
@@ -3,7 +3,7 @@ package File::Spec;
 use strict;
 use vars qw(@ISA $VERSION);
 
-$VERSION = '3.29';
+$VERSION = '3.29_01';
 $VERSION = eval $VERSION;
 
 my %module = (MacOS   => 'Mac',