Bug #42152 for Cwd: Update Cwd for supporting VMS in UNIX or Extended Character set mode

Actual version 3.29 Update to support VMS in Unix compatible mode and/or file names using extended character sets.

--- /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);