| Subject: | Update Cwd for supporting VMS in UNIX or Extended Character set mode |
Update to support VMS in Unix compatible mode and/or file names using
extended character sets.
Originally submited at ticket 42152
| Subject: | cwd.patch |
--- /rsync_root/perl/lib/Cwd.pm Wed Oct 29 15:52:58 2008
+++ lib/Cwd.pm Sun Jan 4 11:10:48 2009
@@ -202,6 +202,45 @@
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 @@
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;
@@ -673,6 +725,13 @@
# 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);
--- /rsync_root/perl/ext/Cwd/t/cwd.t Mon Oct 27 16:05:37 2008
+++ ext/Cwd/t/cwd.t Sun Nov 23 22:17:14 2008
@@ -16,7 +16,30 @@
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 @@
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 @@
# 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 @@
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,20 @@
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(
+ $ENV{PERL_CORE} ? $Test_Dir : File::Spec->catdir('t', $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);