Here is the latest attempt. Still not fully tested.
The VMS format of logical foo:bar, such as sys$scratch:foo seems to be
causing all sorts of problems.
catpath("sys$scratch:",,"foo.bar") can not work. The catpath method can
not deal with an empty directory, so will treat 'foo.bar' as a
directory. So the splitpath("sys$scratch:foo.bar") must translate the
sys$scratch: to its device and directory component.
Some new regression tests that may be needed for EFS/VMS mode.
[wrapped line below]
perl -"MFile::Spec::Functions" -e -
"print
File::Spec->abs2rel('../lib/Module/Pluggable','../lib/Module/Pluggable/');"
returns "."
perl -"MFile::Spec::Functions" -e -
"print catdir('sys$scratch:','foo', 'bar');
returns "device:[dir.foo.bar]'
perl -"MFile::Spec::Functions" -e "print catdir('[]','foo', 'bar');
returns "[.foo.bar]"
File::Spec->splitpath('sys$scratch:compilet.exe') returns ('dev:',
'[dir]', 'compilet.exe').
It looks like there are still issues with:
ext/Test-Harness,
lib/Archive/Extract,
lib/Archive/Tar
CPANPLUS,
Various lib/ExtUtils,
lib/Module/Build,
lib/Pod/Simple
And i need to make a test run to make sure that I did not change the
working EFS/Unix and non-EFS modes.
Regards,
-John
--- /rsync_root/perl/lib/File/Spec/VMS.pm Sun May 10 04:02:09 2009
+++ lib/File/Spec/VMS.pm Tue Jun 9 00:03:27 2009
@@ -105,7 +105,6 @@
sub canonpath {
my($self,$path) = @_;
-
return undef unless defined $path;
my $efs = $self->_efs;
@@ -195,6 +194,32 @@
if ($efs) {
# Extended character set in use, go into DWIM mode.
+ if ($path =~ /:$/) {
+ # We have a problem. If we do a syntax only conversion
+ # we can break existing code that does not understand how
+ # logical names and directories can be combined.
+ my $test_path = $path;
+ my $i = 0;
+ while ($i < 10) {
+ # We need to do a logical name check, but we do not have
+ # logical name services in perl. So we need to $ENV until
+ # that can be remedied.
+ $test_path =~ s/:$//;
+ my $test_trnlnm = $ENV{$test_path};
+ last unless defined $test_trnlnm;
+ if ($test_trnlnm =~ /\.[\]>]$/) {
+ # A rooted logical name, same as device so use as is.
+ last;
+ }
+ if ($test_trnlnm =~ /[\]>]$/) {
+ # Found a directory, use this instead of the path
+ $path = $test_trnlnm;
+ last;
+ }
+ $test_path = $test_trnlnm;
+ $i++;
+ }
+ }
# Now we need to identify what the directory is in
# of the specification in order to merge them.
@@ -202,14 +227,14 @@
$path_unix = 1 if ($path =~ m#/#);
$path_unix = 1 if ($path =~ /^\.\.?$/);
my $path_vms = 0;
- $path_vms = 1 if ($path =~ m#[\[<\]]#);
- $path_vms = 1 if ($path =~ /^--?$/);
+ $path_vms = 1 if ($path =~ m#(?:[\[<\]]|:$)#);
+ $path_vms = 1 if ($path =~ /^--*$/);
my $dir_unix = 0;
$dir_unix = 1 if ($dir =~ m#/#);
$dir_unix = 1 if ($dir =~ /^\.\.?$/);
my $dir_vms = 0;
$dir_vms = 1 if ($dir =~ m#[\[<\]]#);
- $dir_vms = 1 if ($dir =~ /^--?$/);
+ $dir_vms = 1 if ($dir =~ /^--*$/);
my $unix_mode = 0;
if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) {
@@ -237,20 +262,31 @@
#with <> posible instead of [.
# Normalize the brackets
# Fixme - need to not switch when preceded by ^.
- $path =~ s/</\[/g;
- $path =~ s/>/\]/g;
+ if ($path !~ /:$/) {
+ $path =~ s/</\[/g;
+ $path =~ s/>/\]/g;
+ }
$dir =~ s/</\[/g;
$dir =~ s/>/\]/g;
# Fix up mixed syntax imput as good as possible - GIGO
- $path = vmsify($path) if $path_unix;
- $dir = vmsify($dir) if $dir_unix;
+ if ($path_unix) {
+ $path = vmspath($path);
+ $path_vms = 1;
+ $path_unix = 0;
+ }
+ if ($dir_unix) {
+ $dir = vmspath($dir);
+ $dir_vms = 1;
+ $dir_unix = 0;
+ }
#Possible path values: foo: [.foo] [foo] foo, and $(foo)
#or starting with '-', or foo.dir
#If path is foo, it needs to be converted to [.foo]
# Fix up a bare path name.
+ my $is_abs_path = 0;
unless ($path_vms) {
$path =~ s/\.dir\Z(?!\n)//i;
if (($path ne '') && ($path !~ /^-/)) {
@@ -258,6 +294,7 @@
$path = '[.' . $path;
} else {
# Just start a directory.
+ $is_abs_path = 1 if $path eq '';
$path = '[' . $path;
}
} else {
@@ -276,16 +313,25 @@
$dir =~ s/\]$//;
}
- #strip off the leading dot if present.
- $dir =~ s/^\.//;
-
# Now put the specifications together.
if ($dir ne '') {
- # Add a separator unless this is an absolute path
- $path .= '.' if ($path ne '[');
- $rslt = $path . $dir . ']';
+ if ($path =~ /:$/) {
+ $rslt = $path . '[' . $dir . ']';
+ } else {
+
+ #strip off the leading dot if present.
+ $dir =~ s/^\.//;
+
+ # Add a separator unless this is an absolute path
+ $path .= '.' unless $is_abs_path;
+ $rslt = $path . $dir . ']';
+ }
} else {
- $rslt = $path . ']';
+ if ($path =~ /:$/) {
+ $rslt = $path;
+ } else {
+ $rslt = $path . ']';
+ }
}
}
@@ -427,7 +473,7 @@
$spath_unix = 1 if ($spath =~ m#/#);
$spath_unix = 1 if ($spath =~ /^\.\.?$/);
my $spath_vms = 0;
- $spath_vms = 1 if ($spath =~ m#[\[<\]]#);
+ $spath_vms = 1 if ($spath =~ m#(?:[\[<\]]|:$)#);
$spath_vms = 1 if ($spath =~ /^--?$/);
# Assume VMS mode
@@ -439,13 +485,19 @@
$unix_mode = 1
if (($spath_unix || $file_unix) && $unix_rpt);
}
-
if (!$unix_mode) {
if ($spath_vms) {
- $spath = '[' . $spath . ']' if $spath =~ /^-/;
- $rslt = vmspath($spath);
+ if ($spath =~ /^-/) {
+ $rslt = '[' . $spath . ']';
+ } else {
+ $rslt = $spath;
+ }
} else {
- $rslt = '[.' . $spath . ']';
+ if ($spath_unix) {
+ $rslt = vmspath($spath);
+ } else {
+ $rslt = '[.' . $spath . ']';
+ }
}
$file = vmsify($file) if ($file_unix);
} else {
@@ -459,7 +511,7 @@
}
$rslt .= $file;
- $rslt =~ s/\]\[//;
+ $rslt =~ s/\]\[// if !$unix_mode;
} else {
# Traditional VMS Perl mode expects that this is done.
@@ -638,8 +690,8 @@
my $vmsify_path = vmsify($path);
if ($efs) {
my $path_vms = 0;
- $path_vms = 1 if ($path =~ m#[\[<\]]#);
- $path_vms = 1 if ($path =~ /^--?$/);
+ $path_vms = 1 if ($path =~ m#(?:[\[<\]:])#);
+ $path_vms = 1 if ($path =~ /^--*$/);
if (!$path_vms) {
return $self->SUPER::splitpath($path, $nofile);
}
@@ -658,7 +710,35 @@
}
else {
$vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
- return ($1 || '',$2 || '',$3);
+ $dev = $1 || ''; $dir = $2 || ''; $file = $3;
+
+ # Need to handle things like 'sys$scratch:foo'
+ # We have to expand the logical name because catpath can not
+ # deal with an empty directory.
+ if (($dir eq '') && ($file ne '')) {
+
+ my $test_dev = $dev;
+ my $i = 0;
+ while ($i < 10) {
+ $test_dev =~ s/:$//;
+ my $test_trnlnm = $ENV{$test_dev};
+ last unless defined $test_trnlnm;
+ if ($test_trnlnm =~ /\.[\]>]$/) {
+ # A rooted logical name, same as device so use as is.
+ last;
+ }
+ if ($test_trnlnm =~ /[\]>]$/) {
+ # Found a directory, use this instead of the dev, dir
+ $test_trnlnm =~ /(.+:)?([\[<].*[\]>])?/s;
+ $dev = $1; $dir = $2;
+ last;
+ }
+ $test_dev = $test_trnlnm;
+ $i++;
+ }
+ }
+
+ return ($dev, $dir, $file);
}
}
@@ -715,7 +795,6 @@
sub catpath {
my($self,$dev,$dir,$file) = @_;
-
my $efs = $self->_efs;
my $unix_rpt = $self->_unix_rpt;
@@ -734,7 +813,6 @@
$unix_mode = $dir_unix;
}
}
-
# We look for a volume in $dev, then in $dir, but not both
# but only if using VMS syntax.
if (!$unix_mode) {
@@ -789,6 +867,7 @@
my $path_vms = 0;
$path_vms = 1 if ($path =~ m#[\[<\]]#);
$path_vms = 1 if ($path =~ /^--?$/);
+ $path_vms = 1 if ($path =~ /:$/);
my $unix_mode = 0;
if ($path_vms == $path_unix) {
@@ -803,8 +882,8 @@
if (defined $base) {
$base_unix = 1 if ($base =~ m#/#);
$base_unix = 1 if ($base =~ /^\.\.?$/);
- $base_vms = 1 if ($base =~ m#[\[<\]]#);
- $base_vms = 1 if ($base =~ /^--?$/);
+ $base_vms = 1 if ($base =~ m#(?:[\[<\]]|:$)#);
+ $base_vms = 1 if ($base =~ /^--*$/);
if ($path_vms == $path_unix) {
if ($base_vms == $base_unix) {
@@ -821,7 +900,7 @@
if ($unix_mode) {
# We are UNIX mode.
$base = unixpath($base) if $base_vms;
- $base = unixify($path) if $path_vms;
+ $path = unixify($path) if $path_vms;
# Here VMS is different, and in order to do this right
# we have to take the realpath for both the path and the base
@@ -839,11 +918,20 @@
return $path;
}
- return File::Spec::Unix::abs2rel( $self, $path, $base );
+ # Handle it as Unix.
+ my $rslt = File::Spec::Unix::abs2rel($self, $path, $base);
+
+ # If we are not in Unix mode, something that the Unix code
+ # if flipping this to VMS format. We need to put this back.
+ unless ($unix_rpt) {
+ $rslt = unixify($rslt) if $rslt =~ m#(?:[\[\<\]]|:$)#;
+ $rslt =~ s#/$## if ($rslt ne '/');
+ }
+ return $rslt;
} else {
$base = vmspath($base) if $base_unix;
- $path = vmsify($path) if $path_unix;
+ $path = vmspath($path) if $path_unix;
}
}
@@ -923,8 +1011,8 @@
$path_unix = 1 if ($path =~ m#/#);
$path_unix = 1 if ($path =~ /^\.\.?$/);
my $path_vms = 0;
- $path_vms = 1 if ($path =~ m#[\[<\]]#);
- $path_vms = 1 if ($path =~ /^--?$/);
+ $path_vms = 1 if ($path =~ m#(?:[\[<\]]|:$)#);
+ $path_vms = 1 if ($path =~ /^--*$/);
my $unix_mode = 0;
if ($path_vms == $path_unix) {
@@ -939,8 +1027,8 @@
if (defined $base) {
$base_unix = 1 if ($base =~ m#/#);
$base_unix = 1 if ($base =~ /^\.\.?$/);
- $base_vms = 1 if ($base =~ m#[\[<\]]#);
- $base_vms = 1 if ($base =~ /^--?$/);
+ $base_vms = 1 if ($base =~ m#(?:[\[<\]]|:$)#);
+ $base_vms = 1 if ($base =~ /^--*$/);
# If we could not determine the path mode, see if we can find out
# from the base.
