1 package File::Spec::VMS;
5 require File::Spec::Unix;
10 our @ISA = qw(File::Spec::Unix);
17 File::Spec::VMS - methods for VMS file specs
21 require File::Spec::VMS; # Done internally by File::Spec if needed
25 See File::Spec::Unix for a documentation of the methods provided
26 there. This package overrides the implementation of these methods, not
29 The default behavior is to allow either VMS or Unix syntax on input and to
30 return VMS syntax on output unless Unix syntax has been explicitly requested
31 via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
37 # Need to look up the feature settings. The preferred way is to use the
38 # VMS::Feature module, but that may not be available to dual life modules.
42 if (eval { local $SIG{__DIE__};
44 pop @INC if $INC[-1] eq '.';
45 require VMS::Feature; }) {
50 # Need to look up the UNIX report mode. This may become a dynamic mode
55 $unix_rpt = VMS::Feature::current("filename_unix_report");
57 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
58 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
63 =item canonpath (override)
65 Removes redundant portions of file specifications and returns results
66 in native syntax unless Unix filename reporting has been enabled.
74 return undef unless defined $path;
76 my $unix_rpt = $self->_unix_rpt;
79 my $pathify = $path =~ m|/\Z(?!\n)|;
80 $path = $self->SUPER::canonpath($path);
82 return $path if $unix_rpt;
83 $path = $pathify ? vmspath($path) : vmsify($path);
86 $path =~ s/(?<!\^)</[/; # < and > ==> [ and ]
87 $path =~ s/(?<!\^)>/]/;
88 $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
89 $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
90 $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
91 $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
92 $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
93 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
94 # That loop does the following
95 # with any amount of dashes:
100 1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/);
101 # That loop does the following
102 # with any amount (minimum 2)
109 # And then, the remaining cases
110 $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [-
111 $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g; # .foo.-. ==> .
112 $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g; # [foo.-. ==> [
113 $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g; # .foo.-] ==> ]
114 # [foo.-] ==> [000000]
115 $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g;
117 $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
118 return $unix_rpt ? unixify($path) : $path;
121 =item catdir (override)
123 Concatenates a list of file specifications, and returns the result as a
124 native directory specification unless the Unix filename reporting feature
125 has been enabled. No check is made for "impossible" cases (e.g. elements
126 other than the first being absolute filespecs).
134 my $unix_rpt = $self->_unix_rpt;
136 my @dirs = grep {defined() && length()} @_;
140 my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
141 my ($spath,$sdir) = ($path,$dir);
142 $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
145 $spath = unixify($spath) unless $spath =~ m#/#;
146 $sdir= unixify($sdir) unless $sdir =~ m#/#;
147 return $self->SUPER::catdir($spath, $sdir)
150 $rslt = vmspath( unixify($spath) . '/' . unixify($sdir));
152 # Special case for VMS absolute directory specs: these will have
153 # had device prepended during trip through Unix syntax in
154 # eliminate_macros(), since Unix syntax has no way to express
155 # "absolute from the top of this device's directory tree".
156 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
159 # Single directory. Return an empty string on null input; otherwise
160 # just return a canonical path.
162 if (not defined $dir or not length $dir) {
165 $rslt = $unix_rpt ? $dir : vmspath($dir);
168 return $self->canonpath($rslt);
171 =item catfile (override)
173 Concatenates a list of directory specifications with a filename specification
181 my $file = $self->canonpath($tfile);
182 my @files = grep {defined() && length()} @_;
184 my $unix_rpt = $self->_unix_rpt;
188 my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
191 # Something building a VMS path in pieces may try to pass a
192 # directory name in filename format, so normalize it.
193 $spath =~ s/\.dir\Z(?!\n)//i;
195 # If the spath ends with a directory delimiter and the file is bare,
196 # then just concatenate them.
197 if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
198 $rslt = "$spath$file";
200 $rslt = unixify($spath);
201 $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
202 $rslt = vmsify($rslt) unless $unix_rpt;
206 # Only passed a single file?
207 my $xfile = (defined($file) && length($file)) ? $file : '';
209 $rslt = $unix_rpt ? $xfile : vmsify($xfile);
211 return $self->canonpath($rslt) unless $unix_rpt;
213 # In Unix report mode, do not strip off redundant path information.
218 =item curdir (override)
220 Returns a string representation of the current directory: '[]' or '.'
226 return '.' if ($self->_unix_rpt);
230 =item devnull (override)
232 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
238 return '/dev/null' if ($self->_unix_rpt);
242 =item rootdir (override)
244 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
251 if ($self->_unix_rpt) {
252 # Root may exist, try it first.
254 my ($dev1, $ino1) = stat('/');
255 my ($dev2, $ino2) = stat('.');
257 # Perl falls back to '.' if it can not determine '/'
258 if (($dev1 != $dev2) || ($ino1 != $ino2)) {
261 # Fall back to UNIX format sys$disk.
264 return 'SYS$DISK:[000000]';
267 =item tmpdir (override)
269 Returns a string representation of the first writable directory
270 from the following list or '' if none are writable:
272 /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
276 If running under taint mode, and if $ENV{TMPDIR}
277 is tainted, it is not used.
283 my $tmpdir = $self->_cached_tmpdir('TMPDIR');
284 return $tmpdir if defined $tmpdir;
285 if ($self->_unix_rpt) {
286 $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
289 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
291 $self->_cache_tmpdir($tmpdir, 'TMPDIR');
294 =item updir (override)
296 Returns a string representation of the parent directory: '[-]' or '..'
302 return '..' if ($self->_unix_rpt);
306 =item case_tolerant (override)
308 VMS file specification syntax is case-tolerant.
316 =item path (override)
318 Translate logical name DCL$PATH as a searchlist, rather than trying
319 to C<split> string value of C<$ENV{'PATH'}>.
325 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
329 =item file_name_is_absolute (override)
331 Checks for VMS directory spec as well as Unix separators.
335 sub file_name_is_absolute {
336 my ($self,$file) = @_;
337 # If it's a logical name, expand it.
338 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
339 return scalar($file =~ m!^/!s ||
340 $file =~ m![<\[][^.\-\]>]! ||
341 $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
344 =item splitpath (override)
346 ($volume,$directories,$file) = File::Spec->splitpath( $path );
347 ($volume,$directories,$file) = File::Spec->splitpath( $path,
350 Passing a true value for C<$no_file> indicates that the path being
351 split only contains directory components, even on systems where you
352 can usually (when not supporting a foreign syntax) tell the difference
353 between directories and files at a glance.
358 my($self,$path, $nofile) = @_;
359 my($dev,$dir,$file) = ('','','');
360 my $vmsify_path = vmsify($path);
363 #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
364 #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
365 if( $vmsify_path =~ /(.*)\](.+)/ ){
366 $vmsify_path = $1.'.'.$2.']';
368 $vmsify_path =~ /(.+:)?(.*)/s;
369 $dir = defined $2 ? $2 : ''; # dir can be '0'
370 return ($1 || '',$dir,$file);
373 $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
374 return ($1 || '',$2 || '',$3);
378 =item splitdir (override)
380 Split a directory specification into the components.
385 my($self,$dirspec) = @_;
387 return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
389 $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ]
390 $dirspec =~ s/(?<!\^)>/]/;
391 $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
392 $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
393 $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
394 $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
395 $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
396 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
397 # That loop does the following
398 # with any amount of dashes:
403 $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
404 $dirspec =~ s/^(\[|<)\./$1/;
405 @dirs = split /(?<!\^)\./, vmspath($dirspec);
406 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
411 =item catpath (override)
413 Construct a complete filespec.
418 my($self,$dev,$dir,$file) = @_;
420 # We look for a volume in $dev, then in $dir, but not both
421 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
422 $dev = $dir_volume unless length $dev;
423 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
425 if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
426 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
427 if (length($dev) or length($dir)) {
428 $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
429 $dir = vmspath($dir);
431 $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
435 =item abs2rel (override)
437 Attempt to convert an absolute file specification to a relative specification.
443 my($path,$base) = @_;
445 $base = Cwd::getcwd() unless defined $base and length $base;
447 # If there is no device or directory syntax on $base, make sure it
448 # is treated as a directory.
449 $base = vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};
451 for ($path, $base) { $_ = $self->rel2abs($_) }
453 # Are we even starting $path on the same (node::)device as $base? Note that
454 # logical paths or nodename differences may be on the "same device"
455 # but the comparison that ignores device differences so as to concatenate
456 # [---] up directory specs is not even a good idea in cases where there is
457 # a logical path difference between $path and $base nodename and/or device.
458 # Hence we fall back to returning the absolute $path spec
459 # if there is a case blind device (or node) difference of any sort
460 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
461 # (this module needs to run on non VMS platforms after all).
463 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
464 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
465 return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume);
467 # Now, remove all leading components that are the same
468 my @pathchunks = $self->splitdir( $path_directories );
469 my $pathchunks = @pathchunks;
470 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
471 my @basechunks = $self->splitdir( $base_directories );
472 my $basechunks = @basechunks;
473 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
475 while ( @pathchunks &&
477 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
483 # @basechunks now contains the directories to climb out of,
484 # @pathchunks now has the directories to descend in to.
485 if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
486 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
489 $path_directories = join '.', @pathchunks;
491 $path_directories = '['.$path_directories.']';
492 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
496 =item rel2abs (override)
498 Return an absolute file specification from a relative one.
504 my ($path,$base ) = @_;
505 return undef unless defined $path;
506 if ($path =~ m/\//) {
507 $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
508 ? vmspath($path) # whether it's a directory
511 $base = vmspath($base) if defined $base && $base =~ m/\//;
513 # Clean up and split up $path
514 if ( ! $self->file_name_is_absolute( $path ) ) {
515 # Figure out the effective $base and clean it up.
516 if ( !defined( $base ) || $base eq '' ) {
517 $base = Cwd::getcwd();
519 elsif ( ! $self->file_name_is_absolute( $base ) ) {
520 $base = $self->rel2abs( $base ) ;
523 $base = $self->canonpath( $base ) ;
527 my ( $path_directories, $path_file ) =
528 ($self->splitpath( $path ))[1,2] ;
530 my ( $base_volume, $base_directories ) =
531 $self->splitpath( $base ) ;
533 $path_directories = '' if $path_directories eq '[]' ||
534 $path_directories eq '<>';
537 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
538 $path_directories =~ m{^[^.\[<]}s
540 $base_directories = "$base_directories$sep$path_directories";
541 $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
543 $path = $self->catpath( $base_volume, $base_directories, $path_file );
546 return $self->canonpath( $path ) ;
554 Copyright (c) 2004-14 by the Perl 5 Porters. All rights reserved.
556 This program is free software; you can redistribute it and/or modify
557 it under the same terms as Perl itself.
561 See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
562 implementation of these methods, not the semantics.
564 An explanation of VMS file specs can be found at
565 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.