diff options
Diffstat (limited to 'contrib/perl5/lib/File/Spec/VMS.pm')
| -rw-r--r-- | contrib/perl5/lib/File/Spec/VMS.pm | 450 |
1 files changed, 397 insertions, 53 deletions
diff --git a/contrib/perl5/lib/File/Spec/VMS.pm b/contrib/perl5/lib/File/Spec/VMS.pm index c5269fd..a2ac8ca 100644 --- a/contrib/perl5/lib/File/Spec/VMS.pm +++ b/contrib/perl5/lib/File/Spec/VMS.pm @@ -1,19 +1,13 @@ - package File::Spec::VMS; -use Carp qw( &carp ); -use Config; -require Exporter; -use VMS::Filespec; -use File::Basename; - -use File::Spec; -use vars qw($Revision); -$Revision = '5.3901 (6-Mar-1997)'; - +use strict; +use vars qw(@ISA); +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -Exporter::import('File::Spec', '$Verbose'); +use Cwd; +use File::Basename; +use VMS::Filespec; =head1 NAME @@ -21,7 +15,7 @@ File::Spec::VMS - methods for VMS file specs =head1 SYNOPSIS - use File::Spec::VMS; # Done internally by File::Spec if needed + require File::Spec::VMS; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -29,67 +23,202 @@ See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. +=over + +=item eliminate_macros + +Expands MM[KS]/Make macros in a text string, using the contents of +identically named elements of C<%$self>, and returns the result +as a file specification in Unix syntax. + +=cut + +sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + my($npath) = unixify($path); + 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}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { ($macro = unixify($self->{$macro})) =~ s#/\z##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } + $npath; +} + +=item fixpath + +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. + +If optional second argument has a TRUE value, then the return string is +a VMS-syntax directory specification, if it is FALSE, the return string +is a VMS-syntax file specification, and if it is not specified, fixpath() +checks to see whether it matches the name of a directory in the current +default directory, and returns a directory or file specification accordingly. + +=cut + +sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {} unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ m#^\$\([^\)]+\)\z#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\z/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\z/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$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 ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } + $fixedpath; +} + +=back + =head2 Methods always loaded =over +=item canonpath (override) + +Removes redundant portions of file specifications according to VMS syntax. + +=cut + +sub canonpath { + my($self,$path) = @_; + + if ($path =~ m|/|) { # Fake Unix + my $pathify = $path =~ m|/\z|; + $path = $self->SUPER::canonpath($path); + if ($pathify) { return vmspath($path); } + else { return vmsify($path); } + } + else { + $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar + $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo + 1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [-- + $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar] + $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s + $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo + $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode + return $path; + } +} + =item catdir Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +VMS-syntax directory specification. No check is made for "impossible" +cases (e.g. elements other than the first being absolute filespecs). =cut sub catdir { - my($self,@dirs) = @_; - my($dir) = pop @dirs; + my ($self,@dirs) = @_; + my $dir = pop @dirs; @dirs = grep($_,@dirs); - my($rslt); + my $rslt; if (@dirs) { - my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); - my($spath,$sdir) = ($path,$dir); - $spath =~ s/.dir$//; $sdir =~ s/.dir$//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/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 ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + else { + if (not defined $dir or not length $dir) { $rslt = ''; } + elsif ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; } + else { $rslt = vmspath($dir); } } - print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + return $self->canonpath($rslt); } =item catfile Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +VMS-syntax file specification. =cut sub catfile { - my($self,@files) = @_; - my($file) = pop @files; + my ($self,@files) = @_; + my $file = pop @files; @files = grep($_,@files); - my($rslt); + my $rslt; if (@files) { - my($path) = (@files == 1 ? $files[0] : $self->catdir(@files)); - my($spath) = $path; - $spath =~ s/.dir$//; - if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); - } + my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + my $spath = $path; + $spath =~ s/\.dir\z//; + if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) { + $rslt = "$spath$file"; + } + else { + $rslt = $self->eliminate_macros($spath); + $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } } - else { $rslt = vmsify($file); } - print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } + return $self->canonpath($rslt); } + =item curdir (override) -Returns a string representing of the current directory. +Returns a string representation of the current directory: '[]' =cut @@ -97,19 +226,51 @@ sub curdir { return '[]'; } +=item devnull (override) + +Returns a string representation of the null device: '_NLA0:' + +=cut + +sub devnull { + return "_NLA0:"; +} + =item rootdir (override) -Returns a string representing of the root directory. +Returns a string representation of the root directory: 'SYS$DISK:[000000]' =cut sub rootdir { - return ''; + return 'SYS$DISK:[000000]'; +} + +=item tmpdir (override) + +Returns a string representation of the first writable directory +from the following list or '' if none are writable: + + sys$scratch + $ENV{TMPDIR} + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + foreach ('sys$scratch', $ENV{TMPDIR}) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; } =item updir (override) -Returns a string representing of the parent directory. +Returns a string representation of the parent directory: '[-]' =cut @@ -117,6 +278,16 @@ sub updir { return '[-]'; } +=item case_tolerant (override) + +VMS file specification syntax is case-tolerant. + +=cut + +sub case_tolerant { + return 1; +} + =item path (override) Translate logical name DCL$PATH as a searchlist, rather than trying @@ -125,9 +296,9 @@ to C<split> string value of C<$ENV{'PATH'}>. =cut sub path { - my(@dirs,$dir,$i); + my (@dirs,$dir,$i); while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } - @dirs; + return @dirs; } =item file_name_is_absolute (override) @@ -137,12 +308,185 @@ Checks for VMS directory spec as well as Unix separators. =cut sub file_name_is_absolute { - my($self,$file) = @_; + my ($self,$file) = @_; # If it's a logical name, expand it. - $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; - $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file}; + return scalar($file =~ m!^/!s || + $file =~ m![<\[][^.\-\]>]! || + $file =~ /:[^<\[]/); } -1; -__END__ +=item splitpath (override) + +Splits using VMS syntax. + +=cut + +sub splitpath { + my($self,$path) = @_; + my($dev,$dir,$file) = ('','',''); + + vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); +} + +=item splitdir (override) + +Split dirspec using VMS syntax. + +=cut + +sub splitdir { + my($self,$dirspec) = @_; + $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; + $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal + my(@dirs) = split('\.', vmspath($dirspec)); + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\z//s; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec using VMS syntax + +=cut + +sub catpath { + my($self,$dev,$dir,$file) = @_; + if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; } + if (length($dev) or length($dir)) { + $dir = "[$dir]" unless $dir =~ /[\[<\/]/; + $dir = vmspath($dir); + } + "$dev$dir$file"; +} + +=item abs2rel (override) + +Use VMS syntax when converting filespecs. + +=cut + +sub abs2rel { + my $self = shift; + + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) + if ( join( '', @_ ) =~ m{/} ) ; + + my($path,$base) = @_; + + # Note: we use '/' to glue things together here, then let canonpath() + # clean them up at the end. + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + $path_directories = $1 + if $path_directories =~ /^\[(.*)\]\z/s ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $base_directories = $1 + if $base_directories =~ /^\[(.*)\]\z/s ; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @basechunks now contains the directories to climb out of, + # @pathchunks now has the directories to descend in to. + $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ; + $path_directories =~ s{\.\z}{} ; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; +} + + +=item rel2abs (override) + +Use VMS syntax when converting filespecs. + +=cut + +sub rel2abs($;$;) { + my $self = shift ; + return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) + if ( join( '', @_ ) =~ m{/} ) ; + + my ($path,$base ) = @_; + # Clean up and split up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base ) ; + + $path_directories = '' if $path_directories eq '[]' || + $path_directories eq '<>'; + my $sep = '' ; + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\z} && + $path_directories =~ m{^[^.\[<]}s + ) ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + + $path = $self->catpath( $base_volume, $base_directories, $path_file ); + } + + return $self->canonpath( $path ) ; +} + + +=back + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +1; |
