This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
120575a3e0f761dfb7c9f4d3661a60d15dc18747
[perl5.git] / dist / Cwd / lib / File / Spec / VMS.pm
1 package File::Spec::VMS;
2
3 use strict;
4 use vars qw(@ISA $VERSION);
5 require File::Spec::Unix;
6
7 $VERSION = '3.34';
8 $VERSION = eval $VERSION;
9
10 @ISA = qw(File::Spec::Unix);
11
12 use File::Basename;
13 use VMS::Filespec;
14
15 =head1 NAME
16
17 File::Spec::VMS - methods for VMS file specs
18
19 =head1 SYNOPSIS
20
21  require File::Spec::VMS; # Done internally by File::Spec if needed
22
23 =head1 DESCRIPTION
24
25 See File::Spec::Unix for a documentation of the methods provided
26 there. This package overrides the implementation of these methods, not
27 the semantics.
28
29 The default behavior is to allow either VMS or Unix syntax on input and to 
30 return VMS syntax on output, even when Unix syntax was given on input.
31
32 When used with a Perl of version 5.10 or greater and a CRTL possessing the
33 relevant capabilities, override behavior depends on the CRTL features
34 C<DECC$FILENAME_UNIX_REPORT> and C<DECC$EFS_CHARSET>.  When the
35 C<DECC$EFS_CHARSET> feature is enabled and the input parameters are clearly
36 in Unix syntax, the output will be in Unix syntax.  If
37 C<DECC$FILENAME_UNIX_REPORT> is enabled and the output syntax cannot be
38 determined from the input syntax, the output will be in Unix syntax.
39
40 =over 4
41
42 =cut
43
44 # Need to look up the feature settings.  The preferred way is to use the
45 # VMS::Feature module, but that may not be available to dual life modules.
46
47 my $use_feature;
48 BEGIN {
49     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
50         $use_feature = 1;
51     }
52 }
53
54 # Need to look up the UNIX report mode.  This may become a dynamic mode
55 # in the future.
56 sub _unix_rpt {
57     my $unix_rpt;
58     if ($use_feature) {
59         $unix_rpt = VMS::Feature::current("filename_unix_report");
60     } else {
61         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
62         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
63     }
64     return $unix_rpt;
65 }
66
67 # Need to look up the EFS character set mode.  This may become a dynamic
68 # mode in the future.
69 sub _efs {
70     my $efs;
71     if ($use_feature) {
72         $efs = VMS::Feature::current("efs_charset");
73     } else {
74         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
75         $efs = $env_efs =~ /^[ET1]/i; 
76     }
77     return $efs;
78 }
79
80 =item canonpath (override)
81
82 Removes redundant portions of file specifications according to the syntax
83 detected.
84
85 =cut
86
87
88 sub canonpath {
89     my($self,$path) = @_;
90
91     return undef unless defined $path;
92
93     my $efs = $self->_efs;
94
95     if ($path =~ m|/|) { # Fake Unix
96       my $pathify = $path =~ m|/\Z(?!\n)|;
97       $path = $self->SUPER::canonpath($path);
98
99       # Do not convert to VMS when EFS character sets are in use
100       return $path if $efs;
101
102       if ($pathify) { return vmspath($path); }
103       else          { return vmsify($path);  }
104     }
105     else {
106
107 #FIXME - efs parsing has different rules.  Characters in a VMS filespec
108 #        are only delimiters if not preceded by '^';
109
110         $path =~ tr/<>/[]/;                     # < and >       ==> [ and ]
111         $path =~ s/\]\[\./\.\]\[/g;             # ][.           ==> .][
112         $path =~ s/\[000000\.\]\[/\[/g;         # [000000.][    ==> [
113         $path =~ s/\[000000\./\[/g;             # [000000.      ==> [
114         $path =~ s/\.\]\[000000\]/\]/g;         # .][000000]    ==> ]
115         $path =~ s/\.\]\[/\./g;                 # foo.][bar     ==> foo.bar
116         1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
117                                                 # That loop does the following
118                                                 # with any amount of dashes:
119                                                 # .-.-.         ==> .--.
120                                                 # [-.-.         ==> [--.
121                                                 # .-.-]         ==> .--]
122                                                 # [-.-]         ==> [--]
123         1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
124                                                 # That loop does the following
125                                                 # with any amount (minimum 2)
126                                                 # of dashes:
127                                                 # .foo.--.      ==> .-.
128                                                 # .foo.--]      ==> .-]
129                                                 # [foo.--.      ==> [-.
130                                                 # [foo.--]      ==> [-]
131                                                 #
132                                                 # And then, the remaining cases
133         $path =~ s/\[\.-/[-/;                   # [.-           ==> [-
134         $path =~ s/\.[^\]\.]+\.-\./\./g;        # .foo.-.       ==> .
135         $path =~ s/\[[^\]\.]+\.-\./\[/g;        # [foo.-.       ==> [
136         $path =~ s/\.[^\]\.]+\.-\]/\]/g;        # .foo.-]       ==> ]
137         $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-]       ==> [000000]
138         $path =~ s/\[\]// unless $path eq '[]'; # []            ==>
139         return $path;
140     }
141 }
142
143 =item catdir (override)
144
145 Concatenates a list of file specifications, and returns the result as a
146 directory specification.  No check is made for "impossible"
147 cases (e.g. elements other than the first being absolute filespecs).
148
149 =cut
150
151 sub catdir {
152     my $self = shift;
153     my $dir = pop;
154
155     my $efs = $self->_efs;
156     my $unix_rpt = $self->_unix_rpt;
157
158
159     my @dirs = grep {defined() && length()} @_;
160     if ($efs) {
161         # Legacy mode removes blank entries.
162         # But that breaks existing generic perl code that
163         # uses a blank path at the beginning of the array
164         # to indicate an absolute path.
165         # So put it back if found.
166         if (@_) {
167             if ($_[0] eq '') {
168                 unshift @dirs, '';
169             }
170         }
171     }
172
173     my $rslt;
174     if (@dirs) {
175         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
176         my ($spath,$sdir) = ($path,$dir);
177
178         if ($efs) {
179             # Extended character set in use, go into DWIM mode.
180
181             # Now we need to identify what the directory is in
182             # of the specification in order to merge them.
183             my $path_unix = 0;
184             $path_unix = 1 if ($path =~ m#/#);
185             $path_unix = 1 if ($path =~ /^\.\.?$/);
186             my $path_vms = 0;
187             $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
188             $path_vms = 1 if ($path =~ /^--?$/);
189             my $dir_unix = 0;
190             $dir_unix = 1 if ($dir =~ m#/#);
191             $dir_unix = 1 if ($dir =~ /^\.\.?$/);
192             my $dir_vms = 0;
193             $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
194             $dir_vms = 1 if ($dir =~ /^--?$/);
195
196             my $unix_mode = 0;
197             if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) {
198                 # Ambiguous, so if in $unix_rpt mode then assume UNIX.
199                 $unix_mode = 1 if $unix_rpt;
200             } else {
201                 $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt);
202                 $unix_mode = 1 if ($path_unix || $dir_unix);
203             }
204
205             if ($unix_mode) {
206
207                 # Fix up mixed syntax input as good as possible - GIGO
208                 $path = unixify($path) if $path_vms;
209                 $dir = unixify($dir) if $dir_vms;
210
211                 $rslt = $path;
212                 # Append a path delimiter
213                 $rslt .= '/' unless ($rslt =~ m#/$#);
214
215                 $rslt .= $dir;
216                 return $self->SUPER::canonpath($rslt);
217             } else {
218
219                 #with <> possible instead of [.
220                 # Normalize the brackets
221                 # Fixme - need to not switch when preceded by ^.
222                 $path =~ s/</\[/g;
223                 $path =~ s/>/\]/g;
224                 $dir =~ s/</\[/g;
225                 $dir =~ s/>/\]/g;
226
227                 # Fix up mixed syntax input as good as possible - GIGO
228                 $path = vmsify($path) if $path_unix;
229                 $dir = vmsify($dir) if $dir_unix;
230
231                 #Possible path values: foo: [.foo] [foo] foo, and $(foo)
232                 #or starting with '-', or foo.dir
233                 #If path is foo, it needs to be converted to [.foo]
234
235                 # Fix up a bare path name.
236                 unless ($path_vms) {
237                     $path =~ s/\.dir\Z(?!\n)//i;
238                     if (($path ne '') && ($path !~ /^-/)) {
239                         # Non blank and not prefixed with '-', add a dot
240                         $path = '[.' . $path;
241                     } else {
242                         # Just start a directory.
243                         $path = '[' . $path;
244                     }
245                 } else {
246                     $path =~ s/\]$//;
247                 }
248
249                 #Possible dir values: [.dir] dir and $(foo)
250
251                 # No punctuation may have a trailing .dir
252                 unless ($dir_vms) {
253                     $dir =~ s/\.dir\Z(?!\n)//i;
254                 } else {
255
256                     #strip off the brackets
257                     $dir =~ s/^\[//;
258                     $dir =~ s/\]$//;
259                 }
260
261                 #strip off the leading dot if present.
262                 $dir =~ s/^\.//;
263
264                 # Now put the specifications together.
265                 if ($dir ne '') {
266                     # Add a separator unless this is an absolute path
267                     $path .= '.' if ($path ne '[');
268                     $rslt = $path . $dir . ']';
269                 } else {
270                     $rslt = $path . ']';
271                 }
272             }
273
274         } else {
275             # Traditional ODS-2 mode.
276             $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 
277
278             $sdir = $self->eliminate_macros($sdir)
279                 unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
280             $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
281
282             # Special case for VMS absolute directory specs: these will have
283             # had device prepended during trip through Unix syntax in
284             # eliminate_macros(), since Unix syntax has no way to express
285             # "absolute from the top of this device's directory tree".
286             if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
287         } 
288     } else {
289         # Single directory, just make sure it is in directory format
290         # Return an empty string on null input, and pass through macros.
291
292         if    (not defined $dir or not length $dir) { $rslt = ''; }
293         elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { 
294             $rslt = $dir;
295         } else {
296             my $unix_mode = 0;
297
298             if ($efs) {
299                 my $dir_unix = 0;
300                 $dir_unix = 1 if ($dir =~ m#/#);
301                 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
302                 my $dir_vms = 0;
303                 $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
304                 $dir_vms = 1 if ($dir =~ /^--?$/);
305
306                 if ($dir_vms == $dir_unix) {
307                     # Ambiguous, so if in $unix_rpt mode then assume UNIX.
308                     $unix_mode = 1 if $unix_rpt;
309                 } else {
310                     $unix_mode = 1 if $dir_unix;
311                 }
312             }
313
314             if ($unix_mode) {
315                 return $dir;
316             } else {
317                 # For VMS, force it to be in directory format
318                 $rslt = vmspath($dir);
319             }
320         }
321     }
322     return $self->canonpath($rslt);
323 }
324
325 =item catfile (override)
326
327 Concatenates a list of directory specifications with a filename specification
328 to build a path.
329
330 =cut
331
332 sub catfile {
333     my $self = shift;
334     my $tfile = pop();
335     my $file = $self->canonpath($tfile);
336     my @files = grep {defined() && length()} @_;
337
338     my $efs = $self->_efs;
339     my $unix_rpt = $self->_unix_rpt;
340
341     # Assume VMS mode
342     my $unix_mode = 0;
343     my $file_unix = 0;
344     my $file_vms = 0;
345     if ($efs) {
346
347         # Now we need to identify format the file is in
348         # of the specification in order to merge them.
349         $file_unix = 1 if ($tfile =~ m#/#);
350         $file_unix = 1 if ($tfile =~ /^\.\.?$/);
351         $file_vms = 1 if ($tfile =~ m#(?<!\^)[\[<\]:]#);
352         $file_vms = 1 if ($tfile =~ /^--?$/);
353
354         # We may know for sure what the format is.
355         if (($file_unix != $file_vms)) {
356             $unix_mode = 1 if ($file_unix && $unix_rpt);
357         }
358     }
359
360     my $rslt;
361     if (@files) {
362         # concatenate the directories.
363         my $path;
364         if (@files == 1) {
365            $path = $files[0];
366         } else {
367             if ($file_vms) {
368                 # We need to make sure this is in VMS mode to avoid doing
369                 # both a vmsify and unixfy on the same path, as that may
370                 # lose significant data.
371                 my $i = @files - 1;
372                 my $tdir = $files[$i];
373                 my $tdir_vms = 0;
374                 my $tdir_unix = 0;
375                 $tdir_vms = 1 if ($tdir =~ m#(?<!\^)[\[<\]:]#);
376                 $tdir_unix = 1 if ($tdir =~ m#/#);
377                 $tdir_unix = 1 if ($tdir =~ /^\.\.?$/);
378
379                 if (!$tdir_vms) {
380                     if ($tdir_unix) { 
381                         $tdir = vmspath($tdir);
382                     } else {
383                         $tdir =~ s/\.dir\Z(?!\n)//i;
384                         $tdir = '[.' . $tdir . ']';
385                     }
386                     $files[$i] = $tdir;
387                 }
388             }
389             $path = $self->catdir(@files);
390         }
391         my $spath = $path;
392
393         # Some thing building a VMS path in pieces may try to pass a
394         # directory name in filename format, so normalize it.
395         $spath =~ s/\.dir\Z(?!\n)//i;
396
397         # if the spath ends with a directory delimiter and the file is bare,
398         # then just concat them.
399         if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
400             $rslt = "$spath$file";
401         } else {
402             if ($efs) {
403
404                 # Now we need to identify what the directory is in
405                 # of the specification in order to merge them.
406                 my $spath_unix = 0;
407                 $spath_unix = 1 if ($spath =~ m#/#);
408                 $spath_unix = 1 if ($spath =~ /^\.\.?$/);
409                 my $spath_vms = 0;
410                 $spath_vms = 1 if ($spath =~ m#(?<!\^)[\[<\]:]#);
411                 $spath_vms = 1 if ($spath =~ /^--?$/);
412
413                 # Assume VMS mode
414                 if (($spath_unix == $spath_vms) &&
415                     ($file_unix == $file_vms)) {
416                      # Ambiguous, so if in $unix_rpt mode then assume UNIX.
417                      $unix_mode = 1 if $unix_rpt;
418                 } else {
419                      $unix_mode = 1
420                          if (($spath_unix || $file_unix) && $unix_rpt);
421                 }
422
423                 if (!$unix_mode) {
424                     if ($spath_vms) {
425                         $spath = '[' . $spath . ']' if $spath =~ /^-/;
426                         $rslt = vmspath($spath);
427                     } else {
428                         $rslt = '[.' . $spath . ']';
429                     }
430                     $file = vmsify($file) if ($file_unix);
431                 } else {
432                     $spath = unixify($spath) if ($spath_vms);
433                     $rslt = $spath;
434                     $file = unixify($file) if ($file_vms);
435
436                     # Unix merge may need a directory delimiter.
437                     # A null path indicates root on Unix.
438                     $rslt .= '/' unless ($rslt =~ m#/$#);
439                 }
440
441                 $rslt .= $file;
442                 $rslt =~ s/\]\[//;
443
444             } else {
445                 # Traditional VMS Perl mode expects that this is done.
446                 # Note for future maintainers:
447                 # This is left here for compatibility with perl scripts
448                 # that have come to expect this behavior, even though
449                 # usually the Perl scripts ported to VMS have to be
450                 # patched because of it changing Unix syntax file
451                 # to VMS format.
452
453                 $rslt = $self->eliminate_macros($spath);
454
455
456                 $rslt = vmsify($rslt.((defined $rslt) &&
457                     ($rslt ne '') ? '/' : '').unixify($file));
458             }
459         }
460     }
461     else {
462         # Only passed a single file?
463         my $xfile = $file;
464
465         # Traditional VMS perl expects this conversion.
466         $xfile = vmsify($file) unless ($efs);
467
468         $rslt = (defined($file) && length($file)) ? $xfile : '';
469     }
470     return $self->canonpath($rslt) unless $unix_rpt;
471
472     # In Unix report mode, do not strip off redundant path information.
473     return $rslt;
474 }
475
476
477 =item curdir (override)
478
479 Returns a string representation of the current directory: '[]' or '.'
480
481 =cut
482
483 sub curdir {
484     my $self = shift @_;
485     return '.' if ($self->_unix_rpt);
486     return '[]';
487 }
488
489 =item devnull (override)
490
491 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
492
493 =cut
494
495 sub devnull {
496     my $self = shift @_;
497     return '/dev/null' if ($self->_unix_rpt);
498     return "_NLA0:";
499 }
500
501 =item rootdir (override)
502
503 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
504 or '/'
505
506 =cut
507
508 sub rootdir {
509     my $self = shift @_;
510     if ($self->_unix_rpt) {
511        # Root may exist, try it first.
512        my $try = '/';
513        my ($dev1, $ino1) = stat('/');
514        my ($dev2, $ino2) = stat('.');
515
516        # Perl falls back to '.' if it can not determine '/'
517        if (($dev1 != $dev2) || ($ino1 != $ino2)) {
518            return $try;
519        }
520        # Fall back to UNIX format sys$disk.
521        return '/sys$disk/';
522     }
523     return 'SYS$DISK:[000000]';
524 }
525
526 =item tmpdir (override)
527
528 Returns a string representation of the first writable directory
529 from the following list or '' if none are writable:
530
531     /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
532     sys$scratch:
533     $ENV{TMPDIR}
534
535 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
536 is tainted, it is not used.
537
538 =cut
539
540 my $tmpdir;
541 sub tmpdir {
542     my $self = shift @_;
543     return $tmpdir if defined $tmpdir;
544     if ($self->_unix_rpt) {
545         $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
546         return $tmpdir;
547     }
548
549     $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
550 }
551
552 =item updir (override)
553
554 Returns a string representation of the parent directory: '[-]' or '..'
555
556 =cut
557
558 sub updir {
559     my $self = shift @_;
560     return '..' if ($self->_unix_rpt);
561     return '[-]';
562 }
563
564 =item case_tolerant (override)
565
566 VMS file specification syntax is case-tolerant.
567
568 =cut
569
570 sub case_tolerant {
571     return 1;
572 }
573
574 =item path (override)
575
576 Translate logical name DCL$PATH as a searchlist, rather than trying
577 to C<split> string value of C<$ENV{'PATH'}>.
578
579 =cut
580
581 sub path {
582     my (@dirs,$dir,$i);
583     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
584     return @dirs;
585 }
586
587 =item file_name_is_absolute (override)
588
589 Checks for VMS directory spec as well as Unix separators.
590
591 =cut
592
593 sub file_name_is_absolute {
594     my ($self,$file) = @_;
595     # If it's a logical name, expand it.
596     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
597     return scalar($file =~ m!^/!s             ||
598                   $file =~ m![<\[][^.\-\]>]!  ||
599                   $file =~ /:[^<\[]/);
600 }
601
602 =item splitpath (override)
603
604     ($volume,$directories,$file) = File::Spec->splitpath( $path );
605     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
606
607 Passing a true value for C<$no_file> indicates that the path being
608 split only contains directory components, even on systems where you
609 can usually (when not supporting a foreign syntax) tell the difference
610 between directories and files at a glance.
611
612 =cut
613
614 sub splitpath {
615     my($self,$path, $nofile) = @_;
616     my($dev,$dir,$file)      = ('','','');
617     my $efs = $self->_efs;
618     my $vmsify_path = vmsify($path);
619     if ($efs) {
620         my $path_vms = 0;
621         $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
622         $path_vms = 1 if ($path =~ /^--?$/);
623         if (!$path_vms) {
624             return $self->SUPER::splitpath($path, $nofile);
625         }
626         $vmsify_path = $path;
627     }
628
629     if ( $nofile ) {
630         #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
631         #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
632         if( $vmsify_path =~ /(.*)\](.+)/ ){
633             $vmsify_path = $1.'.'.$2.']';
634         }
635         $vmsify_path =~ /(.+:)?(.*)/s;
636         $dir = defined $2 ? $2 : ''; # dir can be '0'
637         return ($1 || '',$dir,$file);
638     }
639     else {
640         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
641         return ($1 || '',$2 || '',$3);
642     }
643 }
644
645 =item splitdir (override)
646
647 Split a directory specification into the components.
648
649 =cut
650
651 sub splitdir {
652     my($self,$dirspec) = @_;
653     my @dirs = ();
654     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
655
656     my $efs = $self->_efs;
657
658     my $dir_unix = 0;
659     $dir_unix = 1 if ($dirspec =~ m#/#);
660     $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
661
662     # Unix filespecs in EFS mode handled by Unix routines.
663     if ($efs && $dir_unix) {
664         return $self->SUPER::splitdir($dirspec);
665     }
666
667     # FIX ME, only split for VMS delimiters not prefixed with '^'.
668
669     $dirspec =~ tr/<>/[]/;                      # < and >       ==> [ and ]
670     $dirspec =~ s/\]\[\./\.\]\[/g;              # ][.           ==> .][
671     $dirspec =~ s/\[000000\.\]\[/\[/g;          # [000000.][    ==> [
672     $dirspec =~ s/\[000000\./\[/g;              # [000000.      ==> [
673     $dirspec =~ s/\.\]\[000000\]/\]/g;          # .][000000]    ==> ]
674     $dirspec =~ s/\.\]\[/\./g;                  # foo.][bar     ==> foo.bar
675     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
676                                                 # That loop does the following
677                                                 # with any amount of dashes:
678                                                 # .--.          ==> .-.-.
679                                                 # [--.          ==> [-.-.
680                                                 # .--]          ==> .-.-]
681                                                 # [--]          ==> [-.-]
682     $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
683     $dirspec =~ s/^(\[|<)\./$1/;
684     @dirs = split /(?<!\^)\./, vmspath($dirspec);
685     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
686     @dirs;
687 }
688
689
690 =item catpath (override)
691
692 Construct a complete filespec.
693
694 =cut
695
696 sub catpath {
697     my($self,$dev,$dir,$file) = @_;
698     
699     my $efs = $self->_efs;
700     my $unix_rpt = $self->_unix_rpt;
701
702     my $unix_mode = 0;
703     my $dir_unix = 0;
704     $dir_unix = 1 if ($dir =~ m#/#);
705     $dir_unix = 1 if ($dir =~ /^\.\.?$/);
706     my $dir_vms = 0;
707     $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
708     $dir_vms = 1 if ($dir =~ /^--?$/);
709
710     if ($efs && (length($dev) == 0)) {
711         if ($dir_unix == $dir_vms) {
712             $unix_mode = $unix_rpt;
713         } else {
714             $unix_mode = $dir_unix;
715         }
716     } 
717
718     # We look for a volume in $dev, then in $dir, but not both
719     # but only if using VMS syntax.
720     if (!$unix_mode) {
721         $dir = vmspath($dir) if $dir_unix;
722         my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
723         $dev = $dir_volume unless length $dev;
724         $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) :
725                                   $dir_dir;
726     }
727     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
728     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
729     if (length($dev) or length($dir)) {
730       if ($efs) {
731           if ($unix_mode) {
732               $dir .= '/' unless ($dir =~ m#/$#);
733           } else {
734               $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
735               $dir = "[$dir]" unless $dir =~ /^[\[<]/;
736           }
737       } else {
738           $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
739           $dir = vmspath($dir);
740       }
741     }
742     $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
743     "$dev$dir$file";
744 }
745
746 =item abs2rel (override)
747
748 Attempt to convert a file specification to a relative specification.
749 On a system with volumes, like VMS, this may not be possible.
750
751 =cut
752
753 sub abs2rel {
754     my $self = shift;
755     my($path,$base) = @_;
756
757     my $efs = $self->_efs;
758     my $unix_rpt = $self->_unix_rpt;
759
760     # We need to identify what the directory is in
761     # of the specification in order to process them
762     my $path_unix = 0;
763     $path_unix = 1 if ($path =~ m#/#);
764     $path_unix = 1 if ($path =~ /^\.\.?$/);
765     my $path_vms = 0;
766     $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
767     $path_vms = 1 if ($path =~ /^--?$/);
768
769     my $unix_mode = 0;
770     if ($path_vms == $path_unix) {
771         $unix_mode = $unix_rpt;
772     } else {
773         $unix_mode = $path_unix;
774     }
775
776     my $base_unix = 0;
777     my $base_vms = 0;
778
779     if (defined $base) {
780         $base_unix = 1 if ($base =~ m#/#);
781         $base_unix = 1 if ($base =~ /^\.\.?$/);
782         $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
783         $base_vms = 1 if ($base =~ /^--?$/);
784
785         if ($path_vms == $path_unix) {
786             if ($base_vms == $base_unix) {
787                 $unix_mode = $unix_rpt;
788             } else {
789                 $unix_mode = $base_unix;
790             }
791         } else {
792             $unix_mode = 0 if $base_vms;
793         }
794     }
795
796     if ($efs) {
797         if ($unix_mode) {
798             # We are UNIX mode.
799             $base = unixpath($base) if $base_vms;
800             $base = unixify($path) if $path_vms;
801
802             # Here VMS is different, and in order to do this right
803             # we have to take the realpath for both the path and the base
804             # so that we can remove the common components.
805
806             if ($path =~ m#^/#) {
807                 if (defined $base) {
808
809                     # For the shorterm, if the starting directories are
810                     # common, remove them.
811                     my $bq = qq($base);
812                     $bq =~ s/\$/\\\$/;
813                     $path =~ s/^$bq//i;
814                 }
815                 return $path;
816             }
817
818             return File::Spec::Unix::abs2rel( $self, $path, $base );
819
820         } else {
821             $base = vmspath($base) if $base_unix;
822             $path = vmsify($path) if $path_unix;
823         }
824     }
825
826     unless (defined $base and length $base) {
827         $base = $self->_cwd();
828         if ($efs) {
829             $base_unix = 1 if ($base =~ m#/#);
830             $base_unix = 1 if ($base =~ /^\.\.?$/);
831             $base = vmspath($base) if $base_unix;
832         }
833     }
834
835     for ($path, $base) { $_ = $self->canonpath($_) }
836
837     # Are we even starting $path on the same (node::)device as $base?  Note that
838     # logical paths or nodename differences may be on the "same device" 
839     # but the comparison that ignores device differences so as to concatenate 
840     # [---] up directory specs is not even a good idea in cases where there is 
841     # a logical path difference between $path and $base nodename and/or device.
842     # Hence we fall back to returning the absolute $path spec
843     # if there is a case blind device (or node) difference of any sort
844     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
845     # (this module needs to run on non VMS platforms after all).
846     
847     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
848     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
849     return $path unless lc($path_volume) eq lc($base_volume);
850
851     for ($path, $base) { $_ = $self->rel2abs($_) }
852
853     # Now, remove all leading components that are the same
854     my @pathchunks = $self->splitdir( $path_directories );
855     my $pathchunks = @pathchunks;
856     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
857     my @basechunks = $self->splitdir( $base_directories );
858     my $basechunks = @basechunks;
859     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
860
861     while ( @pathchunks && 
862             @basechunks && 
863             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
864           ) {
865         shift @pathchunks ;
866         shift @basechunks ;
867     }
868
869     # @basechunks now contains the directories to climb out of,
870     # @pathchunks now has the directories to descend in to.
871     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
872       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
873     }
874     else {
875       $path_directories = join '.', @pathchunks;
876     }
877     $path_directories = '['.$path_directories.']';
878     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
879 }
880
881
882 =item rel2abs (override)
883
884 Return an absolute file specification from a relative one.
885
886 =cut
887
888 sub rel2abs {
889     my $self = shift ;
890     my ($path,$base ) = @_;
891     return undef unless defined $path;
892
893     my $efs = $self->_efs;
894     my $unix_rpt = $self->_unix_rpt;
895
896     # We need to identify what the directory is in
897     # of the specification in order to process them
898     my $path_unix = 0;
899     $path_unix = 1 if ($path =~ m#/#);
900     $path_unix = 1 if ($path =~ /^\.\.?$/);
901     my $path_vms = 0;
902     $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
903     $path_vms = 1 if ($path =~ /^--?$/);
904
905     my $unix_mode = 0;
906     if ($path_vms == $path_unix) {
907         $unix_mode = $unix_rpt;
908     } else {
909         $unix_mode = $path_unix;
910     }
911
912     my $base_unix = 0;
913     my $base_vms = 0;
914
915     if (defined $base) {
916         $base_unix = 1 if ($base =~ m#/#);
917         $base_unix = 1 if ($base =~ /^\.\.?$/);
918         $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
919         $base_vms = 1 if ($base =~ /^--?$/);
920
921         # If we could not determine the path mode, see if we can find out
922         # from the base.
923         if ($path_vms == $path_unix) {
924             if ($base_vms != $base_unix) {
925                 $unix_mode = $base_unix;
926             }
927         }
928     }
929
930     if (!$efs) {
931         # Legacy behavior, convert to VMS syntax.
932         $unix_mode = 0;
933         if (defined $base) {
934             $base = vmspath($base) if $base =~ m/\//;
935         }
936
937         if ($path =~ m/\//) {
938             $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
939                        ? vmspath($path)             # whether it's a directory
940                        : vmsify($path) );
941         }
942    }
943
944     # Clean up and split up $path
945     if ( ! $self->file_name_is_absolute( $path ) ) {
946         # Figure out the effective $base and clean it up.
947         if ( !defined( $base ) || $base eq '' ) {
948             $base = $self->_cwd;
949         }
950         elsif ( ! $self->file_name_is_absolute( $base ) ) {
951             $base = $self->rel2abs( $base ) ;
952         }
953         else {
954             $base = $self->canonpath( $base ) ;
955         }
956
957         if ($efs) {
958             # base may have changed, so need to look up format again.
959             if ($unix_mode) {
960                 $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
961                 $base_vms = 1 if ($base =~ /^--?$/);
962                 $base = unixpath($base) if $base_vms;
963                 $base .= '/' unless ($base =~ m#/$#);
964             } else {
965                 $base_unix = 1 if ($base =~ m#/#);
966                 $base_unix = 1 if ($base =~ /^\.\.?$/);
967                 $base = vmspath($base) if $base_unix; 
968             }
969         }
970
971         # Split up paths
972         my ( $path_directories, $path_file ) =
973             ($self->splitpath( $path ))[1,2] ;
974
975         my ( $base_volume, $base_directories ) =
976             $self->splitpath( $base ) ;
977
978         $path_directories = '' if $path_directories eq '[]' ||
979                                   $path_directories eq '<>';
980         my $sep = '' ;
981
982         if ($efs) {
983             # Merge the paths assuming that the base is absolute.
984             $base_directories = $self->catdir('',
985                                               $base_directories,
986                                               $path_directories);
987         } else {
988             # Legacy behavior assumes VMS only paths
989             $sep = '.'
990                 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
991                      $path_directories =~ m{^[^.\[<]}s
992                 ) ;
993             $base_directories = "$base_directories$sep$path_directories";
994             $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
995         }
996
997         $path_file = '' if ($path_file eq '.') && $unix_mode;
998
999         $path = $self->catpath( $base_volume, $base_directories, $path_file );
1000    }
1001
1002     return $self->canonpath( $path ) ;
1003 }
1004
1005
1006 # eliminate_macros() and fixpath() are MakeMaker-specific methods
1007 # which are used inside catfile() and catdir().  MakeMaker has its own
1008 # copies as of 6.06_03 which are the canonical ones.  We leave these
1009 # here, in peace, so that File::Spec continues to work with MakeMakers
1010 # prior to 6.06_03.
1011
1012 # Please consider these two methods deprecated.  Do not patch them,
1013 # patch the ones in ExtUtils::MM_VMS instead.
1014 #
1015 # Update:  MakeMaker 6.48 is still using these routines on VMS.
1016 # so they need to be kept up to date with ExtUtils::MM_VMS.
1017 #
1018 # The traditional VMS mode using ODS-2 disks depends on these routines
1019 # being here.  These routines should not be called in when the
1020 # C<DECC$EFS_CHARSET> or C<DECC$FILENAME_UNIX_REPORT> modes are enabled.
1021
1022 sub eliminate_macros {
1023     my($self,$path) = @_;
1024     return '' unless (defined $path) && ($path ne '');
1025     $self = {} unless ref $self;
1026
1027     if ($path =~ /\s/) {
1028       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1029     }
1030
1031     my $npath = unixify($path);
1032     # sometimes unixify will return a string with an off-by-one trailing null
1033     $npath =~ s{\0$}{};
1034
1035     my($complex) = 0;
1036     my($head,$macro,$tail);
1037
1038     # perform m##g in scalar context so it acts as an iterator
1039     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
1040         if (defined $self->{$2}) {
1041             ($head,$macro,$tail) = ($1,$2,$3);
1042             if (ref $self->{$macro}) {
1043                 if (ref $self->{$macro} eq 'ARRAY') {
1044                     $macro = join ' ', @{$self->{$macro}};
1045                 }
1046                 else {
1047                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
1048                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
1049                     $macro = "\cB$macro\cB";
1050                     $complex = 1;
1051                 }
1052             }
1053             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1054             $npath = "$head$macro$tail";
1055         }
1056     }
1057     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1058     $npath;
1059 }
1060
1061 # Deprecated.  See the note above for eliminate_macros().
1062
1063 # Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
1064 # in any directory specification, in order to avoid juxtaposing two
1065 # VMS-syntax directories when MM[SK] is run.  Also expands expressions which
1066 # are all macro, so that we can tell how long the expansion is, and avoid
1067 # overrunning DCL's command buffer when MM[KS] is running.
1068
1069 # fixpath() checks to see whether the result matches the name of a
1070 # directory in the current default directory and returns a directory or
1071 # file specification accordingly.  C<$is_dir> can be set to true to
1072 # force fixpath() to consider the path to be a directory or false to force
1073 # it to be a file.
1074
1075 sub fixpath {
1076     my($self,$path,$force_path) = @_;
1077     return '' unless $path;
1078     $self = bless {}, $self unless ref $self;
1079     my($fixedpath,$prefix,$name);
1080
1081     if ($path =~ /\s/) {
1082       return join ' ',
1083              map { $self->fixpath($_,$force_path) }
1084              split /\s+/, $path;
1085     }
1086
1087     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
1088         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
1089             $fixedpath = vmspath($self->eliminate_macros($path));
1090         }
1091         else {
1092             $fixedpath = vmsify($self->eliminate_macros($path));
1093         }
1094     }
1095     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1096         my($vmspre) = $self->eliminate_macros("\$($prefix)");
1097         # is it a dir or just a name?
1098         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
1099         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
1100         $fixedpath = vmspath($fixedpath) if $force_path;
1101     }
1102     else {
1103         $fixedpath = $path;
1104         $fixedpath = vmspath($fixedpath) if $force_path;
1105     }
1106     # No hints, so we try to guess
1107     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
1108         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
1109     }
1110
1111     # Trim off root dirname if it's had other dirs inserted in front of it.
1112     $fixedpath =~ s/\.000000([\]>])/$1/;
1113     # Special case for VMS absolute directory specs: these will have had device
1114     # prepended during trip through Unix syntax in eliminate_macros(), since
1115     # Unix syntax has no way to express "absolute from the top of this device's
1116     # directory tree".
1117     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1118     $fixedpath;
1119 }
1120
1121
1122 =back
1123
1124 =head1 COPYRIGHT
1125
1126 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
1127
1128 This program is free software; you can redistribute it and/or modify
1129 it under the same terms as Perl itself.
1130
1131 =head1 SEE ALSO
1132
1133 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
1134 implementation of these methods, not the semantics.
1135
1136 An explanation of VMS file specs can be found at
1137 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
1138
1139 =cut
1140
1141 1;