1 package File::Spec::VMS;
4 use vars qw(@ISA $VERSION);
5 require File::Spec::Unix;
9 @ISA = qw(File::Spec::Unix);
16 File::Spec::VMS - methods for VMS file specs
20 require File::Spec::VMS; # Done internally by File::Spec if needed
24 See File::Spec::Unix for a documentation of the methods provided
25 there. This package overrides the implementation of these methods, not
30 =item canonpath (override)
32 Removes redundant portions of file specifications according to VMS syntax.
39 if ($path =~ m|/|) { # Fake Unix
40 my $pathify = $path =~ m|/\Z(?!\n)|;
41 $path = $self->SUPER::canonpath($path);
42 if ($pathify) { return vmspath($path); }
43 else { return vmsify($path); }
46 $path =~ tr/<>/[]/; # < and > ==> [ and ]
47 $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
48 $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
49 $path =~ s/\[000000\./\[/g; # [000000. ==> [
50 $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
51 $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
52 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
53 # That loop does the following
54 # with any amount of dashes:
59 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
60 # That loop does the following
61 # with any amount (minimum 2)
68 # And then, the remaining cases
69 $path =~ s/\[\.-/[-/; # [.- ==> [-
70 $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
71 $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
72 $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
73 $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
74 $path =~ s/\[\]// unless $path eq '[]'; # [] ==>
79 =item catdir (override)
81 Concatenates a list of file specifications, and returns the result as a
82 VMS-syntax directory specification. No check is made for "impossible"
83 cases (e.g. elements other than the first being absolute filespecs).
90 my @dirs = grep {defined() && length()} @_;
94 my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
95 my ($spath,$sdir) = ($path,$dir);
96 $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
97 $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
98 $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
100 # Special case for VMS absolute directory specs: these will have had device
101 # prepended during trip through Unix syntax in eliminate_macros(), since
102 # Unix syntax has no way to express "absolute from the top of this device's
104 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
107 if (not defined $dir or not length $dir) { $rslt = ''; }
108 elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }
109 else { $rslt = vmspath($dir); }
111 return $self->canonpath($rslt);
114 =item catfile (override)
116 Concatenates a list of file specifications, and returns the result as a
117 VMS-syntax file specification.
123 my $file = $self->canonpath(pop());
124 my @files = grep {defined() && length()} @_;
128 my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
130 $spath =~ s/\.dir\Z(?!\n)//;
131 if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
132 $rslt = "$spath$file";
135 $rslt = $self->eliminate_macros($spath);
136 $rslt = vmsify($rslt.((defined $rslt) && ($rslt ne '') ? '/' : '').unixify($file));
139 else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
140 return $self->canonpath($rslt);
144 =item curdir (override)
146 Returns a string representation of the current directory: '[]'
154 =item devnull (override)
156 Returns a string representation of the null device: '_NLA0:'
164 =item rootdir (override)
166 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
171 return 'SYS$DISK:[000000]';
174 =item tmpdir (override)
176 Returns a string representation of the first writable directory
177 from the following list or '' if none are writable:
182 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
183 is tainted, it is not used.
189 return $tmpdir if defined $tmpdir;
190 $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
193 =item updir (override)
195 Returns a string representation of the parent directory: '[-]'
203 =item case_tolerant (override)
205 VMS file specification syntax is case-tolerant.
213 =item path (override)
215 Translate logical name DCL$PATH as a searchlist, rather than trying
216 to C<split> string value of C<$ENV{'PATH'}>.
222 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
226 =item file_name_is_absolute (override)
228 Checks for VMS directory spec as well as Unix separators.
232 sub file_name_is_absolute {
233 my ($self,$file) = @_;
234 # If it's a logical name, expand it.
235 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
236 return scalar($file =~ m!^/!s ||
237 $file =~ m![<\[][^.\-\]>]! ||
241 =item splitpath (override)
243 Splits using VMS syntax.
248 my($self,$path) = @_;
249 my($dev,$dir,$file) = ('','','');
251 vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
252 return ($1 || '',$2 || '',$3);
255 =item splitdir (override)
257 Split dirspec using VMS syntax.
262 my($self,$dirspec) = @_;
263 $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
264 $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
265 $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
266 $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
267 $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
268 $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
269 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
270 # That loop does the following
271 # with any amount of dashes:
276 $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
277 my(@dirs) = split('\.', vmspath($dirspec));
278 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
283 =item catpath (override)
285 Construct a complete filespec using VMS syntax
290 my($self,$dev,$dir,$file) = @_;
292 # We look for a volume in $dev, then in $dir, but not both
293 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
294 $dev = $dir_volume unless length $dev;
295 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
297 if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
298 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
299 if (length($dev) or length($dir)) {
300 $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
301 $dir = vmspath($dir);
306 =item abs2rel (override)
308 Use VMS syntax when converting filespecs.
314 return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
317 my($path,$base) = @_;
318 $base = $self->_cwd() unless defined $base and length $base;
320 for ($path, $base) { $_ = $self->canonpath($_) }
322 # Are we even starting $path on the same (node::)device as $base? Note that
323 # logical paths or nodename differences may be on the "same device"
324 # but the comparison that ignores device differences so as to concatenate
325 # [---] up directory specs is not even a good idea in cases where there is
326 # a logical path difference between $path and $base nodename and/or device.
327 # Hence we fall back to returning the absolute $path spec
328 # if there is a case blind device (or node) difference of any sort
329 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
330 # (this module needs to run on non VMS platforms after all).
332 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
333 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
334 return $path unless lc($path_volume) eq lc($base_volume);
336 for ($path, $base) { $_ = $self->rel2abs($_) }
338 # Now, remove all leading components that are the same
339 my @pathchunks = $self->splitdir( $path_directories );
340 my $pathchunks = @pathchunks;
341 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
342 my @basechunks = $self->splitdir( $base_directories );
343 my $basechunks = @basechunks;
344 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
346 while ( @pathchunks &&
348 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
354 # @basechunks now contains the directories to climb out of,
355 # @pathchunks now has the directories to descend in to.
356 if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
357 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
360 $path_directories = join '.', @pathchunks;
362 $path_directories = '['.$path_directories.']';
363 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
367 =item rel2abs (override)
369 Use VMS syntax when converting filespecs.
375 my ($path,$base ) = @_;
376 return undef unless defined $path;
377 if ($path =~ m/\//) {
378 $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
379 ? vmspath($path) # whether it's a directory
382 $base = vmspath($base) if defined $base && $base =~ m/\//;
383 # Clean up and split up $path
384 if ( ! $self->file_name_is_absolute( $path ) ) {
385 # Figure out the effective $base and clean it up.
386 if ( !defined( $base ) || $base eq '' ) {
389 elsif ( ! $self->file_name_is_absolute( $base ) ) {
390 $base = $self->rel2abs( $base ) ;
393 $base = $self->canonpath( $base ) ;
397 my ( $path_directories, $path_file ) =
398 ($self->splitpath( $path ))[1,2] ;
400 my ( $base_volume, $base_directories ) =
401 $self->splitpath( $base ) ;
403 $path_directories = '' if $path_directories eq '[]' ||
404 $path_directories eq '<>';
407 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
408 $path_directories =~ m{^[^.\[<]}s
410 $base_directories = "$base_directories$sep$path_directories";
411 $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
413 $path = $self->catpath( $base_volume, $base_directories, $path_file );
416 return $self->canonpath( $path ) ;
420 # eliminate_macros() and fixpath() are MakeMaker-specific methods
421 # which are used inside catfile() and catdir(). MakeMaker has its own
422 # copies as of 6.06_03 which are the canonical ones. We leave these
423 # here, in peace, so that File::Spec continues to work with MakeMakers
426 # Please consider these two methods deprecated. Do not patch them,
427 # patch the ones in ExtUtils::MM_VMS instead.
428 sub eliminate_macros {
429 my($self,$path) = @_;
430 return '' unless (defined $path) && ($path ne '');
431 $self = {} unless ref $self;
434 return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
437 my($npath) = unixify($path);
439 my($head,$macro,$tail);
441 # perform m##g in scalar context so it acts as an iterator
442 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
444 ($head,$macro,$tail) = ($1,$2,$3);
445 if (ref $self->{$macro}) {
446 if (ref $self->{$macro} eq 'ARRAY') {
447 $macro = join ' ', @{$self->{$macro}};
450 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
451 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
452 $macro = "\cB$macro\cB";
456 else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
457 $npath = "$head$macro$tail";
460 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
464 # Deprecated. See the note above for eliminate_macros().
466 my($self,$path,$force_path) = @_;
467 return '' unless $path;
468 $self = bless {} unless ref $self;
469 my($fixedpath,$prefix,$name);
473 map { $self->fixpath($_,$force_path) }
477 if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
478 if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
479 $fixedpath = vmspath($self->eliminate_macros($path));
482 $fixedpath = vmsify($self->eliminate_macros($path));
485 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
486 my($vmspre) = $self->eliminate_macros("\$($prefix)");
487 # is it a dir or just a name?
488 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
489 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
490 $fixedpath = vmspath($fixedpath) if $force_path;
494 $fixedpath = vmspath($fixedpath) if $force_path;
496 # No hints, so we try to guess
497 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
498 $fixedpath = vmspath($fixedpath) if -d $fixedpath;
501 # Trim off root dirname if it's had other dirs inserted in front of it.
502 $fixedpath =~ s/\.000000([\]>])/$1/;
503 # Special case for VMS absolute directory specs: these will have had device
504 # prepended during trip through Unix syntax in eliminate_macros(), since
505 # Unix syntax has no way to express "absolute from the top of this device's
507 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
516 Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
518 This program is free software; you can redistribute it and/or modify
519 it under the same terms as Perl itself.
523 See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
524 implementation of these methods, not the semantics.
526 An explanation of VMS file specs can be found at
527 L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.