summaryrefslogtreecommitdiff
path: root/lib/File/Spec/VMS.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/File/Spec/VMS.pm')
-rw-r--r--lib/File/Spec/VMS.pm201
1 files changed, 151 insertions, 50 deletions
diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm
index c5269fd10c..d13f5e68c2 100644
--- a/lib/File/Spec/VMS.pm
+++ b/lib/File/Spec/VMS.pm
@@ -1,19 +1,12 @@
-
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 File::Basename;
+use VMS::Filespec;
=head1 NAME
@@ -21,7 +14,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,6 +22,74 @@ See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
+=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+?)\)(.*)#g) {
+ 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#/$##; }
+ $npath = "$head$macro$tail";
+ }
+ }
+ if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; }
+ $npath;
+}
+
+sub fixpath {
+ my($self,$path,$force_path) = @_;
+ return '' unless $path;
+ $self = bless {} unless ref $self;
+ my($fixedpath,$prefix,$name);
+
+ if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) {
+ if ($force_path or $path =~ /(?:DIR\)|\])$/) {
+ $fixedpath = vmspath($self->eliminate_macros($path));
+ }
+ else {
+ $fixedpath = vmsify($self->eliminate_macros($path));
+ }
+ }
+ elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
+ my($vmspre) = $self->eliminate_macros("\$($prefix)");
+ # is it a dir or just a name?
+ $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? 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/;
+ $fixedpath;
+}
+
+
=head2 Methods always loaded
=over
@@ -41,23 +102,22 @@ VMS-syntax directory specification.
=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$//; $sdir =~ s/.dir$//;
+ $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
+ $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
}
- else {
- if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
- else { $rslt = vmspath($dir); }
+ else {
+ if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
+ else { $rslt = vmspath($dir); }
}
- print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
- $rslt;
+ return $rslt;
}
=item catfile
@@ -68,28 +128,29 @@ VMS-syntax directory 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$//;
+ if ($spath =~ /^[^\)\]\/:>]+\)$/ && 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;
+ return $rslt;
}
=item curdir (override)
-Returns a string representing of the current directory.
+Returns a string representation of the current directory: '[]'
=cut
@@ -97,19 +158,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
@@ -125,9 +218,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 +230,20 @@ 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\$\-]+$/ && $ENV{$file};
+ return scalar($file =~ m!^/! ||
+ $file =~ m![<\[][^.\-\]>]! ||
+ $file =~ /:[^<\[]/);
}
-1;
-__END__
+=back
+
+=head1 SEE ALSO
+L<File::Spec>
+
+=cut
+
+1;
View Lorry Controller Status