From: John Malmberg Date: Fri, 9 Jan 2009 20:09:36 +0000 (+0100) Subject: Merge changes from PathTools: 'Update to support VMS in Unix compatible mode and... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=53e80d0bfa727482493993e65eb4fe904f7d9d97;p=p5sagit%2Fp5-mst-13.2.git Merge changes from PathTools: 'Update to support VMS in Unix compatible mode and/or file names using extended character sets' (PathTools RT #42154) --- diff --git a/ext/Cwd/Changes b/ext/Cwd/Changes index dec9c57..1c34381 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 7d5f67f..8e86c4d 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); diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 3bf704f..83239bf 100644 --- 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 --- 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',