I have not tested this or anything on 5.8.7, I am in the process of
moving my changes over to 5.8.7.
Applying this to the 5.8.7 vms.pm results in the vms.pm that I am using
on 5.8.6.
I included Michael Schwern on this since I had to make a similar change
in the mm_vms.pm routines, along with several others which I will post
later, as I merge in my changes into my local copy of the 5.8.7 source.
I am sure that there is probably a better way to do many of the changes
I made to this model, particularly where I have to look up the DECC
feature logicals every time a routine is called.
When my yet to be posted patch to VMS.C is installed, it replaces the
"sub case_tolerant()" routine with one that returns the current process
state.
This also means that on UNIX, this module is now providing what could be
a wrong value, if something wants to know if VMS is case sensitive,
unless you interpret it as actually being that the default on VMS is to
be case insensitive.
Also I have a lot of commented out diagnostics in this, as this was the
only way I found to find out why some test scripts were not working,
particularly in the MakeMaker area.
I was not able to get the canonpath() routine to work correctly with
ODS-5 Extended file specifications in directory name.
In particular, '[.foo^.-.bar]' is a legal directory name on an ODS-5
file, and would correspond to the UNIX './foo.-/bar/' path name. I
could not find a simple change to the Perl rules to stop it from
incorrectly compressing that specification to '[.bar]'. So I put in a
hack to force the directory name into UNIX mode and run the UNIX
canonpath() routine instead when a '^' is found in a VMS directory
specification.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- lib/File/Spec/VMS.pm_5_8_7 Thu Jul 14 10:36:30 2005
+++ lib/File/Spec/VMS.pm Thu Jul 14 10:45:57 2005
@@ -38,6 +38,7 @@
sub eliminate_macros {
my($self,$path) = @_;
return '' unless $path;
+#print STDERR "VMS.pm eliminate_macros - path = $path\n";
$self = {} unless ref $self;
if ($path =~ /\s/) {
@@ -68,6 +69,7 @@
}
}
if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
+#print STDERR "VMS eliminate_macros - npath = $npath\n";
$npath;
}
@@ -92,6 +94,7 @@
return '' unless $path;
$self = bless {} unless ref $self;
my($fixedpath,$prefix,$name);
+ my $vms_mode = 1;
if ($path =~ /\s/) {
return join ' ',
@@ -99,28 +102,100 @@
split /\s+/, $path;
}
+ my $unix_report;
+ my $unix_only;
+ $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ }
+ else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ if (defined $unix_report) {
+ $vms_mode = 0;
+ }
+ if (!defined ($unix_only)) {
+ $vms_mode = 1 if $path =~ m|[\]>:]|;
+ }
+#if ($force_path) {
+#print STDERR "VMS fixpath path = $path, force_path = $force_path \n";
+#} else {
+#print STDERR "VMS fixpath path = $path, force_path = undef \n";
+#}
+
if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
+#my $path_n2 = $self->eliminate_macros($path);
+#print "fixpath (1.0) path_n2 = $path_n2, path = $path \n";
+ if ($vms_mode == 1) {
$fixedpath = vmspath($self->eliminate_macros($path));
}
else {
- $fixedpath = vmsify($self->eliminate_macros($path));
+ $fixedpath = $self->eliminate_macros($path);
+ }
+#print "fixpath (1) path = $path, fixedpath = $fixedpath \n";
+ }
+ else {
+ $fixedpath = $self->eliminate_macros($path);
+ $fixedpath = vmsify($fixedpath) if ($vms_mode == 1);
+#print "fixpath (2) path = $path, fixedpath = $fixedpath \n";
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) &&
$self->{$prefix}) {
my($vmspre) = $self->eliminate_macros("\$($prefix)");
# is it a dir or just a name?
+ if ($vms_mode == 1) {
$vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ?
vmspath($vmspre) : '';
+ }
+ else {
+ $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ?
unixpath($vmspre) : '';
+ }
$fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
- $fixedpath = vmspath($fixedpath) if $force_path;
+ if ($force_path) {
+ if ($vms_mode == 1) {
+ $fixedpath = vmspath($fixedpath);
+ }
+# else {
+# $fixedpath = unixpath($fixedpath);
+# }
+ }
+#print "fixpath (3) path = $path, fixedpath = $fixedpath \n";
}
else {
$fixedpath = $path;
- $fixedpath = vmspath($fixedpath) if $force_path;
+ if ($force_path) {
+ if ($vms_mode == 1) {
+ $fixedpath = vmspath($fixedpath);
+ }
+# else {
+# $fixedpath = unixpath($fixedpath);
+# }
+ }
+#print STDERR "fixpath (4) path = $path, fixedpath = $fixedpath \n";
}
# No hints, so we try to guess
if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
- $fixedpath = vmspath($fixedpath) if -d $fixedpath;
+ if (-d $fixedpath) {
+ if ($vms_mode == 1) {
+ $fixedpath = vmspath($fixedpath);
+ }
+# else {
+# $fixedpath = unixpath($fixedpath);
+# }
+ }
+#print STDERR "fixpath (5) path = $path, fixedpath = $fixedpath \n";
}
# Trim off root dirname if it's had other dirs inserted in front of it.
@@ -130,6 +205,7 @@
# Unix syntax has no way to express "absolute from the top of this device's
# directory tree".
if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
+#print STDERR "VMS fixpath (6) path = $path, fixedpath = $fixedpath \n";
$fixedpath;
}
@@ -148,13 +224,54 @@
sub canonpath {
my($self,$path) = @_;
- if ($path =~ m|/|) { # Fake Unix
+#print STDERR "VMS canonpath (0) path = $path\n";
+ my $vms_mode;
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ # VMS/UNIX mixed handling.
+ $vms_mode = 1;
+ $vms_mode = 0 if ($path =~ m|/|) || (defined $unix_only);
+
+# temp hack to force UNIX mode if EFS characters seen.
+
+ if (($vms_mode == 0) || ($path =~ m|\^|)) { # Fake Unix
+#print STDERR "#vms.pm cannonpath (UNIX mode) path = $path, vms_mode =
$vms_mode\n";
+
+ # Convert to UNIX if need be, VMS cannonpath can not handle EFS charset.
+ $path = unixify($path) if ($vms_mode == 1);
my $pathify = $path =~ m|/\Z(?!\n)|;
+#print STDERR "VMS canonpath (1) path = $path\n";
+
$path = $self->SUPER::canonpath($path);
+#print STDERR "VMS canonpath (2) path = $path\n";
+ if ($vms_mode == 0) {
+ return $path;
+ }
+ else {
if ($pathify) { return vmspath($path); }
else { return vmsify($path); }
}
+ }
else {
+#print STDERR "#vms.pm cannonpath (VMS mode) path = $path\n";
+
$path =~ tr/<>/[]/; # < and > ==> [ and ]
$path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
$path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
@@ -168,7 +285,11 @@
# [-.-. ==> [--.
# .-.-] ==> .--]
# [-.-] ==> [--]
+#print STDERR "VMS canonpath (1) path = $path\n";
1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
+# 1 while ($path =~
s/([\[]*.+(?:(?<!\^)\.)+).+(?:(?!<!\^)\.)-(-+)([\]\.])/$1$2$3/); not working.
+# '^.' must not be treated as '.' - Only seen on ODS-5 EFS specifications
+#print STDERR "VMS canonpath (2) path = $path\n";
# That loop does the following
# with any amount (minimum 2)
# of dashes:
@@ -180,9 +301,17 @@
# And then, the remaining cases
$path =~ s/\[\.-/[-/; # [.- ==> [-
$path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
+# $path =~ s/(?<!\^)\..+(?:(?!<!\^)\.)-\./\./g; # .foo^..-. ==> .
not working.
+#print STDERR "VMS canonpath (3) path = $path\n";
$path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
+# $path =~ s/(?<!\^)\[.+(?:(?!<!\^)\.)-\./\[/g; # [foo^..-. ==-> [
+#print STDERR "VMS canonpath (4) path = $path\n";
$path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
+# $path =~ s/(?<!\^)\..+(?:(?!<!\^)\.)-\]/\]/g; # .foo^..-] == > ]
not working
+#print STDERR "VMS canonpath (5) path = $path\n";
$path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
+# $path =~ s/(?<!\^)\].+(?:(?!<!\^)\.)-\]/\[000000\]/g; # [foo^..-] =>
[000000] not working
+#print STDERR "VMS canonpath (6) path = $path\n";
$path =~ s/\[\]//; # [] ==>
return $path;
}
@@ -197,16 +326,75 @@
=cut
sub catdir {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+ my $case_preserved = 1;
+ $case_preserved = $ENV{'DECC$EFS_CASE_PRESERVE'};
+ if (defined $case_preserved) {
+ if (($case_preserved lt '1') && ($case_preserved ne 'ENABLE')) {
+ $case_preserved = undef;
+ }
+ }
+
+ # VMS mode
my ($self,@dirs) = @_;
+#print STDERR "VMS catdir files = @dirs .\n";
+
+ my $vms_mode = 1;
+ $vms_mode = 0 if (defined $unix_report);
my $dir = pop @dirs;
+ $vms_mode = 1 if $dir =~ m|[\]>:]|;
+#print STDERR "catdir vms_mode = $vms_mode .\n";
@dirs = grep($_,@dirs);
my $rslt;
if (@dirs) {
- my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
+ my $path;
+ if (@dirs == 1) {
+ $path = $dirs[0];
+ $vms_mode = 1 if $path =~ m|[\]>:]|;
+#print STDERR "catdir (1a) dirs[0] = $dirs[0], vms_mode = $vms_mode .\n";
+ }
+ else {
+ $path = $self->catdir(@dirs);
+ $vms_mode = 1 if $path =~ m|[\]>:]|;
+#print STDERR "catdir (1b) path = $path, dirs = @dirs, vms_mode = $vms_mode
.\n";
+ }
my ($spath,$sdir) = ($path,$dir);
+ if (defined $case_preserved) {
+ $spath =~ s/\.DIR\Z(?!\n)//; $sdir =~ s/\.DIR\Z(?!\n)//;
+ }
$spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
+ if ($vms_mode == 0) {
+ $vms_mode = 1 if (($spath ne $path) || ($sdir ne $dir));
+ }
$sdir = $self->eliminate_macros($sdir) unless $sdir =~
/^[\w\-]+\Z(?!\n)/s;
+ if ($vms_mode) {
+#my $spath_n = $self->eliminate_macros($spath);
+#print STDERR "catdir (3a.0) spath_n = $spath_n, spath = $spath, sdir = $sdir,
vms_mode = $vms_mode .\n";
$rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
+ $rslt = vmspath($rslt);
+#print STDERR "catdir (3a) rslt = $rslt, sdir = $sdir, spath = $spath,
vms_mode = $vms_mode .\n";
+ }
+ else {
+ $rslt =
unixify($self->fixpath($self->eliminate_macros($spath)."/$sdir",0));
+#print STDERR "catdir (3b) rslt = $rslt, sdir = $sdir, spath = $spath,
vms_mode = $vms_mode .\n";
+ }
# Special case for VMS absolute directory specs: these will have had
device
# prepended during trip through Unix syntax in eliminate_macros(), since
@@ -216,9 +404,22 @@
}
else {
if (not defined $dir or not length $dir) { $rslt = ''; }
- elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }
- else { $rslt = vmspath($dir); }
+ elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) {
+ $rslt = $dir;
+#print STDERR "catdir (4) rslt = $rslt, vms_mode = $vms_mode .\n";
}
+ else {
+ if ($vms_mode) {
+ $rslt = vmspath($dir);
+#print STDERR "catdir (5a) rslt = $rslt, dir = $dir, vms_mode = $vms_mode .\n";
+ }
+ else {
+ $rslt = unixpath($dir);
+#print STDERR "catdir (5b) rslt = $rslt, dir = $dir, vms_mode = $vms_mode .\n";
+ }
+ }
+ }
+#print STDERR "catdir (6) rslt = $rslt, vms_mode = $vms_mode .\n";
return $self->canonpath($rslt);
}
@@ -230,24 +431,86 @@
=cut
sub catfile {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ if (defined $unix_only) {
+ my $self = shift;
+ my $file = $self->canonpath(pop @_);
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ $dir .= "/" unless substr($dir,-1) eq "/";
+ return $dir.$file;
+
+ } else {
+ # vms / unix mode
my ($self,@files) = @_;
- my $file = $self->canonpath(pop @files);
+#print STDERR "VMS catfile files = @files .\n";
+ my $vms_mode = 1;
+ $vms_mode = 0 if (defined $unix_report);
+ my $file = pop @files;
+ $vms_mode = 1 if $file =~ m|[\]>:]|;
+ $file = $self->canonpath($file);
@files = grep($_,@files);
my $rslt;
if (@files) {
my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
+ $vms_mode = 1 if $path =~ m|[\]>:]|;
my $spath = $path;
+ if (defined $unix_report) {
+ $spath =~ s/\.DIR\Z(?!\n)//;
+ }
+ else {
$spath =~ s/\.dir\Z(?!\n)//;
+ }
if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
$rslt = "$spath$file";
+#print STDERR "catfile 1 spath = $spath, file = $file, rslt = $rslt .\n";
}
else {
$rslt = $self->eliminate_macros($spath);
+#print STDERR "catfile 2a spath = $spath, file = $file, rslt = $rslt .\n";
+ if ($vms_mode) {
$rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
+#print STDERR "catfile 2b spath = $spath, file = $file, rslt = $rslt .\n";
}
+ else {
+ $rslt = $rslt.($rslt ? '/' : '').unixify($file);
+#print STDERR "catfile 2c spath = $spath, file = $file, rslt = $rslt .\n";
+ }
+ }
+ }
+ else {
+ if (defined($file) && (length($file) != 0)) {
+ $rslt = $vms_mode ? vmsify($file) : $file;
+#print STDERR "catfile 3 vms_mode = $vms_mode, file = $file, rslt = $rslt .\n";
+ }
+ else {
+ $rslt = '';
+ }
+ }
+#print STDERR "catfile result = $rslt .\n";
+ return $self->canonpath($rslt) unless defined $unix_report;
+
+ # In unix_report mode, do not strip off the redundant path here.
+ return $rslt;
}
- else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
- return $self->canonpath($rslt);
}
@@ -258,7 +521,30 @@
=cut
sub curdir {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ if (defined $unix_report) {
+ return '.';
+ } else {
return '[]';
+ }
}
=item devnull (override)
@@ -268,7 +554,30 @@
=cut
sub devnull {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ if (defined $unix_report) {
+ return '/dev/null';
+ } else {
return "_NLA0:";
+ }
}
=item rootdir (override)
@@ -278,7 +587,30 @@
=cut
sub rootdir {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ if (defined $unix_report) {
+ return '/';
+ } else {
return 'SYS$DISK:[000000]';
+ }
}
=item tmpdir (override)
@@ -298,7 +630,57 @@
sub tmpdir {
return $tmpdir if defined $tmpdir;
my $self = shift;
+
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ my $posix_compliant = $ENV{'DECC$POSIX_COMPLIANT_PATHNAMES'};
+ if (defined $posix_compliant) {
+ if (($posix_compliant lt '1') && ($posix_compliant ne 'ENABLE')) {
+ $posix_compliant = undef;
+ }
+ }
+
+ if (defined $posix_compliant) {
+ my @dirlist = @_;
+ {
+ no strict 'refs';
+ if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
+ require Scalar::Util;
+ @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
+ }
+ }
+ foreach (@dirlist) {
+ next unless defined && -d && -w _;
+ $tmpdir = $_;
+ last;
+ }
+ $tmpdir = $self->curdir unless defined $tmpdir;
+ $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
+ return $tmpdir;
+ } else {
+ if (defined $unix_report) {
+ $tmpdir = $self->_tmpdir( 'sys$scratch/', $ENV{TMPDIR} );
+ } else {
$tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
+ }
+ }
}
=item updir (override)
@@ -308,7 +690,30 @@
=cut
sub updir {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ if (defined $unix_report) {
+ return '../';
+ } else {
return '[-]';
+ }
}
=item case_tolerant (override)
@@ -317,6 +722,8 @@
=cut
+#fix me - ODS-5 can be case-intolerant.
+
sub case_tolerant {
return 1;
}
@@ -329,9 +736,36 @@
=cut
sub path {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ if (defined $unix_report) {
+ return () unless exists $ENV{PATH};
+ my @path = split(':', $ENV{PATH});
+ foreach (@path) { $_ = '.' if $_ eq '' }
+ return @path;
+ } else {
+ # vms mode
my (@dirs,$dir,$i);
while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
return @dirs;
+ }
}
=item file_name_is_absolute (override)
@@ -343,7 +777,9 @@
sub file_name_is_absolute {
my ($self,$file) = @_;
# If it's a logical name, expand it.
- $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
+ # but do not expand it forever and ever...
+ my $j = 0;
+ $file = $ENV{$file} while (($file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file})
&& ($j++ < 10));
return scalar($file =~ m!^/!s ||
$file =~ m![<\[][^.\-\]>]! ||
$file =~ /:[^<\[]/);
@@ -356,11 +792,55 @@
=cut
sub splitpath {
- my($self,$path) = @_;
+ my $vms_mode = 1;
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+
+ my ($self,$path, $nofile) = @_;
+ if (defined $unix_report) {
+ $vms_mode = 0;
+ $vms_mode = 1 if (defined $path) && ($path =~ m|[\]>:]|);
+ }
+
+ if ($vms_mode == 0) {
+
+ my ($volume,$directory,$file) = ('','','');
+
+ if ( $nofile ) {
+ $directory = $path;
+ }
+ else {
+#print STDERR "#vms.pm splitpath path = undef \n" unless $path;
+ $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs;
+ $directory = $1;
+ $file = $2;
+ }
+
+ return ($volume,$directory,$file);
+ } else {
+ #vms mode
my($dev,$dir,$file) = ('','','');
vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
return ($1 || '',$2 || '',$3);
+ }
}
=item splitdir (override)
@@ -370,7 +850,35 @@
=cut
sub splitdir {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
my($self,$dirspec) = @_;
+ my $vms_mode = 1;
+ if (defined $unix_report) {
+ $vms_mode = 0;
+ $vms_mode = 1 if $dirspec =~ m|[\]>:]|;
+ }
+
+ if ($vms_mode == 0) {
+ return split m|/|, $_[1], -1; # Preserve trailing fields
+ } else {
$dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
$dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
$dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
@@ -388,6 +896,7 @@
my(@dirs) = split('\.', vmspath($dirspec));
$dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
@dirs;
+ }
}
@@ -400,7 +909,58 @@
sub catpath {
my($self,$dev,$dir,$file) = @_;
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
+ my $vms_mode = 1;
+ if (defined $unix_report) {
+ $vms_mode = 0;
+ $vms_mode = 1 if $dir =~ m|[\]>:;]|;
+ $vms_mode = 1 if $dev =~ m|[\]>:;]|;
+ $vms_mode = 1 if (@_ == 4) && $dev ne '';
+ }
+ if ($vms_mode == 0) {
+ if ( $dir ne '' &&
+ $file ne '' &&
+ substr( $dir, -1 ) ne '/' &&
+ substr( $file, 0, 1 ) ne '/'
+ ) {
+ $dir .= "/$file" ;
+ }
+ else {
+ $dir .= $file ;
+ }
+
+ return $dir ;
+ } else {
# We look for a volume in $dev, then in $dir, but not both
+
+ # Make sure $dir is in VMS format if UNIX emulation is on or you may
+ # get a UNIX format result that you are not expecting.
+ if (defined $unix_report) {
+ if ($dir eq '') {
+ $dir = '[]';
+ }
+ else {
+ $dir = vmspath($dir);
+ }
+ }
my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
$dev = $dir_volume unless length $dev;
$dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
@@ -411,7 +971,9 @@
$dir = "[$dir]" unless $dir =~ /[\[<\/]/;
$dir = vmspath($dir);
}
+
"$dev$dir$file";
+ }
}
=item abs2rel (override)
@@ -421,11 +983,132 @@
=cut
sub abs2rel {
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
my $self = shift;
+ my($path,$base) = @_;
+ my $vms_mode = 1;
+ if (defined $unix_report) {
+ $vms_mode = 0;
+ if (defined $path) {
+ $vms_mode = 1 if $path =~ m|[\]>:]|;
+ }
+ if (defined $base) {
+ if ($vms_mode == 1) {
+ $base = vmsify($base);
+ }
+ else {
+ if ($base =~ m|[\]>:]|) {
+ if (($vms_mode == 0) && defined $path) {
+ $path = vmsify($path);
+ }
+ $vms_mode = 1
+ }
+ }
+ }
+ }
+
+ if ($vms_mode == 0) {
+
+ my $path_abs = 0;
+ my $base_abs = 0;
+
+ # Clean up $path
+ if ( ! $self->file_name_is_absolute( $path ) ) {
+ $path = $self->rel2abs( $path ) ;
+ }
+ else {
+ $path_abs = 1;
+ $path = $self->canonpath( $path ) ;
+ }
+
+ # Figure out the effective $base and clean it up.
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd();
+ $base_abs = 1;
+ }
+ elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ }
+ else {
+ $base = $self->canonpath( $base ) ;
+ $base_abs = 1;
+ }
+
+ # Now, remove all leading components that are the same
+ my @pathchunks = $self->splitdir( $path);
+ my @basechunks = $self->splitdir( $base);
+
+ if ($base_abs == 1 || ($path_abs == 1)) {
+ # Fix me: No real root may be common between the path and base
+ # It would take comparing the physical device name of the absolute
+ # paths of both components to find out a relative path could
+ # be crafted.
+
+ # Different algorithms are also needed when in traditional
+ # UNIX emulation mode, SYS$POSIX_ROOT mode and the new
+ # Posix Compliant mode.
+
+ # So if the path is not absolute or the both the path and base
+ # are not absolute, then returning path is the only safe
+ # thing to do in UNIX emulation mode.
+ if (($path_abs == 0) || ($base_abs != $path_abs)) {
+ return $path;
+ }
+
+ # If both are absolute, then they need the same base directory
+ if (!defined $pathchunks[1] || !defined $basechunks[1] ||
+ ($pathchunks[1] ne $basechunks[1])) {
+ return $path;
+ }
+
+ }
+
+ while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
+ shift @pathchunks ;
+ shift @basechunks ;
+ }
+
+ $path = CORE::join( '/', @pathchunks );
+ $base = CORE::join( '/', @basechunks );
+
+ # $base now contains the directories the resulting relative path
+ # must ascend out of before it can descend to $path_directory. So,
+ # replace all names with $parentDir
+ $base =~ s|[^/]+|..|g ;
+
+ # Glue the two together, using a separator if necessary, and preventing an
+ # empty result.
+ if ( $path ne '' && $base ne '' ) {
+ $path = "$base/$path" ;
+ } else {
+ $path = "$base$path" ;
+ }
+
+ return $self->canonpath( $path ) ;
+ } else {
+ # vms mode
return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
- if grep m{/}, @_;
+ if (grep m{/}, @_) && !(defined $unix_report);
- my($path,$base) = @_;
+ ($path,$base) = @_;
$base = $self->_cwd() unless defined $base and length $base;
for ($path, $base) { $_ = $self->canonpath($_) }
@@ -440,7 +1123,9 @@
# and we do not even try to call $parse() or consult %ENV for $trnlnm()
# (this module needs to run on non VMS platforms after all).
+#print STDERR "#vms.pm splitpath call (2) path = $path\n";
my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
+#print STDERR "#vms.pm splitpath call (3) base = $base\n";
my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
return $path unless lc($path_volume) eq lc($base_volume);
@@ -448,10 +1133,13 @@
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
+ my $pathchunks = @pathchunks;
unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
my @basechunks = $self->splitdir( $base_directories );
+ my $basechunks = @basechunks;
unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
-
+#print STDERR "#vms.pm rel2abs basechunks = $basechunks, pathchunks =
$pathchunks\n";
+ if (case_tolerant) {
while ( @pathchunks &&
@basechunks &&
lc( $pathchunks[0] ) eq lc( $basechunks[0] )
@@ -459,11 +1147,30 @@
shift @pathchunks ;
shift @basechunks ;
}
-
+ }
+ else {
+ while ( @pathchunks &&
+ @basechunks &&
+ $pathchunks[0] eq $basechunks[0]
+ ) {
+ shift @pathchunks ;
+ shift @basechunks ;
+ }
+ }
# @basechunks now contains the directories to climb out of,
# @pathchunks now has the directories to descend in to.
+ if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
+#print STDERR "#vms.pm rel2abs basechunks > 0\n";
$path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
- return $self->canonpath( $self->catpath( '', $path_directories, $path_file
) ) ;
+ }
+ else {
+#print STDERR "#vms.pm rel2abs basechunks <= 0\n";
+ $path_directories = join '.', @pathchunks;
+ }
+ $path_directories = '['.$path_directories.']';
+#print STDERR "#vms.pm rel2abs catpath call (3a) p_dir = $path_directories,
p_file = $path_file\n";
+ return vmsify($self->canonpath( $self->catpath( '', $path_directories,
$path_file ) ) );
+ }
}
@@ -474,8 +1181,69 @@
=cut
sub rel2abs {
+
+ my $posix_compliant = $ENV{'DECC$POSIX_COMPLIANT_PATHNAMES'};
+ if (defined $posix_compliant) {
+ if (($posix_compliant lt '1') && ($posix_compliant ne 'ENABLE')) {
+ $posix_compliant = undef;
+ }
+ }
+
+ my $unix_report;
+ my $unix_only = $ENV{'DECC$FILENAME_UNIX_ONLY'};
+ if (defined $unix_only) {
+ if (($unix_only ne '1') && ($unix_only ne 'ENABLE')) {
+ $unix_only = undef;
+ }
+ }
+
+ if (defined $unix_only) {
+ $unix_report = 1;
+ } else {
+ $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'};
+ if (defined $unix_report) {
+ if (($unix_report ne '1') && ($unix_report ne 'ENABLE')) {
+ $unix_report = undef;
+ }
+ }
+ }
+
my $self = shift ;
my ($path,$base ) = @_;
+ my $vms_mode = 1;
+ if (defined $unix_report) {
+ $vms_mode = 0;
+ if (defined $path) {
+ $vms_mode = 1 if $path =~ m|[\]>:]|;
+ }
+ if (defined $base) {
+ $vms_mode = 1 if $base =~ m|[\]>:]|;
+ }
+ }
+
+ if ($vms_mode == 0) {
+
+ # Clean up $path
+ if ( ! $self->file_name_is_absolute( $path ) ) {
+ # Figure out the effective $base and clean it up.
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd();
+ }
+ elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ }
+ else {
+ $base = $self->canonpath( $base ) ;
+ }
+
+ # Glom them together
+ $path = $self->catdir( $base, $path ) ;
+ }
+
+ return $self->canonpath( $path ) ;
+
+ } else {
+ # VMS mode
return undef unless defined $path;
if ($path =~ m/\//) {
$path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
@@ -488,18 +1256,30 @@
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd;
+
+ $base = vmspath($base) if $vms_mode == 1;
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
+
+ $base = vmspath($base) if $vms_mode == 1;
}
else {
$base = $self->canonpath( $base ) ;
}
+ # are we forced to $vms_mode == 0?
+ if ($vms_mode == 0) {
+ $base = unixpath($base); # Must have trailing '/'
+ $path = unixify($path);
+ }
+
# Split up paths
+#print STDERR "#vms.pm splitpath call (4) path = $path\n";
my ( $path_directories, $path_file ) =
($self->splitpath( $path ))[1,2] ;
+#print STDERR "#vms.pm splitpath call (5) base = $base\n";
my ( $base_volume, $base_directories ) =
$self->splitpath( $base ) ;
@@ -508,15 +1288,18 @@
my $sep = '' ;
$sep = '.'
if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
- $path_directories =~ m{^[^.\[<]}s
+ $path_directories =~ m{^[^.\[<]}s &&
+ $vms_mode == 1
) ;
$base_directories = "$base_directories$sep$path_directories";
$base_directories =~ s{\.?[\]>][\[<]\.?}{.};
+#print STDERR "#vms.pm splitpath call cat_path (5.1) $base_volume,
$base_directories, $path_file \n";
$path = $self->catpath( $base_volume, $base_directories, $path_file );
}
return $self->canonpath( $path ) ;
+ }
}
