Preferred bug tracker

Please visit the preferred bug tracker to report your issue.

This queue is for tickets about the PathTools CPAN distribution.

Report information
The Basics
Id:
42154
Status:
resolved
Priority:
Low/Low
Queue:

People
Owner:
Nobody in particular
Requestors:
wb8tyw [...] gmail.com
Cc:
AdminCc:

BugTracker
Severity:
Normal
Broken in:
3.29
Fixed in:
(no value)



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);
Thanks, applied to the PathTools repository as r12319 with some fuzz: in t/cwd.t, always use $TestDir (both in PathTools and core) and not "t/$TestDir". Sorry for the delay. Cheers, Steffen


This service runs on Request Tracker, is sponsored by The Perl Foundation, and maintained by Best Practical Solutions.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.