1 package File::Spec::VMS;
4 require File::Spec::Unix;
9 our @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
28 The default behavior is to allow either VMS or Unix syntax on input and to
29 return VMS syntax on output unless Unix syntax has been explicitly requested
30 via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
36 # Need to look up the feature settings. The preferred way is to use the
37 # VMS::Feature module, but that may not be available to dual life modules.
41 if (eval { local $SIG{__DIE__};
43 pop @INC if $INC[-1] eq '.';
44 require VMS::Feature; }) {
49 # Need to look up the UNIX report mode. This may become a dynamic mode
54 $unix_rpt = VMS::Feature::current("filename_unix_report");
56 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
57 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
62 =item canonpath (override)
64 Removes redundant portions of file specifications and returns results
65 in native syntax unless Unix filename reporting has been enabled.
73 return undef unless defined $path;
75 my $unix_rpt = $self->_unix_rpt;
78 my $pathify = $path =~ m|/\Z(?!\n)|;
79 $path = $self->SUPER::canonpath($path);
81 return $path if $unix_rpt;
82 $path = $pathify ? vmspath($path) : vmsify($path);
85 $path =~ s/(?<!\^)</[/; # < and > ==> [ and ]
86 $path =~ s/(?<!\^)>/]/;
87 $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
88 $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
89 $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
90 $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
91 $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
92 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
93 # That loop does the following
94 # with any amount of dashes:
99 1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/);
100 # That loop does the following
101 # with any amount (minimum 2)
108 # And then, the remaining cases
109 $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [-
110 $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g; # .foo.-. ==> .
111 $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g; # [foo.-. ==> [
112 $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g; # .foo.-] ==> ]
113 # [foo.-] ==> [000000]
114 $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g;
116 $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
117 return $unix_rpt ? unixify($path) : $path;
120 =item catdir (override)
122 Concatenates a list of file specifications, and returns the result as a
123 native directory specification unless the Unix filename reporting feature
124 has been enabled. No check is made for "impossible" cases (e.g. elements
125 other than the first being absolute filespecs).
133 my $unix_rpt = $self->_unix_rpt;
135 my @dirs = grep {defined() && length()} @_;
139 my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
140 my ($spath,$sdir) = ($path,$dir);
141 $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
144 $spath = unixify($spath) unless $spath =~ m#/#;
145 $sdir= unixify($sdir) unless $sdir =~ m#/#;
146 return $self->SUPER::catdir($spath, $sdir)
149 $rslt = vmspath( unixify($spath) . '/' . unixify($sdir));
151 # Special case for VMS absolute directory specs: these will have
152 # had device prepended during trip through Unix syntax in
153 # eliminate_macros(), since Unix syntax has no way to express
154 # "absolute from the top of this device's directory tree".
155 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
158 # Single directory. Return an empty string on null input; otherwise
159 # just return a canonical path.
161 if (not defined $dir or not length $dir) {
164 $rslt = $unix_rpt ? $dir : vmspath($dir);
167 return $self->canonpath($rslt);
170 =item catfile (override)
172 Concatenates a list of directory specifications with a filename specification
180 my $file = $self->canonpath($tfile);
181 my @files = grep {defined() && length()} @_;
183 my $unix_rpt = $self->_unix_rpt;
187 my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
190 # Something building a VMS path in pieces may try to pass a
191 # directory name in filename format, so normalize it.
192 $spath =~ s/\.dir\Z(?!\n)//i;
194 # If the spath ends with a directory delimiter and the file is bare,
195 # then just concatenate them.
196 if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
197 $rslt = "$spath$file";
199 $rslt = unixify($spath);
200 $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
201 $rslt = vmsify($rslt) unless $unix_rpt;
205 # Only passed a single file?
206 my $xfile = (defined($file) && length($file)) ? $file : '';
208 $rslt = $unix_rpt ? $xfile : vmsify($xfile);
210 return $self->canonpath($rslt) unless $unix_rpt;
212 # In Unix report mode, do not strip off redundant path information.
217 =item curdir (override)
219 Returns a string representation of the current directory: '[]' or '.'
225 return '.' if ($self->_unix_rpt);
229 =item devnull (override)
231 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
237 return '/dev/null' if ($self->_unix_rpt);
241 =item rootdir (override)
243 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
250 if ($self->_unix_rpt) {
251 # Root may exist, try it first.
253 my ($dev1, $ino1) = stat('/');
254 my ($dev2, $ino2) = stat('.');
256 # Perl falls back to '.' if it can not determine '/'
257 if (($dev1 != $dev2) || ($ino1 != $ino2)) {
260 # Fall back to UNIX format sys$disk.
263 return 'SYS$DISK:[000000]';
266 =item tmpdir (override)
268 Returns a string representation of the first writable directory
269 from the following list or '' if none are writable:
271 /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
275 If running under taint mode, and if $ENV{TMPDIR}
276 is tainted, it is not used.
282 my $tmpdir = $self->_cached_tmpdir('TMPDIR');
283 return $tmpdir if defined $tmpdir;
284 if ($self->_unix_rpt) {
285 $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
288 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
290 $self->_cache_tmpdir($tmpdir, 'TMPDIR');
293 =item updir (override)
295 Returns a string representation of the parent directory: '[-]' or '..'
301 return '..' if ($self->_unix_rpt);
305 =item case_tolerant (override)
307 VMS file specification syntax is case-tolerant.
315 =item path (override)
317 Translate logical name DCL$PATH as a searchlist, rather than trying
318 to C<split> string value of C<$ENV{'PATH'}>.
324 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
328 =item file_name_is_absolute (override)
330 Checks for VMS directory spec as well as Unix separators.
334 sub file_name_is_absolute {
335 my ($self,$file) = @_;
336 # If it's a logical name, expand it.
337 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
338 return scalar($file =~ m!^/!s ||
339 $file =~ m![<\[][^.\-\]>]! ||
340 $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
343 =item splitpath (override)
345 ($volume,$directories,$file) = File::Spec->splitpath( $path );
346 ($volume,$directories,$file) = File::Spec->splitpath( $path,
349 Passing a true value for C<$no_file> indicates that the path being
350 split only contains directory components, even on systems where you
351 can usually (when not supporting a foreign syntax) tell the difference
352 between directories and files at a glance.
357 my($self,$path, $nofile) = @_;
358 my($dev,$dir,$file) = ('','','');
359 my $vmsify_path = vmsify($path);
362 #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
363 #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
364 if( $vmsify_path =~ /(.*)\](.+)/ ){
365 $vmsify_path = $1.'.'.$2.']';
367 $vmsify_path =~ /(.+:)?(.*)/s;
368 $dir = defined $2 ? $2 : ''; # dir can be '0'
369 return ($1 || '',$dir,$file);
372 $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
373 return ($1 || '',$2 || '',$3);
377 =item splitdir (override)
379 Split a directory specification into the components.
384 my($self,$dirspec) = @_;
386 return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
388 $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ]
389 $dirspec =~ s/(?<!\^)>/]/;
390 $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
391 $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
392 $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
393 $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
394 $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
395 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
396 # That loop does the following
397 # with any amount of dashes:
402 $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
403 $dirspec =~ s/^(\[|<)\./$1/;
404 @dirs = split /(?<!\^)\./, vmspath($dirspec);
405 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
410 =item catpath (override)
412 Construct a complete filespec.
417 my($self,$dev,$dir,$file) = @_;
419 # We look for a volume in $dev, then in $dir, but not both
420 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
421 $dev = $dir_volume unless length $dev;
422 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
424 if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
425 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
426 if (length($dev) or length($dir)) {
427 $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
428 $dir = vmspath($dir);
430 $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
434 =item abs2rel (override)
436 Attempt to convert an absolute file specification to a relative specification.
442 my($path,$base) = @_;
444 $base = $self->_cwd() unless defined $base and length $base;
446 # If there is no device or directory syntax on $base, make sure it
447 # is treated as a directory.
448 $base = vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};
450 for ($path, $base) { $_ = $self->rel2abs($_) }
452 # Are we even starting $path on the same (node::)device as $base? Note that
453 # logical paths or nodename differences may be on the "same device"
454 # but the comparison that ignores device differences so as to concatenate
455 # [---] up directory specs is not even a good idea in cases where there is
456 # a logical path difference between $path and $base nodename and/or device.
457 # Hence we fall back to returning the absolute $path spec
458 # if there is a case blind device (or node) difference of any sort
459 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
460 # (this module needs to run on non VMS platforms after all).
462 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
463 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
464 return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume);
466 # Now, remove all leading components that are the same
467 my @pathchunks = $self->splitdir( $path_directories );
468 my $pathchunks = @pathchunks;
469 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
470 my @basechunks = $self->splitdir( $base_directories );
471 my $basechunks = @basechunks;
472 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
474 while ( @pathchunks &&
476 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
482 # @basechunks now contains the directories to climb out of,
483 # @pathchunks now has the directories to descend in to.
484 if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
485 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
488 $path_directories = join '.', @pathchunks;
490 $path_directories = '['.$path_directories.']';
491 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
495 =item rel2abs (override)
497 Return an absolute file specification from a relative one.
503 my ($path,$base ) = @_;
504 return undef unless defined $path;
505 if ($path =~ m/\//) {
506 $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
507 ? vmspath($path) # whether it's a directory
510 $base = vmspath($base) if defined $base && $base =~ m/\//;
512 # Clean up and split up $path
513 if ( ! $self->file_name_is_absolute( $path ) ) {
514 # Figure out the effective $base and clean it up.
515 if ( !defined( $base ) || $base eq '' ) {
518 elsif ( ! $self->file_name_is_absolute( $base ) ) {
519 $base = $self->rel2abs( $base ) ;
522 $base = $self->canonpath( $base ) ;
526 my ( $path_directories, $path_file ) =
527 ($self->splitpath( $path ))[1,2] ;
529 my ( $base_volume, $base_directories ) =
530 $self->splitpath( $base ) ;
532 $path_directories = '' if $path_directories eq '[]' ||
533 $path_directories eq '<>';
536 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
537 $path_directories =~ m{^[^.\[<]}s
539 $base_directories = "$base_directories$sep$path_directories";
540 $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
542 $path = $self->catpath( $base_volume, $base_directories, $path_file );
545 return $self->canonpath( $path ) ;
553 Copyright (c) 2004-14 by the Perl 5 Porters. All rights reserved.
555 This program is free software; you can redistribute it and/or modify
556 it under the same terms as Perl itself.
560 See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
561 implementation of these methods, not the semantics.
563 An explanation of VMS file specs can be found at
564 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.