34b592abbfefa22b7efa6e05a92979bb9ea7c8cd
[perl.git] / ext / 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.30';
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 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
31 C<DECC$EFS_CHARSET>.
32
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
35 operations.
36
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
39 given on input.
40
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.
44
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.
49
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.
53
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.
57
58 =over 4
59
60 =cut
61
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.
64
65 my $use_feature;
66 BEGIN {
67     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
68         $use_feature = 1;
69     }
70 }
71
72 # Need to look up the UNIX report mode.  This may become a dynamic mode
73 # in the future.
74 sub _unix_rpt {
75     my $unix_rpt;
76     if ($use_feature) {
77         $unix_rpt = VMS::Feature::current("filename_unix_report");
78     } else {
79         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
80         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
81     }
82     return $unix_rpt;
83 }
84
85 # Need to look up the EFS character set mode.  This may become a dynamic
86 # mode in the future.
87 sub _efs {
88     my $efs;
89     if ($use_feature) {
90         $efs = VMS::Feature::current("efs_charset");
91     } else {
92         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
93         $efs = $env_efs =~ /^[ET1]/i; 
94     }
95     return $efs;
96 }
97
98 =item canonpath (override)
99
100 Removes redundant portions of file specifications according to the syntax
101 detected.
102
103 =cut
104
105
106 sub canonpath {
107     my($self,$path) = @_;
108
109     return undef unless defined $path;
110
111     my $efs = $self->_efs;
112
113     if ($path =~ m|/|) { # Fake Unix
114       my $pathify = $path =~ m|/\Z(?!\n)|;
115       $path = $self->SUPER::canonpath($path);
116
117       # Do not convert to VMS when EFS character sets are in use
118       return $path if $efs;
119
120       if ($pathify) { return vmspath($path); }
121       else          { return vmsify($path);  }
122     }
123     else {
124
125 #FIXME - efs parsing has different rules.  Characters in a VMS filespec
126 #        are only delimiters if not preceded by '^';
127
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:
137                                                 # .-.-.         ==> .--.
138                                                 # [-.-.         ==> [--.
139                                                 # .-.-]         ==> .--]
140                                                 # [-.-]         ==> [--]
141         1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
142                                                 # That loop does the following
143                                                 # with any amount (minimum 2)
144                                                 # of dashes:
145                                                 # .foo.--.      ==> .-.
146                                                 # .foo.--]      ==> .-]
147                                                 # [foo.--.      ==> [-.
148                                                 # [foo.--]      ==> [-]
149                                                 #
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 '[]'; # []            ==>
157         return $path;
158     }
159 }
160
161 =item catdir (override)
162
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).
166
167 =cut
168
169 sub catdir {
170     my $self = shift;
171     my $dir = pop;
172
173     my $efs = $self->_efs;
174     my $unix_rpt = $self->_unix_rpt;
175
176
177     my @dirs = grep {defined() && length()} @_;
178     if ($efs) {
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.
184         if (@_) {
185             if ($_[0] eq '') {
186                 unshift @dirs, '';
187             }
188         }
189     }
190
191     my $rslt;
192     if (@dirs) {
193         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
194         my ($spath,$sdir) = ($path,$dir);
195
196         if ($efs) {
197             # Extended character set in use, go into DWIM mode.
198
199             # Now we need to identify what the directory is in
200             # of the specification in order to merge them.
201             my $path_unix = 0;
202             $path_unix = 1 if ($path =~ m#/#);
203             $path_unix = 1 if ($path =~ /^\.\.?$/);
204             my $path_vms = 0;
205             $path_vms = 1 if ($path =~ m#[\[<\]]#);
206             $path_vms = 1 if ($path =~ /^--?$/);
207             my $dir_unix = 0;
208             $dir_unix = 1 if ($dir =~ m#/#);
209             $dir_unix = 1 if ($dir =~ /^\.\.?$/);
210             my $dir_vms = 0;
211             $dir_vms = 1 if ($dir =~ m#[\[<\]]#);
212             $dir_vms = 1 if ($dir =~ /^--?$/);
213
214             my $unix_mode = 0;
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;
218             } else {
219                 $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt);
220                 $unix_mode = 1 if ($path_unix || $dir_unix);
221             }
222
223             if ($unix_mode) {
224
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;
228
229                 $rslt = $path;
230                 # Append a path delimiter
231                 $rslt .= '/' unless ($rslt =~ m#/$#);
232
233                 $rslt .= $dir;
234                 return $self->SUPER::canonpath($rslt);
235             } else {
236
237                 #with <> posible instead of [.
238                 # Normalize the brackets
239                 # Fixme - need to not switch when preceded by ^.
240                 $path =~ s/</\[/g;
241                 $path =~ s/>/\]/g;
242                 $dir =~ s/</\[/g;
243                 $dir =~ s/>/\]/g;
244
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;
248
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]
252
253                 # Fix up a bare path name.
254                 unless ($path_vms) {
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;
259                     } else {
260                         # Just start a directory.
261                         $path = '[' . $path;
262                     }
263                 } else {
264                     $path =~ s/\]$//;
265                 }
266
267                 #Possible dir values: [.dir] dir and $(foo)
268
269                 # No punctuation may have a trailing .dir
270                 unless ($dir_vms) {
271                     $dir =~ s/\.dir\Z(?!\n)//i;
272                 } else {
273
274                     #strip off the brackets
275                     $dir =~ s/^\[//;
276                     $dir =~ s/\]$//;
277                 }
278
279                 #strip off the leading dot if present.
280                 $dir =~ s/^\.//;
281
282                 # Now put the specifications together.
283                 if ($dir ne '') {
284                     # Add a separator unless this is an absolute path
285                     $path .= '.' if ($path ne '[');
286                     $rslt = $path . $dir . ']';
287                 } else {
288                     $rslt = $path . ']';
289                 }
290             }
291
292         } else {
293             # Traditional ODS-2 mode.
294             $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 
295
296             $sdir = $self->eliminate_macros($sdir)
297                 unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
298             $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
299
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; }
305         } 
306     } else {
307         # Single directory, just make sure it is in directory format
308         # Return an empty string on null input, and pass through macros.
309
310         if    (not defined $dir or not length $dir) { $rslt = ''; }
311         elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { 
312             $rslt = $dir;
313         } else {
314             my $unix_mode = 0;
315
316             if ($efs) {
317                 my $dir_unix = 0;
318                 $dir_unix = 1 if ($dir =~ m#/#);
319                 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
320                 my $dir_vms = 0;
321                 $dir_vms = 1 if ($dir =~ m#[\[<\]]#);
322                 $dir_vms = 1 if ($dir =~ /^--?$/);
323
324                 if ($dir_vms == $dir_unix) {
325                     # Ambiguous, so if in $unix_rpt mode then assume UNIX.
326                     $unix_mode = 1 if $unix_rpt;
327                 } else {
328                     $unix_mode = 1 if $dir_unix;
329                 }
330             }
331
332             if ($unix_mode) {
333                 return $dir;
334             } else {
335                 # For VMS, force it to be in directory format
336                 $rslt = vmspath($dir);
337             }
338         }
339     }
340     return $self->canonpath($rslt);
341 }
342
343 =item catfile (override)
344
345 Concatenates a list of directory specifications with a filename specification
346 to build a path.
347
348 =cut
349
350 sub catfile {
351     my $self = shift;
352     my $tfile = pop();
353     my $file = $self->canonpath($tfile);
354     my @files = grep {defined() && length()} @_;
355
356     my $efs = $self->_efs;
357     my $unix_rpt = $self->_unix_rpt;
358
359     # Assume VMS mode
360     my $unix_mode = 0;
361     my $file_unix = 0;
362     my $file_vms = 0;
363     if ($efs) {
364
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 =~ /^--?$/);
371
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);
375         }
376     }
377
378     my $rslt;
379     if (@files) {
380         # concatenate the directories.
381         my $path;
382         if (@files == 1) {
383            $path = $files[0];
384         } else {
385             if ($file_vms) {
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.
389                 my $i = @files - 1;
390                 my $tdir = $files[$i];
391                 my $tdir_vms = 0;
392                 my $tdir_unix = 0;
393                 $tdir_vms = 1 if ($tdir =~ m#[\[<\]]#);
394                 $tdir_unix = 1 if ($tdir =~ m#/#);
395                 $tdir_unix = 1 if ($tdir =~ /^\.\.?$/);
396
397                 if (!$tdir_vms) {
398                     if ($tdir_unix) { 
399                         $tdir = vmspath($tdir);
400                     } else {
401                         $tdir =~ s/\.dir\Z(?!\n)//i;
402                         $tdir = '[.' . $tdir . ']';
403                     }
404                     $files[$i] = $tdir;
405                 }
406             }
407             $path = $self->catdir(@files);
408         }
409         my $spath = $path;
410
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;
414
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";
421         } else {
422             if ($efs) {
423
424                 # Now we need to identify what the directory is in
425                 # of the specification in order to merge them.
426                 my $spath_unix = 0;
427                 $spath_unix = 1 if ($spath =~ m#/#);
428                 $spath_unix = 1 if ($spath =~ /^\.\.?$/);
429                 my $spath_vms = 0;
430                 $spath_vms = 1 if ($spath =~ m#[\[<\]]#);
431                 $spath_vms = 1 if ($spath =~ /^--?$/);
432
433                 # Assume VMS mode
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;
438                 } else {
439                      $unix_mode = 1
440                          if (($spath_unix || $file_unix) && $unix_rpt);
441                 }
442
443                 if (!$unix_mode) {
444                     if ($spath_vms) {
445                         $spath = '[' . $spath . ']' if $spath =~ /^-/;
446                         $rslt = vmspath($spath);
447                     } else {
448                         $rslt = '[.' . $spath . ']';
449                     }
450                     $file = vmsify($file) if ($file_unix);
451                 } else {
452                     $spath = unixify($spath) if ($spath_vms);
453                     $rslt = $spath;
454                     $file = unixify($file) if ($file_vms);
455
456                     # Unix merge may need a directory delimitor.
457                     # A null path indicates root on Unix.
458                     $rslt .= '/' unless ($rslt =~ m#/$#);
459                 }
460
461                 $rslt .= $file;
462                 $rslt =~ s/\]\[//;
463
464             } else {
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
471                 # to VMS format.
472
473                 $rslt = $self->eliminate_macros($spath);
474
475
476                 $rslt = vmsify($rslt.((defined $rslt) &&
477                     ($rslt ne '') ? '/' : '').unixify($file));
478             }
479         }
480     }
481     else {
482         # Only passed a single file?
483         my $xfile = $file;
484
485         # Traditional VMS perl expects this conversion.
486         $xfile = vmsify($file) unless ($efs);
487
488         $rslt = (defined($file) && length($file)) ? $xfile : '';
489     }
490     return $self->canonpath($rslt) unless $unix_rpt;
491
492     # In Unix report mode, do not strip off redundent path information.
493     return $rslt;
494 }
495
496
497 =item curdir (override)
498
499 Returns a string representation of the current directory: '[]' or '.'
500
501 =cut
502
503 sub curdir {
504     my $self = shift @_;
505     return '.' if ($self->_unix_rpt);
506     return '[]';
507 }
508
509 =item devnull (override)
510
511 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
512
513 =cut
514
515 sub devnull {
516     my $self = shift @_;
517     return '/dev/null' if ($self->_unix_rpt);
518     return "_NLA0:";
519 }
520
521 =item rootdir (override)
522
523 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
524 or '/'
525
526 =cut
527
528 sub rootdir {
529     my $self = shift @_;
530     if ($self->_unix_rpt) {
531        # Root may exist, try it first.
532        my $try = '/';
533        my ($dev1, $ino1) = stat('/');
534        my ($dev2, $ino2) = stat('.');
535
536        # Perl falls back to '.' if it can not determine '/'
537        if (($dev1 != $dev2) || ($ino1 != $ino2)) {
538            return $try;
539        }
540        # Fall back to UNIX format sys$disk.
541        return '/sys$disk/';
542     }
543     return 'SYS$DISK:[000000]';
544 }
545
546 =item tmpdir (override)
547
548 Returns a string representation of the first writable directory
549 from the following list or '' if none are writable:
550
551     /tmp if C<DECC$FILENAME_REPORT_UNIX> is enabled.
552     sys$scratch:
553     $ENV{TMPDIR}
554
555 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
556 is tainted, it is not used.
557
558 =cut
559
560 my $tmpdir;
561 sub tmpdir {
562     my $self = shift @_;
563     return $tmpdir if defined $tmpdir;
564     if ($self->_unix_rpt) {
565         $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
566         return $tmpdir;
567     }
568
569     $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
570 }
571
572 =item updir (override)
573
574 Returns a string representation of the parent directory: '[-]' or '..'
575
576 =cut
577
578 sub updir {
579     my $self = shift @_;
580     return '..' if ($self->_unix_rpt);
581     return '[-]';
582 }
583
584 =item case_tolerant (override)
585
586 VMS file specification syntax is case-tolerant.
587
588 =cut
589
590 sub case_tolerant {
591     return 1;
592 }
593
594 =item path (override)
595
596 Translate logical name DCL$PATH as a searchlist, rather than trying
597 to C<split> string value of C<$ENV{'PATH'}>.
598
599 =cut
600
601 sub path {
602     my (@dirs,$dir,$i);
603     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
604     return @dirs;
605 }
606
607 =item file_name_is_absolute (override)
608
609 Checks for VMS directory spec as well as Unix separators.
610
611 =cut
612
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![<\[][^.\-\]>]!  ||
619                   $file =~ /:[^<\[]/);
620 }
621
622 =item splitpath (override)
623
624     ($volume,$directories,$file) = File::Spec->splitpath( $path );
625     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
626
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.
631
632 =cut
633
634 sub splitpath {
635     my($self,$path, $nofile) = @_;
636     my($dev,$dir,$file)      = ('','','');
637     my $efs = $self->_efs;
638     my $vmsify_path = vmsify($path);
639     if ($efs) {
640         my $path_vms = 0;
641         $path_vms = 1 if ($path =~ m#[\[<\]]#);
642         $path_vms = 1 if ($path =~ /^--?$/);
643         if (!$path_vms) {
644             return $self->SUPER::splitpath($path, $nofile);
645         }
646         $vmsify_path = $path;
647     }
648
649     if ( $nofile ) {
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.']';
654         }
655         $vmsify_path =~ /(.+:)?(.*)/s;
656         $dir = defined $2 ? $2 : ''; # dir can be '0'
657         return ($1 || '',$dir,$file);
658     }
659     else {
660         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
661         return ($1 || '',$2 || '',$3);
662     }
663 }
664
665 =item splitdir (override)
666
667 Split a directory specification into the components.
668
669 =cut
670
671 sub splitdir {
672     my($self,$dirspec) = @_;
673     my @dirs = ();
674     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
675
676     my $efs = $self->_efs;
677
678     my $dir_unix = 0;
679     $dir_unix = 1 if ($dirspec =~ m#/#);
680     $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
681
682     # Unix filespecs in EFS mode handled by Unix routines.
683     if ($efs && $dir_unix) {
684         return $self->SUPER::splitdir($dirspec);
685     }
686
687     # FIX ME, only split for VMS delimiters not prefixed with '^'.
688
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:
698                                                 # .--.          ==> .-.-.
699                                                 # [--.          ==> [-.-.
700                                                 # .--]          ==> .-.-]
701                                                 # [--]          ==> [-.-]
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;
706     @dirs;
707 }
708
709
710 =item catpath (override)
711
712 Construct a complete filespec.
713
714 =cut
715
716 sub catpath {
717     my($self,$dev,$dir,$file) = @_;
718     
719     my $efs = $self->_efs;
720     my $unix_rpt = $self->_unix_rpt;
721
722     my $unix_mode = 0;
723     my $dir_unix = 0;
724     $dir_unix = 1 if ($dir =~ m#/#);
725     $dir_unix = 1 if ($dir =~ /^\.\.?$/);
726     my $dir_vms = 0;
727     $dir_vms = 1 if ($dir =~ m#[\[<\]]#);
728     $dir_vms = 1 if ($dir =~ /^--?$/);
729
730     if ($efs && (length($dev) == 0)) {
731         if ($dir_unix == $dir_vms) {
732             $unix_mode = $unix_rpt;
733         } else {
734             $unix_mode = $dir_unix;
735         }
736     } 
737
738     # We look for a volume in $dev, then in $dir, but not both
739     # but only if using VMS syntax.
740     if (!$unix_mode) {
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) :
745                                   $dir_dir;
746     }
747     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
748     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
749     if (length($dev) or length($dir)) {
750       if ($efs) {
751           if ($unix_mode) {
752               $dir .= '/' unless ($dir =~ m#/$#);
753           } else {
754               $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
755               $dir = "[$dir]" unless $dir =~ /^[\[<]/;
756           }
757       } else {
758           $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
759           $dir = vmspath($dir);
760       }
761     }
762     "$dev$dir$file";
763 }
764
765 =item abs2rel (override)
766
767 Attempt to convert a file specification to a relative specification.
768 On a system with volumes, like VMS, this may not be possible.
769
770 =cut
771
772 sub abs2rel {
773     my $self = shift;
774     my($path,$base) = @_;
775
776     my $efs = $self->_efs;
777     my $unix_rpt = $self->_unix_rpt;
778
779     if (!$efs) {
780         return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
781             if grep m{/}, @_;
782     }
783
784     # We need to identify what the directory is in
785     # of the specification in order to process them
786     my $path_unix = 0;
787     $path_unix = 1 if ($path =~ m#/#);
788     $path_unix = 1 if ($path =~ /^\.\.?$/);
789     my $path_vms = 0;
790     $path_vms = 1 if ($path =~ m#[\[<\]]#);
791     $path_vms = 1 if ($path =~ /^--?$/);
792
793     my $unix_mode = 0;
794     if ($path_vms == $path_unix) {
795         $unix_mode = $unix_rpt;
796     } else {
797         $unix_mode = $path_unix;
798     }
799
800     my $base_unix = 0;
801     my $base_vms = 0;
802
803     if (defined $base) {
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 =~ /^--?$/);
808
809         if ($path_vms == $path_unix) {
810             if ($base_vms == $base_unix) {
811                 $unix_mode = $unix_rpt;
812             } else {
813                 $unix_mode = $base_unix;
814             }
815         } else {
816             $unix_mode = 0 if $base_vms;
817         }
818     }
819
820     if ($efs) {
821         if ($unix_mode) {
822             # We are UNIX mode.
823             $base = unixpath($base) if $base_vms;
824             $base = unixify($path) if $path_vms;
825
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.
829
830             if ($path =~ m#^/#) {
831                 if (defined $base) {
832
833                     # For the shorterm, if the starting directories are
834                     # common, remove them.
835                     my $bq = qq($base);
836                     $bq =~ s/\$/\\\$/;
837                     $path =~ s/^$bq//i;
838                 }
839                 return $path;
840             }
841
842             return File::Spec::Unix::abs2rel( $self, $path, $base );
843
844         } else {
845             $base = vmspath($base) if $base_unix;
846             $path = vmsify($path) if $path_unix;
847         }
848     }
849
850     unless (defined $base and length $base) {
851         $base = $self->_cwd();
852         if ($efs) {
853             $base_unix = 1 if ($base =~ m#/#);
854             $base_unix = 1 if ($base =~ /^\.\.?$/);
855             $base = vmspath($base) if $base_unix;
856         }
857     }
858
859     for ($path, $base) { $_ = $self->canonpath($_) }
860
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).
870     
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);
874
875     for ($path, $base) { $_ = $self->rel2abs($_) }
876
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';
884
885     while ( @pathchunks && 
886             @basechunks && 
887             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
888           ) {
889         shift @pathchunks ;
890         shift @basechunks ;
891     }
892
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) ;
897     }
898     else {
899       $path_directories = join '.', @pathchunks;
900     }
901     $path_directories = '['.$path_directories.']';
902     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
903 }
904
905
906 =item rel2abs (override)
907
908 Return an absolute file specification from a relative one.
909
910 =cut
911
912 sub rel2abs {
913     my $self = shift ;
914     my ($path,$base ) = @_;
915     return undef unless defined $path;
916
917     my $efs = $self->_efs;
918     my $unix_rpt = $self->_unix_rpt;
919
920     # We need to identify what the directory is in
921     # of the specification in order to process them
922     my $path_unix = 0;
923     $path_unix = 1 if ($path =~ m#/#);
924     $path_unix = 1 if ($path =~ /^\.\.?$/);
925     my $path_vms = 0;
926     $path_vms = 1 if ($path =~ m#[\[<\]]#);
927     $path_vms = 1 if ($path =~ /^--?$/);
928
929     my $unix_mode = 0;
930     if ($path_vms == $path_unix) {
931         $unix_mode = $unix_rpt;
932     } else {
933         $unix_mode = $path_unix;
934     }
935
936     my $base_unix = 0;
937     my $base_vms = 0;
938
939     if (defined $base) {
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 =~ /^--?$/);
944
945         # If we could not determine the path mode, see if we can find out
946         # from the base.
947         if ($path_vms == $path_unix) {
948             if ($base_vms != $base_unix) {
949                 $unix_mode = $base_unix;
950             }
951         }
952     }
953
954     if (!$efs) {
955         # Legacy behavior, convert to VMS syntax.
956         $unix_mode = 0;
957         if (defined $base) {
958             $base = vmspath($base) if $base =~ m/\//;
959         }
960
961         if ($path =~ m/\//) {
962             $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
963                        ? vmspath($path)             # whether it's a directory
964                        : vmsify($path) );
965         }
966    }
967
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 '' ) {
972             $base = $self->_cwd;
973         }
974         elsif ( ! $self->file_name_is_absolute( $base ) ) {
975             $base = $self->rel2abs( $base ) ;
976         }
977         else {
978             $base = $self->canonpath( $base ) ;
979         }
980
981         if ($efs) {
982             # base may have changed, so need to look up format again.
983             if ($unix_mode) {
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#/$#);
988             } else {
989                 $base_unix = 1 if ($base =~ m#/#);
990                 $base_unix = 1 if ($base =~ /^\.\.?$/);
991                 $base = vmspath($base) if $base_unix; 
992             }
993         }
994
995         # Split up paths
996         my ( $path_directories, $path_file ) =
997             ($self->splitpath( $path ))[1,2] ;
998
999         my ( $base_volume, $base_directories ) =
1000             $self->splitpath( $base ) ;
1001
1002         $path_directories = '' if $path_directories eq '[]' ||
1003                                   $path_directories eq '<>';
1004         my $sep = '' ;
1005
1006         if ($efs) {
1007             # Merge the paths assuming that the base is absolute.
1008             $base_directories = $self->catdir('',
1009                                               $base_directories,
1010                                               $path_directories);
1011         } else {
1012             # Legacy behavior assumes VMS only paths
1013             $sep = '.'
1014                 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
1015                      $path_directories =~ m{^[^.\[<]}s
1016                 ) ;
1017             $base_directories = "$base_directories$sep$path_directories";
1018             $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
1019         }
1020
1021         $path_file = '' if ($path_file eq '.') && $unix_mode;
1022
1023         $path = $self->catpath( $base_volume, $base_directories, $path_file );
1024    }
1025
1026     return $self->canonpath( $path ) ;
1027 }
1028
1029
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
1034 # prior to 6.06_03.
1035
1036 # Please consider these two methods deprecated.  Do not patch them,
1037 # patch the ones in ExtUtils::MM_VMS instead.
1038 #
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.
1041 #
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.
1045
1046 sub eliminate_macros {
1047     my($self,$path) = @_;
1048     return '' unless (defined $path) && ($path ne '');
1049     $self = {} unless ref $self;
1050
1051     if ($path =~ /\s/) {
1052       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1053     }
1054
1055     my $npath = unixify($path);
1056     # sometimes unixify will return a string with an off-by-one trailing null
1057     $npath =~ s{\0$}{};
1058
1059     my($complex) = 0;
1060     my($head,$macro,$tail);
1061
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}};
1069                 }
1070                 else {
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";
1074                     $complex = 1;
1075                 }
1076             }
1077             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1078             $npath = "$head$macro$tail";
1079         }
1080     }
1081     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1082     $npath;
1083 }
1084
1085 # Deprecated.  See the note above for eliminate_macros().
1086
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.
1092
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
1097 # it to be a file.
1098
1099 sub fixpath {
1100     my($self,$path,$force_path) = @_;
1101     return '' unless $path;
1102     $self = bless {}, $self unless ref $self;
1103     my($fixedpath,$prefix,$name);
1104
1105     if ($path =~ /\s/) {
1106       return join ' ',
1107              map { $self->fixpath($_,$force_path) }
1108              split /\s+/, $path;
1109     }
1110
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));
1114         }
1115         else {
1116             $fixedpath = vmsify($self->eliminate_macros($path));
1117         }
1118     }
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;
1125     }
1126     else {
1127         $fixedpath = $path;
1128         $fixedpath = vmspath($fixedpath) if $force_path;
1129     }
1130     # No hints, so we try to guess
1131     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
1132         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
1133     }
1134
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
1140     # directory tree".
1141     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1142     $fixedpath;
1143 }
1144
1145
1146 =back
1147
1148 =head1 COPYRIGHT
1149
1150 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
1151
1152 This program is free software; you can redistribute it and/or modify
1153 it under the same terms as Perl itself.
1154
1155 =head1 SEE ALSO
1156
1157 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
1158 implementation of these methods, not the semantics.
1159
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">.
1162
1163 =cut
1164
1165 1;