From: John Malmberg Date: Fri, 9 Jan 2009 20:20:21 +0000 (+0100) Subject: 'VMS support for Unix and extended file specifications' (PathTools RT #42153) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ae5a807c7dcf22892f732599c013eab30c61162a;p=p5sagit%2Fp5-mst-13.2.git 'VMS support for Unix and extended file specifications' (PathTools RT #42153) --- diff --git a/ext/Cwd/Changes b/ext/Cwd/Changes index 1c34381..7c10f10 100644 --- a/ext/Cwd/Changes +++ b/ext/Cwd/Changes @@ -1,8 +1,10 @@ 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." +- Update to support VMS in Unix compatible mode and/or file names using + extended character sets. (RT #42154) [John Malmberg] + +- VMS support for Unix and extended file specifications in File::Spec + (RT #42153) [John Malmberg] 3.29 - Wed Oct 29 20:48:11 2008 diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index 3585b9a..07a78dc 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.29'; +$VERSION = '3.29_1'; $VERSION = eval $VERSION; @ISA = qw(File::Spec::Unix); @@ -26,26 +26,105 @@ See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. +The mode of operation of these routines depend on the VMS features that +are controlled by the DECC features C and +C. + +Perl needs to be at least at 5.10 for these feature settings to work. +Use of them on older perl versions on VMS will result in unpredictable +operations. + +The default and traditional mode of these routines have been to expect VMS +syntax on input and to return VMS syntax on output, even when Unix syntax was +given on input. + +The default and traditional mode is also incompatible with the VMS +C, Extended File system character set, and with running Perl scripts +under , Gnu is not VMS, an optional Unix like runtime environment on VMS. + +If the C feature is enabled, These routines will now accept +either VMS or UNIX syntax. If the input parameters are clearly VMS syntax, +the return value will be in VMS syntax. If the input parameters are clearly +in Unix syntax, the output will be in Unix syntax. + +This corresponds to the way that the VMS C library routines have always +handled filenames, and what a programmer who has not specifically read this +pod before would also expect. + +If the C feature is enabled, then if the output +syntax can not be determined from the input syntax, the output syntax will be +UNIX. If the feature is not enabled, VMS output will be the default. + =over 4 +=cut + +# Need to look up the feature settings. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. + +my $use_feature; +BEGIN { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_feature = 1; + } +} + +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _unix_rpt { + my $unix_rpt; + if ($use_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 _efs { + my $efs; + if ($use_feature) { + $efs = VMS::Feature::current("efs_charset"); + } else { + my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; + $efs = $env_efs =~ /^[ET1]/i; + } + return $efs; +} + =item canonpath (override) -Removes redundant portions of file specifications according to VMS syntax. +Removes redundant portions of file specifications according to the syntax +detected. =cut + sub canonpath { my($self,$path) = @_; return undef unless defined $path; + my $efs = $self->_efs; + if ($path =~ m|/|) { # Fake Unix my $pathify = $path =~ m|/\Z(?!\n)|; $path = $self->SUPER::canonpath($path); + + # Do not convert to VMS when EFS character sets are in use + return $path if $efs; + if ($pathify) { return vmspath($path); } else { return vmsify($path); } } else { + +#FIXME - efs parsing has different rules. Characters in a VMS filespec +# are only delimiters if not preceded by '^'; + $path =~ tr/<>/[]/; # < and > ==> [ and ] $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ @@ -82,7 +161,7 @@ sub canonpath { =item catdir (override) Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. No check is made for "impossible" +directory specification. No check is made for "impossible" cases (e.g. elements other than the first being absolute filespecs). =cut @@ -90,87 +169,377 @@ cases (e.g. elements other than the first being absolute filespecs). sub catdir { my $self = shift; my $dir = pop; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + my @dirs = grep {defined() && length()} @_; + if ($efs) { + # Legacy mode removes blank entries. + # But that breaks existing generic perl code that + # uses a blank path at the beginning of the array + # to indicate an absolute path. + # So put it back if found. + if (@_) { + if ($_[0] eq '') { + unshift @dirs, ''; + } + } + } my $rslt; if (@dirs) { my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - # Special case for VMS absolute directory specs: these will have had device - # prepended during trip through Unix syntax in eliminate_macros(), since - # Unix syntax has no way to express "absolute from the top of this device's - # directory tree". - if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } - } - else { + if ($efs) { + # Extended character set in use, go into DWIM mode. + + # Now we need to identify what the directory is in + # of the specification in order to merge them. + my $path_unix = 0; + $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 =~ /^--?$/); + 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 =~ /^--?$/); + + my $unix_mode = 0; + if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) { + # Ambiguous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt); + $unix_mode = 1 if ($path_unix || $dir_unix); + } + + if ($unix_mode) { + + # Fix up mixed syntax imput as good as possible - GIGO + $path = unixify($path) if $path_vms; + $dir = unixify($dir) if $dir_vms; + + $rslt = $path; + # Append a path delimiter + $rslt .= '/' unless ($rslt =~ m#/$#); + + $rslt .= $dir; + return $self->SUPER::canonpath($rslt); + } else { + + #with <> posible instead of [. + # Normalize the brackets + # Fixme - need to not switch when preceded by ^. + $path =~ 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; + + #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. + unless ($path_vms) { + $path =~ s/\.dir\Z(?!\n)//i; + if (($path ne '') && ($path !~ /^-/)) { + # Non blank and not prefixed with '-', add a dot + $path = '[.' . $path; + } else { + # Just start a directory. + $path = '[' . $path; + } + } else { + $path =~ s/\]$//; + } + + #Possible dir values: [.dir] dir and $(foo) + + # No punctuation may have a trailing .dir + unless ($dir_vms) { + $dir =~ s/\.dir\Z(?!\n)//i; + } else { + + #strip off the brackets + $dir =~ s/^\[//; + $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 . ']'; + } else { + $rslt = $path . ']'; + } + } + + } else { + # Traditional ODS-2 mode. + $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; + + $sdir = $self->eliminate_macros($sdir) + unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + + # Special case for VMS absolute directory specs: these will have + # had device prepended during trip through Unix syntax in + # eliminate_macros(), since Unix syntax has no way to express + # "absolute from the top of this device's directory tree". + if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } + } + } else { + # Single directory, just make sure it is in directory format + # Return an empty string on null input, and pass through macros. + 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; + } else { + my $unix_mode = 0; + + if ($efs) { + 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 =~ /^--?$/); + + if ($dir_vms == $dir_unix) { + # Ambiguous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 if $dir_unix; + } + } + + if ($unix_mode) { + return $dir; + } else { + # For VMS, force it to be in directory format + $rslt = vmspath($dir); + } + } } return $self->canonpath($rslt); } =item catfile (override) -Concatenates a list of file specifications, and returns the result as a -VMS-syntax file specification. +Concatenates a list of directory specifications with a filename specification +to build a path. =cut sub catfile { my $self = shift; - my $file = $self->canonpath(pop()); + my $tfile = pop(); + my $file = $self->canonpath($tfile); my @files = grep {defined() && length()} @_; + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + # Assume VMS mode + my $unix_mode = 0; + my $file_unix = 0; + my $file_vms = 0; + if ($efs) { + + # Now we need to identify format the file is in + # of the specification in order to merge them. + $file_unix = 1 if ($tfile =~ m#/#); + $file_unix = 1 if ($tfile =~ /^\.\.?$/); + $file_vms = 1 if ($tfile =~ m#[\[<\]]#); + $file_vms = 1 if ($tfile =~ /^--?$/); + + # We may know for sure what the format is. + if (($file_unix != $file_vms)) { + $unix_mode = 1 if ($file_unix && $unix_rpt); + } + } + my $rslt; if (@files) { - my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + # concatenate the directories. + my $path; + if (@files == 1) { + $path = $files[0]; + } else { + if ($file_vms) { + # We need to make sure this is in VMS mode to avoid doing + # both a vmsify and unixfy on the same path, as that may + # lose significant data. + my $i = @files - 1; + my $tdir = $files[$i]; + my $tdir_vms = 0; + my $tdir_unix = 0; + $tdir_vms = 1 if ($tdir =~ m#[\[<\]]#); + $tdir_unix = 1 if ($tdir =~ m#/#); + $tdir_unix = 1 if ($tdir =~ /^\.\.?$/); + + if (!$tdir_vms) { + if ($tdir_unix) { + $tdir = vmspath($tdir); + } else { + $tdir =~ s/\.dir\Z(?!\n)//i; + $tdir = '[.' . $tdir . ']'; + } + $files[$i] = $tdir; + } + } + $path = $self->catdir(@files); + } my $spath = $path; - $spath =~ s/\.dir\Z(?!\n)//; + + # Some thing building a VMS path in pieces may try to pass a + # directory name in filename format, so normalize it. + $spath =~ s/\.dir\Z(?!\n)//i; + + # if the spath ends with a directory delimiter and the file is bare, + # then just concat them. + # FIX-ME: In VMS format "[]<>:" are not delimiters if preceded by '^' + # Quite a bit of Perl does not know that yet. if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { $rslt = "$spath$file"; - } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.((defined $rslt) && ($rslt ne '') ? '/' : '').unixify($file)); + } else { + if ($efs) { + + # Now we need to identify what the directory is in + # of the specification in order to merge them. + my $spath_unix = 0; + $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 =~ /^--?$/); + + # Assume VMS mode + if (($spath_unix == $spath_vms) && + ($file_unix == $file_vms)) { + # Ambigous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 + if (($spath_unix || $file_unix) && $unix_rpt); + } + + if (!$unix_mode) { + if ($spath_vms) { + $spath = '[' . $spath . ']' if $spath =~ /^-/; + $rslt = vmspath($spath); + } else { + $rslt = '[.' . $spath . ']'; + } + $file = vmsify($file) if ($file_unix); + } else { + $spath = unixify($spath) if ($spath_vms); + $rslt = $spath; + $file = unixify($file) if ($file_vms); + + # Unix merge may need a directory delimitor. + # A null path indicates root on Unix. + $rslt .= '/' unless ($rslt =~ m#/$#); + } + + $rslt .= $file; + $rslt =~ s/\]\[//; + + } else { + # Traditional VMS Perl mode expects that this is done. + # Note for future maintainers: + # This is left here for compatibility with perl scripts + # that have come to expect this behavior, even though + # usually the Perl scripts ported to VMS have to be + # patched because of it changing Unix syntax file + # to VMS format. + + $rslt = $self->eliminate_macros($spath); + + + $rslt = vmsify($rslt.((defined $rslt) && + ($rslt ne '') ? '/' : '').unixify($file)); + } } } - else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } - return $self->canonpath($rslt); + else { + # Only passed a single file? + my $xfile = $file; + + # Traditional VMS perl expects this conversion. + $xfile = vmsify($file) unless ($efs); + + $rslt = (defined($file) && length($file)) ? $xfile : ''; + } + return $self->canonpath($rslt) unless $unix_rpt; + + # In Unix report mode, do not strip off redundent path information. + return $rslt; } =item curdir (override) -Returns a string representation of the current directory: '[]' +Returns a string representation of the current directory: '[]' or '.' =cut sub curdir { + my $self = shift @_; + return '.' if ($self->_unix_rpt); return '[]'; } =item devnull (override) -Returns a string representation of the null device: '_NLA0:' +Returns a string representation of the null device: '_NLA0:' or '/dev/null' =cut sub devnull { + my $self = shift @_; + return '/dev/null' if ($self->_unix_rpt); return "_NLA0:"; } =item rootdir (override) Returns a string representation of the root directory: 'SYS$DISK:[000000]' +or '/' =cut sub rootdir { + my $self = shift @_; + if ($self->_unix_rpt) { + # Root may exist, try it first. + my $try = '/'; + my ($dev1, $ino1) = stat('/'); + my ($dev2, $ino2) = stat('.'); + + # Perl falls back to '.' if it can not determine '/' + if (($dev1 != $dev2) || ($ino1 != $ino2)) { + return $try; + } + # Fall back to UNIX format sys$disk. + return '/sys$disk/'; + } return 'SYS$DISK:[000000]'; } @@ -179,6 +548,7 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: + /tmp if C is enabled. sys$scratch: $ENV{TMPDIR} @@ -189,17 +559,25 @@ is tainted, it is not used. my $tmpdir; sub tmpdir { + my $self = shift @_; return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + if ($self->_unix_rpt) { + $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); + return $tmpdir; + } + + $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); } =item updir (override) -Returns a string representation of the parent directory: '[-]' +Returns a string representation of the parent directory: '[-]' or '..' =cut sub updir { + my $self = shift @_; + return '..' if ($self->_unix_rpt); return '[-]'; } @@ -256,8 +634,19 @@ between directories and files at a glance. sub splitpath { my($self,$path, $nofile) = @_; my($dev,$dir,$file) = ('','',''); - my $vmsify_path = vmsify($path); - if ( $nofile ){ + my $efs = $self->_efs; + my $vmsify_path = vmsify($path); + if ($efs) { + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + if (!$path_vms) { + return $self->SUPER::splitpath($path, $nofile); + } + $vmsify_path = $path; + } + + if ( $nofile ) { #vmsify('d1/d2/d3') returns '[.d1.d2]d3' #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' if( $vmsify_path =~ /(.*)\](.+)/ ){ @@ -275,7 +664,7 @@ sub splitpath { =item splitdir (override) -Split dirspec using VMS syntax. +Split a directory specification into the components. =cut @@ -283,6 +672,20 @@ sub splitdir { my($self,$dirspec) = @_; my @dirs = (); return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); + + my $efs = $self->_efs; + + my $dir_unix = 0; + $dir_unix = 1 if ($dirspec =~ m#/#); + $dir_unix = 1 if ($dirspec =~ /^\.\.?$/); + + # Unix filespecs in EFS mode handled by Unix routines. + if ($efs && $dir_unix) { + return $self->SUPER::splitdir($dirspec); + } + + # FIX ME, only split for VMS delimiters not prefixed with '^'. + $dirspec =~ tr/<>/[]/; # < and > ==> [ and ] $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ @@ -306,40 +709,152 @@ sub splitdir { =item catpath (override) -Construct a complete filespec using VMS syntax +Construct a complete filespec. =cut sub catpath { my($self,$dev,$dir,$file) = @_; + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + my $unix_mode = 0; + 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 =~ /^--?$/); + + if ($efs && (length($dev) == 0)) { + if ($dir_unix == $dir_vms) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $dir_unix; + } + } + # We look for a volume in $dev, then in $dir, but not both - 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; - + # but only if using VMS syntax. + if (!$unix_mode) { + $dir = vmspath($dir) if $dir_unix; + 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; + } if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } if (length($dev) or length($dir)) { - $dir = "[$dir]" unless $dir =~ /[\[<\/]/; - $dir = vmspath($dir); + if ($efs) { + if ($unix_mode) { + $dir .= '/' unless ($dir =~ m#/$#); + } else { + $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/)); + $dir = "[$dir]" unless $dir =~ /^[\[<]/; + } + } else { + $dir = "[$dir]" unless $dir =~ /[\[<\/]/; + $dir = vmspath($dir); + } } "$dev$dir$file"; } =item abs2rel (override) -Use VMS syntax when converting filespecs. +Attempt to convert a file specification to a relative specification. +On a system with volumes, like VMS, this may not be possible. =cut sub abs2rel { my $self = shift; - return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) - if grep m{/}, @_; - my($path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + if (!$efs) { + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) + if grep m{/}, @_; + } + + # We need to identify what the directory is in + # of the specification in order to process them + my $path_unix = 0; + $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 =~ /^--?$/); + + my $unix_mode = 0; + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $path_unix; + } + + my $base_unix = 0; + my $base_vms = 0; + + 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 =~ /^--?$/); + + if ($path_vms == $path_unix) { + if ($base_vms == $base_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $base_unix; + } + } else { + $unix_mode = 0 if $base_vms; + } + } + + if ($efs) { + if ($unix_mode) { + # We are UNIX mode. + $base = unixpath($base) if $base_vms; + $base = 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 + # so that we can remove the common components. + + if ($path =~ m#^/#) { + if (defined $base) { + + # For the shorterm, if the starting directories are + # common, remove them. + my $bq = qq($base); + $bq =~ s/\$/\\\$/; + $path =~ s/^$bq//i; + } + return $path; + } + + return File::Spec::Unix::abs2rel( $self, $path, $base ); + + } else { + $base = vmspath($base) if $base_unix; + $path = vmsify($path) if $path_unix; + } + } + + unless (defined $base and length $base) { + $base = $self->_cwd(); + if ($efs) { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base = vmspath($base) if $base_unix; + } + } for ($path, $base) { $_ = $self->canonpath($_) } @@ -390,7 +905,7 @@ sub abs2rel { =item rel2abs (override) -Use VMS syntax when converting filespecs. +Return an absolute file specification from a relative one. =cut @@ -398,12 +913,58 @@ sub rel2abs { my $self = shift ; my ($path,$base ) = @_; return undef unless defined $path; - if ($path =~ m/\//) { - $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about - ? vmspath($path) # whether it's a directory - : vmsify($path) ); + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + # We need to identify what the directory is in + # of the specification in order to process them + my $path_unix = 0; + $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 =~ /^--?$/); + + my $unix_mode = 0; + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $path_unix; + } + + my $base_unix = 0; + my $base_vms = 0; + + 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 =~ /^--?$/); + + # If we could not determine the path mode, see if we can find out + # from the base. + if ($path_vms == $path_unix) { + if ($base_vms != $base_unix) { + $unix_mode = $base_unix; + } + } } - $base = vmspath($base) if defined $base && $base =~ m/\//; + + if (!$efs) { + # Legacy behavior, convert to VMS syntax. + $unix_mode = 0; + if (defined $base) { + $base = vmspath($base) if $base =~ m/\//; + } + + if ($path =~ m/\//) { + $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about + ? vmspath($path) # whether it's a directory + : vmsify($path) ); + } + } + # Clean up and split up $path if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. @@ -417,6 +978,20 @@ sub rel2abs { $base = $self->canonpath( $base ) ; } + if ($efs) { + # base may have changed, so need to look up format again. + if ($unix_mode) { + $base_vms = 1 if ($base =~ m#[\[<\]]#); + $base_vms = 1 if ($base =~ /^--?$/); + $base = unixpath($base) if $base_vms; + $base .= '/' unless ($base =~ m#/$#); + } else { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base = vmspath($base) if $base_unix; + } + } + # Split up paths my ( $path_directories, $path_file ) = ($self->splitpath( $path ))[1,2] ; @@ -427,12 +1002,23 @@ sub rel2abs { $path_directories = '' if $path_directories eq '[]' || $path_directories eq '<>'; my $sep = '' ; - $sep = '.' - if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && - $path_directories =~ m{^[^.\[<]}s - ) ; - $base_directories = "$base_directories$sep$path_directories"; - $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + + if ($efs) { + # Merge the paths assuming that the base is absolute. + $base_directories = $self->catdir('', + $base_directories, + $path_directories); + } else { + # Legacy behavior assumes VMS only paths + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && + $path_directories =~ m{^[^.\[<]}s + ) ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + } + + $path_file = '' if ($path_file eq '.') && $unix_mode; $path = $self->catpath( $base_volume, $base_directories, $path_file ); } @@ -449,6 +1035,14 @@ sub rel2abs { # # Please consider these two methods deprecated. Do not patch them, # patch the ones in ExtUtils::MM_VMS instead. +# +# Update: MakeMaker 6.48 is still using these routines on VMS. +# so they need to be kept up to date with ExtUtils::MM_VMS. +# +# The traditional VMS mode using ODS-2 disks depends on these routines +# being here. These routines should not be called in when the +# C or C modes are enabled. + sub eliminate_macros { my($self,$path) = @_; return '' unless (defined $path) && ($path ne ''); @@ -458,13 +1052,16 @@ sub eliminate_macros { return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; } - my($npath) = unixify($path); + my $npath = unixify($path); + # sometimes unixify will return a string with an off-by-one trailing null + $npath =~ s{\0$}{}; + my($complex) = 0; my($head,$macro,$tail); # perform m##g in scalar context so it acts as an iterator while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { - if ($self->{$2}) { + if (defined $self->{$2}) { ($head,$macro,$tail) = ($1,$2,$3); if (ref $self->{$macro}) { if (ref $self->{$macro} eq 'ARRAY') { @@ -486,6 +1083,19 @@ sub eliminate_macros { } # Deprecated. See the note above for eliminate_macros(). + +# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros +# in any directory specification, in order to avoid juxtaposing two +# VMS-syntax directories when MM[SK] is run. Also expands expressions which +# are all macro, so that we can tell how long the expansion is, and avoid +# overrunning DCL's command buffer when MM[KS] is running. + +# fixpath() checks to see whether the result matches the name of a +# directory in the current default directory and returns a directory or +# file specification accordingly. C<$is_dir> can be set to true to +# force fixpath() to consider the path to be a directory or false to force +# it to be a file. + sub fixpath { my($self,$path,$force_path) = @_; return '' unless $path; diff --git a/lib/File/Spec/t/Spec.t b/lib/File/Spec/t/Spec.t index 6150bc3..0c629bf 100644 --- a/lib/File/Spec/t/Spec.t +++ b/lib/File/Spec/t/Spec.t @@ -13,6 +13,22 @@ eval { require VMS::Filespec ; } ; +my $vms_unix_rpt; +my $vms_efs; + +if ($^O eq 'VMS') { + 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; + } +} + + my $skip_exception = "Install VMS::Filespec (from vms/ext)" ; if ( $@ ) { @@ -85,6 +101,7 @@ if ($^O eq 'MacOS') { [ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], [ "Unix->catdir()", '' ], +[ "Unix->catdir('')", '/' ], [ "Unix->catdir('/')", '/' ], [ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], [ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], @@ -285,27 +302,29 @@ if ($^O eq 'MacOS') { [ "VMS->case_tolerant()", '1' ], -[ "VMS->catfile('a','b','c')", '[.a.b]c' ], +[ "VMS->catfile('a','b','c')", $vms_unix_rpt ? 'a/b/c' : '[.a.b]c' ], [ "VMS->catfile('a','b','[]c')", '[.a.b]c' ], [ "VMS->catfile('[.a]','b','c')", '[.a.b]c' ], [ "VMS->catfile('c')", 'c' ], [ "VMS->catfile('[]c')", 'c' ], -[ "VMS->catfile('0','b','c')", '[.0.b]c' ], -[ "VMS->catfile('a','0','c')", '[.a.0]c' ], -[ "VMS->catfile('a','b','0')", '[.a.b]0' ], -[ "VMS->catfile('0','0','c')", '[.0.0]c' ], -[ "VMS->catfile('a','0','0')", '[.a.0]0' ], -[ "VMS->catfile('0','b','0')", '[.0.b]0' ], -[ "VMS->catfile('0','0','0')", '[.0.0]0' ], +[ "VMS->catfile('0','b','c')", $vms_unix_rpt ? '0/b/c' : '[.0.b]c' ], +[ "VMS->catfile('a','0','c')", $vms_unix_rpt ? 'a/0/c' : '[.a.0]c' ], +[ "VMS->catfile('a','b','0')", $vms_unix_rpt ? 'a/b/0' : '[.a.b]0' ], +[ "VMS->catfile('0','0','c')", $vms_unix_rpt ? '0/0/c' : '[.0.0]c' ], +[ "VMS->catfile('a','0','0')", $vms_unix_rpt ? 'a/0/0' : '[.a.0]0' ], +[ "VMS->catfile('0','b','0')", $vms_unix_rpt ? '0/b/0' : '[.0.b]0' ], +[ "VMS->catfile('0','0','0')", $vms_unix_rpt ? '0/0/0' : '[.0.0]0' ], [ "VMS->splitpath('file')", ',,file' ], [ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], [ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], [ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], -[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], +[ "VMS->splitpath('d1/d2/d3/file')", + $vms_efs ? ',d1/d2/d3/,file' : ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('/d1/d2/d3/file')", + $vms_efs ? ',/d1/d2/d3/,file' : 'd1:,[d2.d3],file' ], [ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], [ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], [ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], @@ -325,16 +344,16 @@ if ($^O eq 'MacOS') { [ "VMS->splitpath('[0]0')", ',[0],0' ], [ "VMS->splitpath('[0.0.0]0')", ',[0.0.0],0' ], [ "VMS->splitpath('[.0.0.0]0')", ',[.0.0.0],0' ], -[ "VMS->splitpath('0/0')", ',[.0],0' ], -[ "VMS->splitpath('0/0/0')", ',[.0.0],0' ], -[ "VMS->splitpath('/0/0')", '0:,[000000],0' ], -[ "VMS->splitpath('/0/0/0')", '0:,[0],0' ], +[ "VMS->splitpath('0/0')", $vms_efs ? ',0/,0' : ',[.0],0' ], +[ "VMS->splitpath('0/0/0')", $vms_efs ? ',0/0/,0' : ',[.0.0],0' ], +[ "VMS->splitpath('/0/0')", $vms_efs ? ',/0/,0' : '0:,[000000],0' ], +[ "VMS->splitpath('/0/0/0')", $vms_efs ? ',/0/0/,0' : '0:,[0],0' ], [ "VMS->splitpath('d1',1)", ',d1,' ], # $no_file tests [ "VMS->splitpath('[d1.d2.d3]',1)", ',[d1.d2.d3],' ], [ "VMS->splitpath('[.d1.d2.d3]',1)", ',[.d1.d2.d3],' ], -[ "VMS->splitpath('d1/d2/d3',1)", ',[.d1.d2.d3],' ], -[ "VMS->splitpath('/d1/d2/d3',1)", 'd1:,[d2.d3],' ], +[ "VMS->splitpath('d1/d2/d3',1)", $vms_efs ? ',d1/d2/d3,' : ',[.d1.d2.d3],' ], +[ "VMS->splitpath('/d1/d2/d3',1)", $vms_efs ? ',/d1/d2/d3,' : 'd1:,[d2.d3],' ], [ "VMS->splitpath('node::volume:[d1.d2.d3]',1)", 'node::volume:,[d1.d2.d3],' ], [ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]',1)", 'node"access_spec"::volume:,[d1.d2.d3],' ], [ "VMS->splitpath('[]',1)", ',[],' ], @@ -345,18 +364,19 @@ if ($^O eq 'MacOS') { [ "VMS->splitpath('[.0]',1)", ',[.0],' ], [ "VMS->splitpath('[0.0.0]',1)", ',[0.0.0],' ], [ "VMS->splitpath('[.0.0.0]',1)", ',[.0.0.0],' ], -[ "VMS->splitpath('0/0',1)", ',[.0.0],' ], -[ "VMS->splitpath('0/0/0',1)", ',[.0.0.0],' ], -[ "VMS->splitpath('/0/0',1)", '0:,[000000.0],' ], -[ "VMS->splitpath('/0/0/0',1)", '0:,[0.0],' ], +[ "VMS->splitpath('0/0',1)", $vms_efs ? ',0/0,' : ',[.0.0],' ], +[ "VMS->splitpath('0/0/0',1)", $vms_efs ? ',0/0/0,' : ',[.0.0.0],' ], +[ "VMS->splitpath('/0/0',1)", $vms_efs ? ',/0/0,' : '0:,[000000.0],' ], +[ "VMS->splitpath('/0/0/0',1)", $vms_efs ? ',/0/0/0,' : '0:,[0.0],' ], [ "VMS->catpath('','','file')", 'file' ], [ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], [ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], [ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], [ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], +[ "VMS->catpath('','d1/d2/d3','file')", + $vms_efs ? 'd1/d2/d3/file' : '[.d1.d2.d3]file' ], +[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], [ "VMS->catpath('v','w:[d1.d2.d3]','file')", 'v:[d1.d2.d3]file' ], [ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], [ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], @@ -411,15 +431,18 @@ if ($^O eq 'MacOS') { [ "VMS->splitdir('[d1.][000000.d2]')", 'd1,d2' ], [ "VMS->splitdir('[.d1.d2^.d3]')", 'd1,d2^.d3' ], -[ "VMS->catdir('')", '' ], -[ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], -[ "VMS->catdir('','-','','d3')", '[-.d3]' ], -[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], -[ "VMS->catdir('[.name]')", '[.name]' ], -[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], +[ "VMS->catdir('')", '' ], +[ "VMS->catdir('d1','d2','d3')", $vms_unix_rpt ? 'd1/d2/d3' : '[.d1.d2.d3]' ], +[ "VMS->catdir('d1','d2/','d3')", $vms_efs ? 'd1/d2/d3' : '[.d1.d2.d3]' ], +[ "VMS->catdir('','d1','d2','d3')", + $vms_unix_rpt ? '/d1/d2/d3' : + $vms_efs ? '[d1.d2.d3]' : '[.d1.d2.d3]' ], +[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], +[ "VMS->catdir('','-','','d3')", '[-.d3]' ], +[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", + $vms_unix_rpt ? 'dir.dir/d2.dir/d3.dir' : '[.dir.d2.d3]' ], +[ "VMS->catdir('[.name]')", '[.name]' ], +[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], [ "VMS->abs2rel('node::volume:[t1.t2.t3]','node::volume:[t1.t2.t3]')", '[]' ], [ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", 'node::volume:[t1.t2.t3]' ], @@ -739,7 +762,7 @@ if ($^O eq 'MacOS') { ) ; - +my $test_count = scalar @tests; plan tests => scalar @tests; diff --git a/lib/File/Spec/t/crossplatform.t b/lib/File/Spec/t/crossplatform.t index 91ea01c..b7c76fc 100644 --- a/lib/File/Spec/t/crossplatform.t +++ b/lib/File/Spec/t/crossplatform.t @@ -9,6 +9,35 @@ local $|=1; my @platforms = qw(Cygwin Epoc Mac OS2 Unix VMS Win32); my $tests_per_platform = 10; +my $vms_unix_rpt = 0; +my $vms_efs = 0; +my $vms_unix_mode = 0; +my $vms_real_root = 0; + +if ($^O eq 'VMS') { + $vms_unix_mode = 0; + 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; + } + + # Traditional VMS mode only if VMS is not in UNIX compatible mode. + $vms_unix_mode = ($vms_efs && $vms_unix_rpt); + + # If we are in UNIX mode, we may or may not have a real root. + if ($vms_unix_mode) { + my $rootdir = File::Spec->rootdir; + $vms_real_root = 1 if ($rootdir eq '/'); + } + +} + + plan tests => 1 + @platforms * $tests_per_platform; my %volumes = ( @@ -72,32 +101,66 @@ foreach my $platform (@platforms) { $file = $module->catpath($v, $module->catdir($module->rootdir, 'foo', 'bar'), 'file'); $base = $module->catpath($v, $module->catdir($module->rootdir, 'foo'), ''); $result = $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 56 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + $result =~ s/\.$//; + + # If we have a real root, then we are dealing with absolute directories + $result =~ s/\[\./\[/ if $vms_real_root; + } + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('A:/foo/bar', 'B:/foo') -> 'A:/foo/bar' $base = $module->catpath($other_v, $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $file : $module->catfile('bar', 'file'); is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('A:/foo/bar', '/foo') -> 'A:/foo/bar' $base = $module->catpath('', $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $file : $module->catfile('bar', 'file'); is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('/foo/bar/file', 'A:/foo') -> '/foo/bar' $file = $module->catpath('', $module->catdir($module->rootdir, 'foo', 'bar'), 'file'); $base = $module->catpath($v, $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $module->rel2abs($file) : $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 59 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + } + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('/foo/bar', 'B:/foo') -> '/foo/bar' $base = $module->catpath($other_v, $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $module->rel2abs($file) : $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 60 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + } + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('/foo/bar', '/foo') -> 'bar' $base = $module->catpath('', $module->catdir($module->rootdir, 'foo'), ''); $result = $module->catfile('bar', 'file'); + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; } } diff --git a/lib/File/Spec/t/tmpdir.t b/lib/File/Spec/t/tmpdir.t index fc5ec0b..6adad18 100644 --- a/lib/File/Spec/t/tmpdir.t +++ b/lib/File/Spec/t/tmpdir.t @@ -9,6 +9,12 @@ plan tests => 4; ok 1, 1, "Loaded"; +if ($^O eq 'VMS') { + # hack: + # Need to cause the %ENV to get populated or you only get the builtins at + # first, and then something else can cause the hash to get populated. + my %look_env = %ENV; +} my $num_keys = keys %ENV; File::Spec->tmpdir; ok scalar keys %ENV, $num_keys, "tmpdir() shouldn't change the contents of %ENV";