1N/Apackage File::Spec::VMS;

1N/A

1N/Ause strict;

1N/Ause vars qw(@ISA $VERSION);

1N/Arequire File::Spec::Unix;

1N/A

1N/A$VERSION = '1.4';

1N/A

1N/A@ISA = qw(File::Spec::Unix);

1N/A

1N/Ause File::Basename;

1N/Ause VMS::Filespec;

1N/A

1N/A

1N/Asub eliminate_macros {

1N/A my($self,$path) = @_;

1N/A return '' unless $path;

1N/A $self = {} unless ref $self;

1N/A

1N/A if ($path =~ /\s/) {

1N/A return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;

1N/A }

1N/A

1N/A my($npath) = unixify($path);

1N/A my($complex) = 0;

1N/A my($head,$macro,$tail);

1N/A

1N/A # perform m##g in scalar context so it acts as an iterator

1N/A while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {

1N/A if ($self->{$2}) {

1N/A ($head,$macro,$tail) = ($1,$2,$3);

1N/A if (ref $self->{$macro}) {

1N/A if (ref $self->{$macro} eq 'ARRAY') {

1N/A $macro = join ' ', @{$self->{$macro}};

1N/A }

1N/A else {

1N/A print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),

1N/A "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";

1N/A $macro = "\cB$macro\cB";

1N/A $complex = 1;

1N/A }

1N/A }

1N/A else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }

1N/A $npath = "$head$macro$tail";

1N/A }

1N/A }

1N/A if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }

1N/A $npath;

1N/A}

1N/A

1N/A

1N/Asub fixpath {

1N/A my($self,$path,$force_path) = @_;

1N/A return '' unless $path;

1N/A $self = bless {} unless ref $self;

1N/A my($fixedpath,$prefix,$name);

1N/A

1N/A if ($path =~ /\s/) {

1N/A return join ' ',

1N/A map { $self->fixpath($_,$force_path) }

1N/A split /\s+/, $path;

1N/A }

1N/A

1N/A if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {

1N/A if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {

1N/A $fixedpath = vmspath($self->eliminate_macros($path));

1N/A }

1N/A else {

1N/A $fixedpath = vmsify($self->eliminate_macros($path));

1N/A }

1N/A }

1N/A elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {

1N/A my($vmspre) = $self->eliminate_macros("\$($prefix)");

1N/A # is it a dir or just a name?

1N/A $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';

1N/A $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;

1N/A $fixedpath = vmspath($fixedpath) if $force_path;

1N/A }

1N/A else {

1N/A $fixedpath = $path;

1N/A $fixedpath = vmspath($fixedpath) if $force_path;

1N/A }

1N/A # No hints, so we try to guess

1N/A if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {

1N/A $fixedpath = vmspath($fixedpath) if -d $fixedpath;

1N/A }

1N/A

1N/A # Trim off root dirname if it's had other dirs inserted in front of it.

1N/A $fixedpath =~ s/\.000000([\]>])/$1/;

1N/A # Special case for VMS absolute directory specs: these will have had device

1N/A # prepended during trip through Unix syntax in eliminate_macros(), since

1N/A # Unix syntax has no way to express "absolute from the top of this device's

1N/A # directory tree".

1N/A if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }

1N/A $fixedpath;

1N/A}

1N/A

1N/A

1N/Asub canonpath {

1N/A my($self,$path) = @_;

1N/A

1N/A if ($path =~ m|/|) { # Fake Unix

1N/A my $pathify = $path =~ m|/\Z(?!\n)|;

1N/A $path = $self->SUPER::canonpath($path);

1N/A if ($pathify) { return vmspath($path); }

1N/A else { return vmsify($path); }

1N/A }

1N/A else {

1N/A $path =~ s/([\[<])000000\./$1/g; # [000000.foo ==> [foo

1N/A $path =~ s/([^-]+)\.(\]\[|><)?000000([\]\>])/$1$3/g; # foo.000000] ==> foo]

1N/A $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar

1N/A 1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [--

1N/A $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar]

1N/A $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s

1N/A $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo

1N/A $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode

1N/A $path =~ s/^[\[<\]>]{2}//; # []foo ==> foo

1N/A return $path;

1N/A }

1N/A}

1N/A

1N/A

1N/Asub catdir {

1N/A my ($self,@dirs) = @_;

1N/A my $dir = pop @dirs;

1N/A @dirs = grep($_,@dirs);

1N/A my $rslt;

1N/A if (@dirs) {

1N/A my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));

1N/A my ($spath,$sdir) = ($path,$dir);

1N/A $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;

1N/A $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;

1N/A $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);

1N/A

1N/A # Special case for VMS absolute directory specs: these will have had device

1N/A # prepended during trip through Unix syntax in eliminate_macros(), since

1N/A # Unix syntax has no way to express "absolute from the top of this device's

1N/A # directory tree".

1N/A if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }

1N/A }

1N/A else {

1N/A if (not defined $dir or not length $dir) { $rslt = ''; }

1N/A elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }

1N/A else { $rslt = vmspath($dir); }

1N/A }

1N/A return $self->canonpath($rslt);

1N/A}

1N/A

1N/A

1N/Asub catfile {

1N/A my ($self,@files) = @_;

1N/A my $file = $self->canonpath(pop @files);

1N/A @files = grep($_,@files);

1N/A my $rslt;

1N/A if (@files) {

1N/A my $path = (@files == 1 ? $files[0] : $self->catdir(@files));

1N/A my $spath = $path;

1N/A $spath =~ s/\.dir\Z(?!\n)//;

1N/A if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {

1N/A $rslt = "$spath$file";

1N/A }

1N/A else {

1N/A $rslt = $self->eliminate_macros($spath);

1N/A $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));

1N/A }

1N/A }

1N/A else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }

1N/A return $self->canonpath($rslt);

1N/A}

1N/A

1N/A

1N/A

1N/Asub curdir {

1N/A return '[]';

1N/A}

1N/A

1N/A

1N/Asub devnull {

1N/A return "_NLA0:";

1N/A}

1N/A

1N/A

1N/Asub rootdir {

1N/A return 'SYS$DISK:[000000]';

1N/A}

1N/A

1N/A

1N/Amy $tmpdir;

1N/Asub tmpdir {

1N/A return $tmpdir if defined $tmpdir;

1N/A my $self = shift;

1N/A $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );

1N/A}

1N/A

1N/A

1N/Asub updir {

1N/A return '[-]';

1N/A}

1N/A

1N/A

1N/Asub case_tolerant {

1N/A return 1;

1N/A}

1N/A

1N/A

1N/Asub path {

1N/A my (@dirs,$dir,$i);

1N/A while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }

1N/A return @dirs;

1N/A}

1N/A

1N/A

1N/Asub file_name_is_absolute {

1N/A my ($self,$file) = @_;

1N/A # If it's a logical name, expand it.

1N/A $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};

1N/A return scalar($file =~ m!^/!s ||

1N/A $file =~ m![<\[][^.\-\]>]! ||

1N/A $file =~ /:[^<\[]/);

1N/A}

1N/A

1N/A

1N/Asub splitpath {

1N/A my($self,$path) = @_;

1N/A my($dev,$dir,$file) = ('','','');

1N/A

1N/A vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;

1N/A return ($1 || '',$2 || '',$3);

1N/A}

1N/A

1N/A

1N/Asub splitdir {

1N/A my($self,$dirspec) = @_;

1N/A $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g;

1N/A $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal

1N/A my(@dirs) = split('\.', vmspath($dirspec));

1N/A $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;

1N/A @dirs;

1N/A}

1N/A

1N/A

1N/A

1N/Asub catpath {

1N/A my($self,$dev,$dir,$file) = @_;

1N/A

1N/A # We look for a volume in $dev, then in $dir, but not both

1N/A my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);

1N/A $dev = $dir_volume unless length $dev;

1N/A $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;

1N/A

1N/A if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }

1N/A else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }

1N/A if (length($dev) or length($dir)) {

1N/A $dir = "[$dir]" unless $dir =~ /[\[<\/]/;

1N/A $dir = vmspath($dir);

1N/A }

1N/A "$dev$dir$file";

1N/A}

1N/A

1N/A

1N/Asub abs2rel {

1N/A my $self = shift;

1N/A return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))

1N/A if grep m{/}, @_;

1N/A

1N/A my($path,$base) = @_;

1N/A $base = $self->_cwd() unless defined $base and length $base;

1N/A

1N/A for ($path, $base) { $_ = $self->canonpath($_) }

1N/A

1N/A # Are we even starting $path on the same (node::)device as $base? Note that

1N/A # logical paths or nodename differences may be on the "same device"

1N/A # but the comparison that ignores device differences so as to concatenate

1N/A # [---] up directory specs is not even a good idea in cases where there is

1N/A # a logical path difference between $path and $base nodename and/or device.

1N/A # Hence we fall back to returning the absolute $path spec

1N/A # if there is a case blind device (or node) difference of any sort

1N/A # and we do not even try to call $parse() or consult %ENV for $trnlnm()

1N/A # (this module needs to run on non VMS platforms after all).

1N/A

1N/A my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);

1N/A my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);

1N/A return $path unless lc($path_volume) eq lc($base_volume);

1N/A

1N/A for ($path, $base) { $_ = $self->rel2abs($_) }

1N/A

1N/A # Now, remove all leading components that are the same

1N/A my @pathchunks = $self->splitdir( $path_directories );

1N/A unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';

1N/A my @basechunks = $self->splitdir( $base_directories );

1N/A unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';

1N/A

1N/A while ( @pathchunks &&

1N/A @basechunks &&

1N/A lc( $pathchunks[0] ) eq lc( $basechunks[0] )

1N/A ) {

1N/A shift @pathchunks ;

1N/A shift @basechunks ;

1N/A }

1N/A

1N/A # @basechunks now contains the directories to climb out of,

1N/A # @pathchunks now has the directories to descend in to.

1N/A $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;

1N/A return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;

1N/A}

1N/A

1N/A

1N/A

1N/Asub rel2abs {

1N/A my $self = shift ;

1N/A return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))

1N/A if ( join( '', @_ ) =~ m{/} ) ;

1N/A

1N/A my ($path,$base ) = @_;

1N/A # Clean up and split up $path

1N/A if ( ! $self->file_name_is_absolute( $path ) ) {

1N/A # Figure out the effective $base and clean it up.

1N/A if ( !defined( $base ) || $base eq '' ) {

1N/A $base = $self->_cwd;

1N/A }

1N/A elsif ( ! $self->file_name_is_absolute( $base ) ) {

1N/A $base = $self->rel2abs( $base ) ;

1N/A }

1N/A else {

1N/A $base = $self->canonpath( $base ) ;

1N/A }

1N/A

1N/A # Split up paths

1N/A my ( $path_directories, $path_file ) =

1N/A ($self->splitpath( $path ))[1,2] ;

1N/A

1N/A my ( $base_volume, $base_directories ) =

1N/A $self->splitpath( $base ) ;

1N/A

1N/A $path_directories = '' if $path_directories eq '[]' ||

1N/A $path_directories eq '<>';

1N/A my $sep = '' ;

1N/A $sep = '.'

1N/A if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&

1N/A $path_directories =~ m{^[^.\[<]}s

1N/A ) ;

1N/A $base_directories = "$base_directories$sep$path_directories";

1N/A $base_directories =~ s{\.?[\]>][\[<]\.?}{.};

1N/A

1N/A $path = $self->catpath( $base_volume, $base_directories, $path_file );

1N/A }

1N/A

1N/A return $self->canonpath( $path ) ;

1N/A}

1N/A

1N/A

1N/A

1N/A1;