1 package File::Spec::VMS;
4 use vars qw(@ISA $VERSION);
5 require File::Spec::Unix;
8 $VERSION = eval $VERSION;
10 @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 mode of operation of these routines depend on the VMS features that
30 are controlled by the DECC features C<DECC$FILENAME_REPORT_UNIX> and
33 Perl needs to be at least at 5.10 for these feature settings to work.
34 Use of them on older perl versions on VMS will result in unpredictable
37 The default and traditional mode of these routines have been to expect VMS
38 syntax on input and to return VMS syntax on output, even when Unix syntax was
41 The default and traditional mode is also incompatible with the VMS
42 C<EFS>, Extended File system character set, and with running Perl scripts
43 under <GNV>, Gnu is not VMS, an optional Unix like runtime environment on VMS.
45 If the C<DECC$EFS_CHARSET> feature is enabled, These routines will now accept
46 either VMS or UNIX syntax. If the input parameters are clearly VMS syntax,
47 the return value will be in VMS syntax. If the input parameters are clearly
48 in Unix syntax, the output will be in Unix syntax.
50 This corresponds to the way that the VMS C library routines have always
51 handled filenames, and what a programmer who has not specifically read this
52 pod before would also expect.
54 If the C<DECC$FILENAME_REPORT_UNIX> feature is enabled, then if the output
55 syntax can not be determined from the input syntax, the output syntax will be
56 UNIX. If the feature is not enabled, VMS output will be the default.
62 # Need to look up the feature settings. The preferred way is to use the
63 # VMS::Feature module, but that may not be available to dual life modules.
67 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
72 # Need to look up the UNIX report mode. This may become a dynamic mode
77 $unix_rpt = VMS::Feature::current("filename_unix_report");
79 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
80 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
85 # Need to look up the EFS character set mode. This may become a dynamic
90 $efs = VMS::Feature::current("efs_charset");
92 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
93 $efs = $env_efs =~ /^[ET1]/i;
98 =item canonpath (override)
100 Removes redundant portions of file specifications according to the syntax
107 my($self,$path) = @_;
109 return undef unless defined $path;
111 my $efs = $self->_efs;
113 if ($path =~ m|/|) { # Fake Unix
114 my $pathify = $path =~ m|/\Z(?!\n)|;
115 $path = $self->SUPER::canonpath($path);
117 # Do not convert to VMS when EFS character sets are in use
118 return $path if $efs;
120 if ($pathify) { return vmspath($path); }
121 else { return vmsify($path); }
125 #FIXME - efs parsing has different rules. Characters in a VMS filespec
126 # are only delimiters if not preceded by '^';
128 $path =~ tr/<>/[]/; # < and > ==> [ and ]
129 $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
130 $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
131 $path =~ s/\[000000\./\[/g; # [000000. ==> [
132 $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
133 $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
134 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
135 # That loop does the following
136 # with any amount of dashes:
141 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
142 # That loop does the following
143 # with any amount (minimum 2)
150 # And then, the remaining cases
151 $path =~ s/\[\.-/[-/; # [.- ==> [-
152 $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
153 $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
154 $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
155 $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
156 $path =~ s/\[\]// unless $path eq '[]'; # [] ==>
161 =item catdir (override)
163 Concatenates a list of file specifications, and returns the result as a
164 directory specification. No check is made for "impossible"
165 cases (e.g. elements other than the first being absolute filespecs).
173 my $efs = $self->_efs;
174 my $unix_rpt = $self->_unix_rpt;
177 my @dirs = grep {defined() && length()} @_;
179 # Legacy mode removes blank entries.
180 # But that breaks existing generic perl code that
181 # uses a blank path at the beginning of the array
182 # to indicate an absolute path.
183 # So put it back if found.
193 my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
194 my ($spath,$sdir) = ($path,$dir);
197 # Extended character set in use, go into DWIM mode.
199 # Now we need to identify what the directory is in
200 # of the specification in order to merge them.
202 $path_unix = 1 if ($path =~ m#/#);
203 $path_unix = 1 if ($path =~ /^\.\.?$/);
205 $path_vms = 1 if ($path =~ m#[\[<\]]#);
206 $path_vms = 1 if ($path =~ /^--?$/);
208 $dir_unix = 1 if ($dir =~ m#/#);
209 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
211 $dir_vms = 1 if ($dir =~ m#[\[<\]]#);
212 $dir_vms = 1 if ($dir =~ /^--?$/);
215 if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) {
216 # Ambiguous, so if in $unix_rpt mode then assume UNIX.
217 $unix_mode = 1 if $unix_rpt;
219 $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt);
220 $unix_mode = 1 if ($path_unix || $dir_unix);
225 # Fix up mixed syntax imput as good as possible - GIGO
226 $path = unixify($path) if $path_vms;
227 $dir = unixify($dir) if $dir_vms;
230 # Append a path delimiter
231 $rslt .= '/' unless ($rslt =~ m#/$#);
234 return $self->SUPER::canonpath($rslt);
237 #with <> posible instead of [.
238 # Normalize the brackets
239 # Fixme - need to not switch when preceded by ^.
245 # Fix up mixed syntax imput as good as possible - GIGO
246 $path = vmsify($path) if $path_unix;
247 $dir = vmsify($dir) if $dir_unix;
249 #Possible path values: foo: [.foo] [foo] foo, and $(foo)
250 #or starting with '-', or foo.dir
251 #If path is foo, it needs to be converted to [.foo]
253 # Fix up a bare path name.
255 $path =~ s/\.dir\Z(?!\n)//i;
256 if (($path ne '') && ($path !~ /^-/)) {
257 # Non blank and not prefixed with '-', add a dot
258 $path = '[.' . $path;
260 # Just start a directory.
267 #Possible dir values: [.dir] dir and $(foo)
269 # No punctuation may have a trailing .dir
271 $dir =~ s/\.dir\Z(?!\n)//i;
274 #strip off the brackets
279 #strip off the leading dot if present.
282 # Now put the specifications together.
284 # Add a separator unless this is an absolute path
285 $path .= '.' if ($path ne '[');
286 $rslt = $path . $dir . ']';
293 # Traditional ODS-2 mode.
294 $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
296 $sdir = $self->eliminate_macros($sdir)
297 unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
298 $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
300 # Special case for VMS absolute directory specs: these will have
301 # had device prepended during trip through Unix syntax in
302 # eliminate_macros(), since Unix syntax has no way to express
303 # "absolute from the top of this device's directory tree".
304 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
307 # Single directory, just make sure it is in directory format
308 # Return an empty string on null input, and pass through macros.
310 if (not defined $dir or not length $dir) { $rslt = ''; }
311 elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) {
318 $dir_unix = 1 if ($dir =~ m#/#);
319 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
321 $dir_vms = 1 if ($dir =~ m#[\[<\]]#);
322 $dir_vms = 1 if ($dir =~ /^--?$/);
324 if ($dir_vms == $dir_unix) {
325 # Ambiguous, so if in $unix_rpt mode then assume UNIX.
326 $unix_mode = 1 if $unix_rpt;
328 $unix_mode = 1 if $dir_unix;
335 # For VMS, force it to be in directory format
336 $rslt = vmspath($dir);
340 return $self->canonpath($rslt);
343 =item catfile (override)
345 Concatenates a list of directory specifications with a filename specification
353 my $file = $self->canonpath($tfile);
354 my @files = grep {defined() && length()} @_;
356 my $efs = $self->_efs;
357 my $unix_rpt = $self->_unix_rpt;
365 # Now we need to identify format the file is in
366 # of the specification in order to merge them.
367 $file_unix = 1 if ($tfile =~ m#/#);
368 $file_unix = 1 if ($tfile =~ /^\.\.?$/);
369 $file_vms = 1 if ($tfile =~ m#[\[<\]]#);
370 $file_vms = 1 if ($tfile =~ /^--?$/);
372 # We may know for sure what the format is.
373 if (($file_unix != $file_vms)) {
374 $unix_mode = 1 if ($file_unix && $unix_rpt);
380 # concatenate the directories.
386 # We need to make sure this is in VMS mode to avoid doing
387 # both a vmsify and unixfy on the same path, as that may
388 # lose significant data.
390 my $tdir = $files[$i];
393 $tdir_vms = 1 if ($tdir =~ m#[\[<\]]#);
394 $tdir_unix = 1 if ($tdir =~ m#/#);
395 $tdir_unix = 1 if ($tdir =~ /^\.\.?$/);
399 $tdir = vmspath($tdir);
401 $tdir =~ s/\.dir\Z(?!\n)//i;
402 $tdir = '[.' . $tdir . ']';
407 $path = $self->catdir(@files);
411 # Some thing building a VMS path in pieces may try to pass a
412 # directory name in filename format, so normalize it.
413 $spath =~ s/\.dir\Z(?!\n)//i;
415 # if the spath ends with a directory delimiter and the file is bare,
416 # then just concat them.
417 # FIX-ME: In VMS format "[]<>:" are not delimiters if preceded by '^'
418 # Quite a bit of Perl does not know that yet.
419 if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
420 $rslt = "$spath$file";
424 # Now we need to identify what the directory is in
425 # of the specification in order to merge them.
427 $spath_unix = 1 if ($spath =~ m#/#);
428 $spath_unix = 1 if ($spath =~ /^\.\.?$/);
430 $spath_vms = 1 if ($spath =~ m#[\[<\]]#);
431 $spath_vms = 1 if ($spath =~ /^--?$/);
434 if (($spath_unix == $spath_vms) &&
435 ($file_unix == $file_vms)) {
436 # Ambigous, so if in $unix_rpt mode then assume UNIX.
437 $unix_mode = 1 if $unix_rpt;
440 if (($spath_unix || $file_unix) && $unix_rpt);
445 $spath = '[' . $spath . ']' if $spath =~ /^-/;
446 $rslt = vmspath($spath);
448 $rslt = '[.' . $spath . ']';
450 $file = vmsify($file) if ($file_unix);
452 $spath = unixify($spath) if ($spath_vms);
454 $file = unixify($file) if ($file_vms);
456 # Unix merge may need a directory delimitor.
457 # A null path indicates root on Unix.
458 $rslt .= '/' unless ($rslt =~ m#/$#);
465 # Traditional VMS Perl mode expects that this is done.
466 # Note for future maintainers:
467 # This is left here for compatibility with perl scripts
468 # that have come to expect this behavior, even though
469 # usually the Perl scripts ported to VMS have to be
470 # patched because of it changing Unix syntax file
473 $rslt = $self->eliminate_macros($spath);
476 $rslt = vmsify($rslt.((defined $rslt) &&
477 ($rslt ne '') ? '/' : '').unixify($file));
482 # Only passed a single file?
485 # Traditional VMS perl expects this conversion.
486 $xfile = vmsify($file) unless ($efs);
488 $rslt = (defined($file) && length($file)) ? $xfile : '';
490 return $self->canonpath($rslt) unless $unix_rpt;
492 # In Unix report mode, do not strip off redundent path information.
497 =item curdir (override)
499 Returns a string representation of the current directory: '[]' or '.'
505 return '.' if ($self->_unix_rpt);
509 =item devnull (override)
511 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
517 return '/dev/null' if ($self->_unix_rpt);
521 =item rootdir (override)
523 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
530 if ($self->_unix_rpt) {
531 # Root may exist, try it first.
533 my ($dev1, $ino1) = stat('/');
534 my ($dev2, $ino2) = stat('.');
536 # Perl falls back to '.' if it can not determine '/'
537 if (($dev1 != $dev2) || ($ino1 != $ino2)) {
540 # Fall back to UNIX format sys$disk.
543 return 'SYS$DISK:[000000]';
546 =item tmpdir (override)
548 Returns a string representation of the first writable directory
549 from the following list or '' if none are writable:
551 /tmp if C<DECC$FILENAME_REPORT_UNIX> is enabled.
555 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
556 is tainted, it is not used.
563 return $tmpdir if defined $tmpdir;
564 if ($self->_unix_rpt) {
565 $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
569 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
572 =item updir (override)
574 Returns a string representation of the parent directory: '[-]' or '..'
580 return '..' if ($self->_unix_rpt);
584 =item case_tolerant (override)
586 VMS file specification syntax is case-tolerant.
594 =item path (override)
596 Translate logical name DCL$PATH as a searchlist, rather than trying
597 to C<split> string value of C<$ENV{'PATH'}>.
603 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
607 =item file_name_is_absolute (override)
609 Checks for VMS directory spec as well as Unix separators.
613 sub file_name_is_absolute {
614 my ($self,$file) = @_;
615 # If it's a logical name, expand it.
616 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
617 return scalar($file =~ m!^/!s ||
618 $file =~ m![<\[][^.\-\]>]! ||
622 =item splitpath (override)
624 ($volume,$directories,$file) = File::Spec->splitpath( $path );
625 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
627 Passing a true value for C<$no_file> indicates that the path being
628 split only contains directory components, even on systems where you
629 can usually (when not supporting a foreign syntax) tell the difference
630 between directories and files at a glance.
635 my($self,$path, $nofile) = @_;
636 my($dev,$dir,$file) = ('','','');
637 my $efs = $self->_efs;
638 my $vmsify_path = vmsify($path);
641 $path_vms = 1 if ($path =~ m#[\[<\]]#);
642 $path_vms = 1 if ($path =~ /^--?$/);
644 return $self->SUPER::splitpath($path, $nofile);
646 $vmsify_path = $path;
650 #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
651 #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
652 if( $vmsify_path =~ /(.*)\](.+)/ ){
653 $vmsify_path = $1.'.'.$2.']';
655 $vmsify_path =~ /(.+:)?(.*)/s;
656 $dir = defined $2 ? $2 : ''; # dir can be '0'
657 return ($1 || '',$dir,$file);
660 $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
661 return ($1 || '',$2 || '',$3);
665 =item splitdir (override)
667 Split a directory specification into the components.
672 my($self,$dirspec) = @_;
674 return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
676 my $efs = $self->_efs;
679 $dir_unix = 1 if ($dirspec =~ m#/#);
680 $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
682 # Unix filespecs in EFS mode handled by Unix routines.
683 if ($efs && $dir_unix) {
684 return $self->SUPER::splitdir($dirspec);
687 # FIX ME, only split for VMS delimiters not prefixed with '^'.
689 $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
690 $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
691 $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
692 $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
693 $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
694 $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
695 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
696 # That loop does the following
697 # with any amount of dashes:
702 $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
703 $dirspec =~ s/^(\[|<)\./$1/;
704 @dirs = split /(?<!\^)\./, vmspath($dirspec);
705 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
710 =item catpath (override)
712 Construct a complete filespec.
717 my($self,$dev,$dir,$file) = @_;
719 my $efs = $self->_efs;
720 my $unix_rpt = $self->_unix_rpt;
724 $dir_unix = 1 if ($dir =~ m#/#);
725 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
727 $dir_vms = 1 if ($dir =~ m#[\[<\]]#);
728 $dir_vms = 1 if ($dir =~ /^--?$/);
730 if ($efs && (length($dev) == 0)) {
731 if ($dir_unix == $dir_vms) {
732 $unix_mode = $unix_rpt;
734 $unix_mode = $dir_unix;
738 # We look for a volume in $dev, then in $dir, but not both
739 # but only if using VMS syntax.
741 $dir = vmspath($dir) if $dir_unix;
742 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
743 $dev = $dir_volume unless length $dev;
744 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) :
747 if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
748 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
749 if (length($dev) or length($dir)) {
752 $dir .= '/' unless ($dir =~ m#/$#);
754 $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
755 $dir = "[$dir]" unless $dir =~ /^[\[<]/;
758 $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
759 $dir = vmspath($dir);
765 =item abs2rel (override)
767 Attempt to convert a file specification to a relative specification.
768 On a system with volumes, like VMS, this may not be possible.
774 my($path,$base) = @_;
776 my $efs = $self->_efs;
777 my $unix_rpt = $self->_unix_rpt;
780 return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
784 # We need to identify what the directory is in
785 # of the specification in order to process them
787 $path_unix = 1 if ($path =~ m#/#);
788 $path_unix = 1 if ($path =~ /^\.\.?$/);
790 $path_vms = 1 if ($path =~ m#[\[<\]]#);
791 $path_vms = 1 if ($path =~ /^--?$/);
794 if ($path_vms == $path_unix) {
795 $unix_mode = $unix_rpt;
797 $unix_mode = $path_unix;
804 $base_unix = 1 if ($base =~ m#/#);
805 $base_unix = 1 if ($base =~ /^\.\.?$/);
806 $base_vms = 1 if ($base =~ m#[\[<\]]#);
807 $base_vms = 1 if ($base =~ /^--?$/);
809 if ($path_vms == $path_unix) {
810 if ($base_vms == $base_unix) {
811 $unix_mode = $unix_rpt;
813 $unix_mode = $base_unix;
816 $unix_mode = 0 if $base_vms;
823 $base = unixpath($base) if $base_vms;
824 $base = unixify($path) if $path_vms;
826 # Here VMS is different, and in order to do this right
827 # we have to take the realpath for both the path and the base
828 # so that we can remove the common components.
830 if ($path =~ m#^/#) {
833 # For the shorterm, if the starting directories are
834 # common, remove them.
842 return File::Spec::Unix::abs2rel( $self, $path, $base );
845 $base = vmspath($base) if $base_unix;
846 $path = vmsify($path) if $path_unix;
850 unless (defined $base and length $base) {
851 $base = $self->_cwd();
853 $base_unix = 1 if ($base =~ m#/#);
854 $base_unix = 1 if ($base =~ /^\.\.?$/);
855 $base = vmspath($base) if $base_unix;
859 for ($path, $base) { $_ = $self->canonpath($_) }
861 # Are we even starting $path on the same (node::)device as $base? Note that
862 # logical paths or nodename differences may be on the "same device"
863 # but the comparison that ignores device differences so as to concatenate
864 # [---] up directory specs is not even a good idea in cases where there is
865 # a logical path difference between $path and $base nodename and/or device.
866 # Hence we fall back to returning the absolute $path spec
867 # if there is a case blind device (or node) difference of any sort
868 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
869 # (this module needs to run on non VMS platforms after all).
871 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
872 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
873 return $path unless lc($path_volume) eq lc($base_volume);
875 for ($path, $base) { $_ = $self->rel2abs($_) }
877 # Now, remove all leading components that are the same
878 my @pathchunks = $self->splitdir( $path_directories );
879 my $pathchunks = @pathchunks;
880 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
881 my @basechunks = $self->splitdir( $base_directories );
882 my $basechunks = @basechunks;
883 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
885 while ( @pathchunks &&
887 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
893 # @basechunks now contains the directories to climb out of,
894 # @pathchunks now has the directories to descend in to.
895 if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
896 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
899 $path_directories = join '.', @pathchunks;
901 $path_directories = '['.$path_directories.']';
902 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
906 =item rel2abs (override)
908 Return an absolute file specification from a relative one.
914 my ($path,$base ) = @_;
915 return undef unless defined $path;
917 my $efs = $self->_efs;
918 my $unix_rpt = $self->_unix_rpt;
920 # We need to identify what the directory is in
921 # of the specification in order to process them
923 $path_unix = 1 if ($path =~ m#/#);
924 $path_unix = 1 if ($path =~ /^\.\.?$/);
926 $path_vms = 1 if ($path =~ m#[\[<\]]#);
927 $path_vms = 1 if ($path =~ /^--?$/);
930 if ($path_vms == $path_unix) {
931 $unix_mode = $unix_rpt;
933 $unix_mode = $path_unix;
940 $base_unix = 1 if ($base =~ m#/#);
941 $base_unix = 1 if ($base =~ /^\.\.?$/);
942 $base_vms = 1 if ($base =~ m#[\[<\]]#);
943 $base_vms = 1 if ($base =~ /^--?$/);
945 # If we could not determine the path mode, see if we can find out
947 if ($path_vms == $path_unix) {
948 if ($base_vms != $base_unix) {
949 $unix_mode = $base_unix;
955 # Legacy behavior, convert to VMS syntax.
958 $base = vmspath($base) if $base =~ m/\//;
961 if ($path =~ m/\//) {
962 $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
963 ? vmspath($path) # whether it's a directory
968 # Clean up and split up $path
969 if ( ! $self->file_name_is_absolute( $path ) ) {
970 # Figure out the effective $base and clean it up.
971 if ( !defined( $base ) || $base eq '' ) {
974 elsif ( ! $self->file_name_is_absolute( $base ) ) {
975 $base = $self->rel2abs( $base ) ;
978 $base = $self->canonpath( $base ) ;
982 # base may have changed, so need to look up format again.
984 $base_vms = 1 if ($base =~ m#[\[<\]]#);
985 $base_vms = 1 if ($base =~ /^--?$/);
986 $base = unixpath($base) if $base_vms;
987 $base .= '/' unless ($base =~ m#/$#);
989 $base_unix = 1 if ($base =~ m#/#);
990 $base_unix = 1 if ($base =~ /^\.\.?$/);
991 $base = vmspath($base) if $base_unix;
996 my ( $path_directories, $path_file ) =
997 ($self->splitpath( $path ))[1,2] ;
999 my ( $base_volume, $base_directories ) =
1000 $self->splitpath( $base ) ;
1002 $path_directories = '' if $path_directories eq '[]' ||
1003 $path_directories eq '<>';
1007 # Merge the paths assuming that the base is absolute.
1008 $base_directories = $self->catdir('',
1012 # Legacy behavior assumes VMS only paths
1014 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
1015 $path_directories =~ m{^[^.\[<]}s
1017 $base_directories = "$base_directories$sep$path_directories";
1018 $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
1021 $path_file = '' if ($path_file eq '.') && $unix_mode;
1023 $path = $self->catpath( $base_volume, $base_directories, $path_file );
1026 return $self->canonpath( $path ) ;
1030 # eliminate_macros() and fixpath() are MakeMaker-specific methods
1031 # which are used inside catfile() and catdir(). MakeMaker has its own
1032 # copies as of 6.06_03 which are the canonical ones. We leave these
1033 # here, in peace, so that File::Spec continues to work with MakeMakers
1036 # Please consider these two methods deprecated. Do not patch them,
1037 # patch the ones in ExtUtils::MM_VMS instead.
1039 # Update: MakeMaker 6.48 is still using these routines on VMS.
1040 # so they need to be kept up to date with ExtUtils::MM_VMS.
1042 # The traditional VMS mode using ODS-2 disks depends on these routines
1043 # being here. These routines should not be called in when the
1044 # C<DECC$EFS_CHARSET> or C<DECC$FILENAME_REPORT_UNIX> modes are enabled.
1046 sub eliminate_macros {
1047 my($self,$path) = @_;
1048 return '' unless (defined $path) && ($path ne '');
1049 $self = {} unless ref $self;
1051 if ($path =~ /\s/) {
1052 return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1055 my $npath = unixify($path);
1056 # sometimes unixify will return a string with an off-by-one trailing null
1060 my($head,$macro,$tail);
1062 # perform m##g in scalar context so it acts as an iterator
1063 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
1064 if (defined $self->{$2}) {
1065 ($head,$macro,$tail) = ($1,$2,$3);
1066 if (ref $self->{$macro}) {
1067 if (ref $self->{$macro} eq 'ARRAY') {
1068 $macro = join ' ', @{$self->{$macro}};
1071 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
1072 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
1073 $macro = "\cB$macro\cB";
1077 else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1078 $npath = "$head$macro$tail";
1081 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1085 # Deprecated. See the note above for eliminate_macros().
1087 # Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
1088 # in any directory specification, in order to avoid juxtaposing two
1089 # VMS-syntax directories when MM[SK] is run. Also expands expressions which
1090 # are all macro, so that we can tell how long the expansion is, and avoid
1091 # overrunning DCL's command buffer when MM[KS] is running.
1093 # fixpath() checks to see whether the result matches the name of a
1094 # directory in the current default directory and returns a directory or
1095 # file specification accordingly. C<$is_dir> can be set to true to
1096 # force fixpath() to consider the path to be a directory or false to force
1100 my($self,$path,$force_path) = @_;
1101 return '' unless $path;
1102 $self = bless {}, $self unless ref $self;
1103 my($fixedpath,$prefix,$name);
1105 if ($path =~ /\s/) {
1107 map { $self->fixpath($_,$force_path) }
1111 if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
1112 if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
1113 $fixedpath = vmspath($self->eliminate_macros($path));
1116 $fixedpath = vmsify($self->eliminate_macros($path));
1119 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1120 my($vmspre) = $self->eliminate_macros("\$($prefix)");
1121 # is it a dir or just a name?
1122 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
1123 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
1124 $fixedpath = vmspath($fixedpath) if $force_path;
1128 $fixedpath = vmspath($fixedpath) if $force_path;
1130 # No hints, so we try to guess
1131 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
1132 $fixedpath = vmspath($fixedpath) if -d $fixedpath;
1135 # Trim off root dirname if it's had other dirs inserted in front of it.
1136 $fixedpath =~ s/\.000000([\]>])/$1/;
1137 # Special case for VMS absolute directory specs: these will have had device
1138 # prepended during trip through Unix syntax in eliminate_macros(), since
1139 # Unix syntax has no way to express "absolute from the top of this device's
1141 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1150 Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
1152 This program is free software; you can redistribute it and/or modify
1153 it under the same terms as Perl itself.
1157 See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
1158 implementation of these methods, not the semantics.
1160 An explanation of VMS file specs can be found at
1161 L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.