This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge branch 'drolsky/release-5.15.6' into blead
[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.39_01';
8 $VERSION =~ tr/_//;
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,
606                                                           $no_file );
607
608 Passing a true value for C<$no_file> indicates that the path being
609 split only contains directory components, even on systems where you
610 can usually (when not supporting a foreign syntax) tell the difference
611 between directories and files at a glance.
612
613 =cut
614
615 sub splitpath {
616     my($self,$path, $nofile) = @_;
617     my($dev,$dir,$file)      = ('','','');
618     my $efs = $self->_efs;
619     my $vmsify_path = vmsify($path);
620     if ($efs) {
621         my $path_vms = 0;
622         $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
623         $path_vms = 1 if ($path =~ /^--?$/);
624         if (!$path_vms) {
625             return $self->SUPER::splitpath($path, $nofile);
626         }
627         $vmsify_path = $path;
628     }
629
630     if ( $nofile ) {
631         #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
632         #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
633         if( $vmsify_path =~ /(.*)\](.+)/ ){
634             $vmsify_path = $1.'.'.$2.']';
635         }
636         $vmsify_path =~ /(.+:)?(.*)/s;
637         $dir = defined $2 ? $2 : ''; # dir can be '0'
638         return ($1 || '',$dir,$file);
639     }
640     else {
641         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
642         return ($1 || '',$2 || '',$3);
643     }
644 }
645
646 =item splitdir (override)
647
648 Split a directory specification into the components.
649
650 =cut
651
652 sub splitdir {
653     my($self,$dirspec) = @_;
654     my @dirs = ();
655     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
656
657     my $efs = $self->_efs;
658
659     my $dir_unix = 0;
660     $dir_unix = 1 if ($dirspec =~ m#/#);
661     $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
662
663     # Unix filespecs in EFS mode handled by Unix routines.
664     if ($efs && $dir_unix) {
665         return $self->SUPER::splitdir($dirspec);
666     }
667
668     # FIX ME, only split for VMS delimiters not prefixed with '^'.
669
670     $dirspec =~ tr/<>/[]/;                      # < and >       ==> [ and ]
671     $dirspec =~ s/\]\[\./\.\]\[/g;              # ][.           ==> .][
672     $dirspec =~ s/\[000000\.\]\[/\[/g;          # [000000.][    ==> [
673     $dirspec =~ s/\[000000\./\[/g;              # [000000.      ==> [
674     $dirspec =~ s/\.\]\[000000\]/\]/g;          # .][000000]    ==> ]
675     $dirspec =~ s/\.\]\[/\./g;                  # foo.][bar     ==> foo.bar
676     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
677                                                 # That loop does the following
678                                                 # with any amount of dashes:
679                                                 # .--.          ==> .-.-.
680                                                 # [--.          ==> [-.-.
681                                                 # .--]          ==> .-.-]
682                                                 # [--]          ==> [-.-]
683     $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
684     $dirspec =~ s/^(\[|<)\./$1/;
685     @dirs = split /(?<!\^)\./, vmspath($dirspec);
686     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
687     @dirs;
688 }
689
690
691 =item catpath (override)
692
693 Construct a complete filespec.
694
695 =cut
696
697 sub catpath {
698     my($self,$dev,$dir,$file) = @_;
699     
700     my $efs = $self->_efs;
701     my $unix_rpt = $self->_unix_rpt;
702
703     my $unix_mode = 0;
704     my $dir_unix = 0;
705     $dir_unix = 1 if ($dir =~ m#/#);
706     $dir_unix = 1 if ($dir =~ /^\.\.?$/);
707     my $dir_vms = 0;
708     $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
709     $dir_vms = 1 if ($dir =~ /^--?$/);
710
711     if ($efs && (length($dev) == 0)) {
712         if ($dir_unix == $dir_vms) {
713             $unix_mode = $unix_rpt;
714         } else {
715             $unix_mode = $dir_unix;
716         }
717     } 
718
719     # We look for a volume in $dev, then in $dir, but not both
720     # but only if using VMS syntax.
721     if (!$unix_mode) {
722         $dir = vmspath($dir) if $dir_unix;
723         my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
724         $dev = $dir_volume unless length $dev;
725         $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) :
726                                   $dir_dir;
727     }
728     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
729     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
730     if (length($dev) or length($dir)) {
731       if ($efs) {
732           if ($unix_mode) {
733               $dir .= '/' unless ($dir =~ m#/$#);
734           } else {
735               $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
736               $dir = "[$dir]" unless $dir =~ /^[\[<]/;
737           }
738       } else {
739           $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
740           $dir = vmspath($dir);
741       }
742     }
743     $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
744     "$dev$dir$file";
745 }
746
747 =item abs2rel (override)
748
749 Attempt to convert a file specification to a relative specification.
750 On a system with volumes, like VMS, this may not be possible.
751
752 =cut
753
754 sub abs2rel {
755     my $self = shift;
756     my($path,$base) = @_;
757
758     my $efs = $self->_efs;
759     my $unix_rpt = $self->_unix_rpt;
760
761     # We need to identify what the directory is in
762     # of the specification in order to process them
763     my $path_unix = 0;
764     $path_unix = 1 if ($path =~ m#/#);
765     $path_unix = 1 if ($path =~ /^\.\.?$/);
766     my $path_vms = 0;
767     $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
768     $path_vms = 1 if ($path =~ /^--?$/);
769
770     my $unix_mode = 0;
771     if ($path_vms == $path_unix) {
772         $unix_mode = $unix_rpt;
773     } else {
774         $unix_mode = $path_unix;
775     }
776
777     my $base_unix = 0;
778     my $base_vms = 0;
779
780     if (defined $base) {
781         $base_unix = 1 if ($base =~ m#/#);
782         $base_unix = 1 if ($base =~ /^\.\.?$/);
783         $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
784         $base_vms = 1 if ($base =~ /^--?$/);
785
786         if ($path_vms == $path_unix) {
787             if ($base_vms == $base_unix) {
788                 $unix_mode = $unix_rpt;
789             } else {
790                 $unix_mode = $base_unix;
791             }
792         } else {
793             $unix_mode = 0 if $base_vms;
794         }
795     }
796
797     if ($efs) {
798         if ($unix_mode) {
799             # We are UNIX mode.
800             $base = unixpath($base) if $base_vms;
801             $base = unixify($path) if $path_vms;
802
803             # Here VMS is different, and in order to do this right
804             # we have to take the realpath for both the path and the base
805             # so that we can remove the common components.
806
807             if ($path =~ m#^/#) {
808                 if (defined $base) {
809
810                     # For the shorterm, if the starting directories are
811                     # common, remove them.
812                     my $bq = qq($base);
813                     $bq =~ s/\$/\\\$/;
814                     $path =~ s/^$bq//i;
815                 }
816                 return $path;
817             }
818
819             return File::Spec::Unix::abs2rel( $self, $path, $base );
820
821         } else {
822             $base = vmspath($base) if $base_unix;
823             $path = vmsify($path) if $path_unix;
824         }
825     }
826
827     unless (defined $base and length $base) {
828         $base = $self->_cwd();
829         if ($efs) {
830             $base_unix = 1 if ($base =~ m#/#);
831             $base_unix = 1 if ($base =~ /^\.\.?$/);
832             $base = vmspath($base) if $base_unix;
833         }
834     }
835
836     for ($path, $base) { $_ = $self->canonpath($_) }
837
838     # Are we even starting $path on the same (node::)device as $base?  Note that
839     # logical paths or nodename differences may be on the "same device" 
840     # but the comparison that ignores device differences so as to concatenate 
841     # [---] up directory specs is not even a good idea in cases where there is 
842     # a logical path difference between $path and $base nodename and/or device.
843     # Hence we fall back to returning the absolute $path spec
844     # if there is a case blind device (or node) difference of any sort
845     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
846     # (this module needs to run on non VMS platforms after all).
847     
848     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
849     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
850     return $path unless lc($path_volume) eq lc($base_volume);
851
852     for ($path, $base) { $_ = $self->rel2abs($_) }
853
854     # Now, remove all leading components that are the same
855     my @pathchunks = $self->splitdir( $path_directories );
856     my $pathchunks = @pathchunks;
857     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
858     my @basechunks = $self->splitdir( $base_directories );
859     my $basechunks = @basechunks;
860     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
861
862     while ( @pathchunks && 
863             @basechunks && 
864             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
865           ) {
866         shift @pathchunks ;
867         shift @basechunks ;
868     }
869
870     # @basechunks now contains the directories to climb out of,
871     # @pathchunks now has the directories to descend in to.
872     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
873       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
874     }
875     else {
876       $path_directories = join '.', @pathchunks;
877     }
878     $path_directories = '['.$path_directories.']';
879     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
880 }
881
882
883 =item rel2abs (override)
884
885 Return an absolute file specification from a relative one.
886
887 =cut
888
889 sub rel2abs {
890     my $self = shift ;
891     my ($path,$base ) = @_;
892     return undef unless defined $path;
893
894     my $efs = $self->_efs;
895     my $unix_rpt = $self->_unix_rpt;
896
897     # We need to identify what the directory is in
898     # of the specification in order to process them
899     my $path_unix = 0;
900     $path_unix = 1 if ($path =~ m#/#);
901     $path_unix = 1 if ($path =~ /^\.\.?$/);
902     my $path_vms = 0;
903     $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
904     $path_vms = 1 if ($path =~ /^--?$/);
905
906     my $unix_mode = 0;
907     if ($path_vms == $path_unix) {
908         $unix_mode = $unix_rpt;
909     } else {
910         $unix_mode = $path_unix;
911     }
912
913     my $base_unix = 0;
914     my $base_vms = 0;
915
916     if (defined $base) {
917         $base_unix = 1 if ($base =~ m#/#);
918         $base_unix = 1 if ($base =~ /^\.\.?$/);
919         $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
920         $base_vms = 1 if ($base =~ /^--?$/);
921
922         # If we could not determine the path mode, see if we can find out
923         # from the base.
924         if ($path_vms == $path_unix) {
925             if ($base_vms != $base_unix) {
926                 $unix_mode = $base_unix;
927             }
928         }
929     }
930
931     if (!$efs) {
932         # Legacy behavior, convert to VMS syntax.
933         $unix_mode = 0;
934         if (defined $base) {
935             $base = vmspath($base) if $base =~ m/\//;
936         }
937
938         if ($path =~ m/\//) {
939             $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
940                        ? vmspath($path)             # whether it's a directory
941                        : vmsify($path) );
942         }
943    }
944
945     # Clean up and split up $path
946     if ( ! $self->file_name_is_absolute( $path ) ) {
947         # Figure out the effective $base and clean it up.
948         if ( !defined( $base ) || $base eq '' ) {
949             $base = $self->_cwd;
950         }
951         elsif ( ! $self->file_name_is_absolute( $base ) ) {
952             $base = $self->rel2abs( $base ) ;
953         }
954         else {
955             $base = $self->canonpath( $base ) ;
956         }
957
958         if ($efs) {
959             # base may have changed, so need to look up format again.
960             if ($unix_mode) {
961                 $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
962                 $base_vms = 1 if ($base =~ /^--?$/);
963                 $base = unixpath($base) if $base_vms;
964                 $base .= '/' unless ($base =~ m#/$#);
965             } else {
966                 $base_unix = 1 if ($base =~ m#/#);
967                 $base_unix = 1 if ($base =~ /^\.\.?$/);
968                 $base = vmspath($base) if $base_unix; 
969             }
970         }
971
972         # Split up paths
973         my ( $path_directories, $path_file ) =
974             ($self->splitpath( $path ))[1,2] ;
975
976         my ( $base_volume, $base_directories ) =
977             $self->splitpath( $base ) ;
978
979         $path_directories = '' if $path_directories eq '[]' ||
980                                   $path_directories eq '<>';
981         my $sep = '' ;
982
983         if ($efs) {
984             # Merge the paths assuming that the base is absolute.
985             $base_directories = $self->catdir('',
986                                               $base_directories,
987                                               $path_directories);
988         } else {
989             # Legacy behavior assumes VMS only paths
990             $sep = '.'
991                 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
992                      $path_directories =~ m{^[^.\[<]}s
993                 ) ;
994             $base_directories = "$base_directories$sep$path_directories";
995             $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
996         }
997
998         $path_file = '' if ($path_file eq '.') && $unix_mode;
999
1000         $path = $self->catpath( $base_volume, $base_directories, $path_file );
1001    }
1002
1003     return $self->canonpath( $path ) ;
1004 }
1005
1006
1007 # eliminate_macros() and fixpath() are MakeMaker-specific methods
1008 # which are used inside catfile() and catdir().  MakeMaker has its own
1009 # copies as of 6.06_03 which are the canonical ones.  We leave these
1010 # here, in peace, so that File::Spec continues to work with MakeMakers
1011 # prior to 6.06_03.
1012
1013 # Please consider these two methods deprecated.  Do not patch them,
1014 # patch the ones in ExtUtils::MM_VMS instead.
1015 #
1016 # Update:  MakeMaker 6.48 is still using these routines on VMS.
1017 # so they need to be kept up to date with ExtUtils::MM_VMS.
1018 #
1019 # The traditional VMS mode using ODS-2 disks depends on these routines
1020 # being here.  These routines should not be called in when the
1021 # C<DECC$EFS_CHARSET> or C<DECC$FILENAME_UNIX_REPORT> modes are enabled.
1022
1023 sub eliminate_macros {
1024     my($self,$path) = @_;
1025     return '' unless (defined $path) && ($path ne '');
1026     $self = {} unless ref $self;
1027
1028     if ($path =~ /\s/) {
1029       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1030     }
1031
1032     my $npath = unixify($path);
1033     # sometimes unixify will return a string with an off-by-one trailing null
1034     $npath =~ s{\0$}{};
1035
1036     my($complex) = 0;
1037     my($head,$macro,$tail);
1038
1039     # perform m##g in scalar context so it acts as an iterator
1040     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
1041         if (defined $self->{$2}) {
1042             ($head,$macro,$tail) = ($1,$2,$3);
1043             if (ref $self->{$macro}) {
1044                 if (ref $self->{$macro} eq 'ARRAY') {
1045                     $macro = join ' ', @{$self->{$macro}};
1046                 }
1047                 else {
1048                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
1049                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
1050                     $macro = "\cB$macro\cB";
1051                     $complex = 1;
1052                 }
1053             }
1054             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1055             $npath = "$head$macro$tail";
1056         }
1057     }
1058     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1059     $npath;
1060 }
1061
1062 # Deprecated.  See the note above for eliminate_macros().
1063
1064 # Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
1065 # in any directory specification, in order to avoid juxtaposing two
1066 # VMS-syntax directories when MM[SK] is run.  Also expands expressions which
1067 # are all macro, so that we can tell how long the expansion is, and avoid
1068 # overrunning DCL's command buffer when MM[KS] is running.
1069
1070 # fixpath() checks to see whether the result matches the name of a
1071 # directory in the current default directory and returns a directory or
1072 # file specification accordingly.  C<$is_dir> can be set to true to
1073 # force fixpath() to consider the path to be a directory or false to force
1074 # it to be a file.
1075
1076 sub fixpath {
1077     my($self,$path,$force_path) = @_;
1078     return '' unless $path;
1079     $self = bless {}, $self unless ref $self;
1080     my($fixedpath,$prefix,$name);
1081
1082     if ($path =~ /\s/) {
1083       return join ' ',
1084              map { $self->fixpath($_,$force_path) }
1085              split /\s+/, $path;
1086     }
1087
1088     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
1089         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
1090             $fixedpath = vmspath($self->eliminate_macros($path));
1091         }
1092         else {
1093             $fixedpath = vmsify($self->eliminate_macros($path));
1094         }
1095     }
1096     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1097         my($vmspre) = $self->eliminate_macros("\$($prefix)");
1098         # is it a dir or just a name?
1099         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
1100         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
1101         $fixedpath = vmspath($fixedpath) if $force_path;
1102     }
1103     else {
1104         $fixedpath = $path;
1105         $fixedpath = vmspath($fixedpath) if $force_path;
1106     }
1107     # No hints, so we try to guess
1108     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
1109         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
1110     }
1111
1112     # Trim off root dirname if it's had other dirs inserted in front of it.
1113     $fixedpath =~ s/\.000000([\]>])/$1/;
1114     # Special case for VMS absolute directory specs: these will have had device
1115     # prepended during trip through Unix syntax in eliminate_macros(), since
1116     # Unix syntax has no way to express "absolute from the top of this device's
1117     # directory tree".
1118     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1119     $fixedpath;
1120 }
1121
1122
1123 =back
1124
1125 =head1 COPYRIGHT
1126
1127 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
1128
1129 This program is free software; you can redistribute it and/or modify
1130 it under the same terms as Perl itself.
1131
1132 =head1 SEE ALSO
1133
1134 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
1135 implementation of these methods, not the semantics.
1136
1137 An explanation of VMS file specs can be found at
1138 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
1139
1140 =cut
1141
1142 1;