This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
331f7e3c0831867e1e67d59ce78cba33abcd36d8
[perl5.git] / dist / PathTools / 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.53';
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 unless Unix syntax has been explicitly requested
31 via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
32
33 =over 4
34
35 =cut
36
37 # Need to look up the feature settings.  The preferred way is to use the
38 # VMS::Feature module, but that may not be available to dual life modules.
39
40 my $use_feature;
41 BEGIN {
42     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
43         $use_feature = 1;
44     }
45 }
46
47 # Need to look up the UNIX report mode.  This may become a dynamic mode
48 # in the future.
49 sub _unix_rpt {
50     my $unix_rpt;
51     if ($use_feature) {
52         $unix_rpt = VMS::Feature::current("filename_unix_report");
53     } else {
54         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
55         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
56     }
57     return $unix_rpt;
58 }
59
60 =item canonpath (override)
61
62 Removes redundant portions of file specifications and returns results
63 in native syntax unless Unix filename reporting has been enabled.
64
65 =cut
66
67
68 sub canonpath {
69     my($self,$path) = @_;
70
71     return undef unless defined $path;
72
73     my $unix_rpt = $self->_unix_rpt;
74
75     if ($path =~ m|/|) {
76       my $pathify = $path =~ m|/\Z(?!\n)|;
77       $path = $self->SUPER::canonpath($path);
78
79       return $path if $unix_rpt;
80       $path = $pathify ? vmspath($path) : vmsify($path);
81     }
82
83     $path =~ s/(?<!\^)</[/;                     # < and >       ==> [ and ]
84     $path =~ s/(?<!\^)>/]/;
85     $path =~ s/(?<!\^)\]\[\./\.\]\[/g;          # ][.           ==> .][
86     $path =~ s/(?<!\^)\[000000\.\]\[/\[/g;      # [000000.][    ==> [
87     $path =~ s/(?<!\^)\[000000\./\[/g;          # [000000.      ==> [
88     $path =~ s/(?<!\^)\.\]\[000000\]/\]/g;      # .][000000]    ==> ]
89     $path =~ s/(?<!\^)\.\]\[/\./g;              # foo.][bar     ==> foo.bar
90     1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
91                                                 # That loop does the following
92                                                 # with any amount of dashes:
93                                                 # .-.-.         ==> .--.
94                                                 # [-.-.         ==> [--.
95                                                 # .-.-]         ==> .--]
96                                                 # [-.-]         ==> [--]
97     1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
98                                                 # That loop does the following
99                                                 # with any amount (minimum 2)
100                                                 # of dashes:
101                                                 # .foo.--.      ==> .-.
102                                                 # .foo.--]      ==> .-]
103                                                 # [foo.--.      ==> [-.
104                                                 # [foo.--]      ==> [-]
105                                                 #
106                                                 # And then, the remaining cases
107     $path =~ s/(?<!\^)\[\.-/[-/;                # [.-           ==> [-
108     $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g;     # .foo.-.       ==> .
109     $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g;     # [foo.-.       ==> [
110     $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g;     # .foo.-]       ==> ]
111                                                 # [foo.-]       ==> [000000]
112     $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g;
113                                                 # []            ==>
114     $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
115     return $unix_rpt ? unixify($path) : $path;
116 }
117
118 =item catdir (override)
119
120 Concatenates a list of file specifications, and returns the result as a
121 native directory specification unless the Unix filename reporting feature
122 has been enabled.  No check is made for "impossible" cases (e.g. elements
123 other than the first being absolute filespecs).
124
125 =cut
126
127 sub catdir {
128     my $self = shift;
129     my $dir = pop;
130
131     my $unix_rpt = $self->_unix_rpt;
132
133     my @dirs = grep {defined() && length()} @_;
134
135     my $rslt;
136     if (@dirs) {
137         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
138         my ($spath,$sdir) = ($path,$dir);
139         $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 
140
141         if ($unix_rpt) {
142             $spath = unixify($spath) unless $spath =~ m#/#;
143             $sdir= unixify($sdir) unless $sdir =~ m#/#;
144             return $self->SUPER::catdir($spath, $sdir)
145         }
146
147         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
148         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
149
150         # Special case for VMS absolute directory specs: these will have
151         # had device prepended during trip through Unix syntax in
152         # eliminate_macros(), since Unix syntax has no way to express
153         # "absolute from the top of this device's directory tree".
154         if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
155
156     } else {
157         # Single directory. Return an empty string on null input; otherwise
158         # just return a canonical path.
159
160         if    (not defined $dir or not length $dir) {
161             $rslt = '';
162         } else {
163             $rslt = $unix_rpt ? $dir : vmspath($dir);
164         }
165     }
166     return $self->canonpath($rslt);
167 }
168
169 =item catfile (override)
170
171 Concatenates a list of directory specifications with a filename specification
172 to build a path.
173
174 =cut
175
176 sub catfile {
177     my $self = shift;
178     my $tfile = pop();
179     my $file = $self->canonpath($tfile);
180     my @files = grep {defined() && length()} @_;
181
182     my $unix_rpt = $self->_unix_rpt;
183
184     my $rslt;
185     if (@files) {
186         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
187         my $spath = $path;
188
189         # Something building a VMS path in pieces may try to pass a
190         # directory name in filename format, so normalize it.
191         $spath =~ s/\.dir\Z(?!\n)//i;
192
193         # If the spath ends with a directory delimiter and the file is bare,
194         # then just concatenate them.
195         if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
196             $rslt = "$spath$file";
197         } else {
198            $rslt = $self->eliminate_macros($spath);
199            $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
200            $rslt = vmsify($rslt) unless $unix_rpt;
201         }
202     }
203     else {
204         # Only passed a single file?
205         my $xfile = (defined($file) && length($file)) ? $file : '';
206
207         $rslt = $unix_rpt ? $xfile : vmsify($xfile);
208     }
209     return $self->canonpath($rslt) unless $unix_rpt;
210
211     # In Unix report mode, do not strip off redundant path information.
212     return $rslt;
213 }
214
215
216 =item curdir (override)
217
218 Returns a string representation of the current directory: '[]' or '.'
219
220 =cut
221
222 sub curdir {
223     my $self = shift @_;
224     return '.' if ($self->_unix_rpt);
225     return '[]';
226 }
227
228 =item devnull (override)
229
230 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
231
232 =cut
233
234 sub devnull {
235     my $self = shift @_;
236     return '/dev/null' if ($self->_unix_rpt);
237     return "_NLA0:";
238 }
239
240 =item rootdir (override)
241
242 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
243 or '/'
244
245 =cut
246
247 sub rootdir {
248     my $self = shift @_;
249     if ($self->_unix_rpt) {
250        # Root may exist, try it first.
251        my $try = '/';
252        my ($dev1, $ino1) = stat('/');
253        my ($dev2, $ino2) = stat('.');
254
255        # Perl falls back to '.' if it can not determine '/'
256        if (($dev1 != $dev2) || ($ino1 != $ino2)) {
257            return $try;
258        }
259        # Fall back to UNIX format sys$disk.
260        return '/sys$disk/';
261     }
262     return 'SYS$DISK:[000000]';
263 }
264
265 =item tmpdir (override)
266
267 Returns a string representation of the first writable directory
268 from the following list or '' if none are writable:
269
270     /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
271     sys$scratch:
272     $ENV{TMPDIR}
273
274 If running under taint mode, and if $ENV{TMPDIR}
275 is tainted, it is not used.
276
277 =cut
278
279 sub tmpdir {
280     my $self = shift @_;
281     my $tmpdir = $self->_cached_tmpdir('TMPDIR');
282     return $tmpdir if defined $tmpdir;
283     if ($self->_unix_rpt) {
284         $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
285     }
286     else {
287         $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
288     }
289     $self->_cache_tmpdir($tmpdir, 'TMPDIR');
290 }
291
292 =item updir (override)
293
294 Returns a string representation of the parent directory: '[-]' or '..'
295
296 =cut
297
298 sub updir {
299     my $self = shift @_;
300     return '..' if ($self->_unix_rpt);
301     return '[-]';
302 }
303
304 =item case_tolerant (override)
305
306 VMS file specification syntax is case-tolerant.
307
308 =cut
309
310 sub case_tolerant {
311     return 1;
312 }
313
314 =item path (override)
315
316 Translate logical name DCL$PATH as a searchlist, rather than trying
317 to C<split> string value of C<$ENV{'PATH'}>.
318
319 =cut
320
321 sub path {
322     my (@dirs,$dir,$i);
323     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
324     return @dirs;
325 }
326
327 =item file_name_is_absolute (override)
328
329 Checks for VMS directory spec as well as Unix separators.
330
331 =cut
332
333 sub file_name_is_absolute {
334     my ($self,$file) = @_;
335     # If it's a logical name, expand it.
336     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
337     return scalar($file =~ m!^/!s             ||
338                   $file =~ m![<\[][^.\-\]>]!  ||
339                   $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
340 }
341
342 =item splitpath (override)
343
344    ($volume,$directories,$file) = File::Spec->splitpath( $path );
345    ($volume,$directories,$file) = File::Spec->splitpath( $path,
346                                                          $no_file );
347
348 Passing a true value for C<$no_file> indicates that the path being
349 split only contains directory components, even on systems where you
350 can usually (when not supporting a foreign syntax) tell the difference
351 between directories and files at a glance.
352
353 =cut
354
355 sub splitpath {
356     my($self,$path, $nofile) = @_;
357     my($dev,$dir,$file)      = ('','','');
358     my $vmsify_path = vmsify($path);
359
360     if ( $nofile ) {
361         #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
362         #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
363         if( $vmsify_path =~ /(.*)\](.+)/ ){
364             $vmsify_path = $1.'.'.$2.']';
365         }
366         $vmsify_path =~ /(.+:)?(.*)/s;
367         $dir = defined $2 ? $2 : ''; # dir can be '0'
368         return ($1 || '',$dir,$file);
369     }
370     else {
371         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
372         return ($1 || '',$2 || '',$3);
373     }
374 }
375
376 =item splitdir (override)
377
378 Split a directory specification into the components.
379
380 =cut
381
382 sub splitdir {
383     my($self,$dirspec) = @_;
384     my @dirs = ();
385     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
386
387     $dirspec =~ s/(?<!\^)</[/;                  # < and >       ==> [ and ]
388     $dirspec =~ s/(?<!\^)>/]/;
389     $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g;       # ][.           ==> .][
390     $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g;   # [000000.][    ==> [
391     $dirspec =~ s/(?<!\^)\[000000\./\[/g;       # [000000.      ==> [
392     $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g;   # .][000000]    ==> ]
393     $dirspec =~ s/(?<!\^)\.\]\[/\./g;           # foo.][bar     ==> foo.bar
394     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
395                                                 # That loop does the following
396                                                 # with any amount of dashes:
397                                                 # .--.          ==> .-.-.
398                                                 # [--.          ==> [-.-.
399                                                 # .--]          ==> .-.-]
400                                                 # [--]          ==> [-.-]
401     $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
402     $dirspec =~ s/^(\[|<)\./$1/;
403     @dirs = split /(?<!\^)\./, vmspath($dirspec);
404     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
405     @dirs;
406 }
407
408
409 =item catpath (override)
410
411 Construct a complete filespec.
412
413 =cut
414
415 sub catpath {
416     my($self,$dev,$dir,$file) = @_;
417     
418     # We look for a volume in $dev, then in $dir, but not both
419     my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
420     $dev = $dir_volume unless length $dev;
421     $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
422     
423     if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
424     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
425     if (length($dev) or length($dir)) {
426         $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
427         $dir = vmspath($dir);
428     }
429     $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
430     "$dev$dir$file";
431 }
432
433 =item abs2rel (override)
434
435 Attempt to convert an absolute file specification to a relative specification.
436
437 =cut
438
439 sub abs2rel {
440     my $self = shift;
441     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
442         if ((grep m{/}, @_) && !(grep m{(?<!\^)[\[<:]}, @_));
443
444     my($path,$base) = @_;
445     $base = $self->_cwd() unless defined $base and length $base;
446
447     # If there is no device or directory syntax on $base, make sure it
448     # is treated as a directory.
449     $base = VMS::Filespec::vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};
450
451     for ($path, $base) { $_ = $self->rel2abs($_) }
452
453     # Are we even starting $path on the same (node::)device as $base?  Note that
454     # logical paths or nodename differences may be on the "same device" 
455     # but the comparison that ignores device differences so as to concatenate 
456     # [---] up directory specs is not even a good idea in cases where there is 
457     # a logical path difference between $path and $base nodename and/or device.
458     # Hence we fall back to returning the absolute $path spec
459     # if there is a case blind device (or node) difference of any sort
460     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
461     # (this module needs to run on non VMS platforms after all).
462     
463     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
464     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
465     return $path unless lc($path_volume) eq lc($base_volume);
466
467     # Now, remove all leading components that are the same
468     my @pathchunks = $self->splitdir( $path_directories );
469     my $pathchunks = @pathchunks;
470     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
471     my @basechunks = $self->splitdir( $base_directories );
472     my $basechunks = @basechunks;
473     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
474
475     while ( @pathchunks && 
476             @basechunks && 
477             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
478           ) {
479         shift @pathchunks ;
480         shift @basechunks ;
481     }
482
483     # @basechunks now contains the directories to climb out of,
484     # @pathchunks now has the directories to descend in to.
485     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
486       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
487     }
488     else {
489       $path_directories = join '.', @pathchunks;
490     }
491     $path_directories = '['.$path_directories.']';
492     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
493 }
494
495
496 =item rel2abs (override)
497
498 Return an absolute file specification from a relative one.
499
500 =cut
501
502 sub rel2abs {
503     my $self = shift ;
504     my ($path,$base ) = @_;
505     return undef unless defined $path;
506     if ($path =~ m/\//) {
507        $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
508                   ? vmspath($path)             # whether it's a directory
509                   : vmsify($path) );
510     }
511     $base = vmspath($base) if defined $base && $base =~ m/\//;
512
513     # Clean up and split up $path
514     if ( ! $self->file_name_is_absolute( $path ) ) {
515         # Figure out the effective $base and clean it up.
516         if ( !defined( $base ) || $base eq '' ) {
517             $base = $self->_cwd;
518         }
519         elsif ( ! $self->file_name_is_absolute( $base ) ) {
520             $base = $self->rel2abs( $base ) ;
521         }
522         else {
523             $base = $self->canonpath( $base ) ;
524         }
525
526         # Split up paths
527         my ( $path_directories, $path_file ) =
528             ($self->splitpath( $path ))[1,2] ;
529
530         my ( $base_volume, $base_directories ) =
531             $self->splitpath( $base ) ;
532
533         $path_directories = '' if $path_directories eq '[]' ||
534                                   $path_directories eq '<>';
535         my $sep = '' ;
536         $sep = '.'
537             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
538                  $path_directories =~ m{^[^.\[<]}s
539             ) ;
540         $base_directories = "$base_directories$sep$path_directories";
541         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
542
543         $path = $self->catpath( $base_volume, $base_directories, $path_file );
544    }
545
546     return $self->canonpath( $path ) ;
547 }
548
549
550 # eliminate_macros() and fixpath() are MakeMaker-specific methods
551 # which are used inside catfile() and catdir().  MakeMaker has its own
552 # copies as of 6.06_03 which are the canonical ones.  We leave these
553 # here, in peace, so that File::Spec continues to work with MakeMakers
554 # prior to 6.06_03.
555
556 # Please consider these two methods deprecated.  Do not patch them,
557 # patch the ones in ExtUtils::MM_VMS instead.
558 #
559 # Update:  MakeMaker 6.48 is still using these routines on VMS.
560 # so they need to be kept up to date with ExtUtils::MM_VMS.
561
562 sub eliminate_macros {
563     my($self,$path) = @_;
564     return '' unless (defined $path) && ($path ne '');
565     $self = {} unless ref $self;
566
567     if ($path =~ /\s/) {
568       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
569     }
570
571     my $npath = unixify($path);
572     # sometimes unixify will return a string with an off-by-one trailing null
573     $npath =~ s{\0$}{};
574
575     my($complex) = 0;
576     my($head,$macro,$tail);
577
578     # perform m##g in scalar context so it acts as an iterator
579     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
580         if (defined $self->{$2}) {
581             ($head,$macro,$tail) = ($1,$2,$3);
582             if (ref $self->{$macro}) {
583                 if (ref $self->{$macro} eq 'ARRAY') {
584                     $macro = join ' ', @{$self->{$macro}};
585                 }
586                 else {
587                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
588                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
589                     $macro = "\cB$macro\cB";
590                     $complex = 1;
591                 }
592             }
593             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
594             $npath = "$head$macro$tail";
595         }
596     }
597     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
598     $npath;
599 }
600
601 # Deprecated.  See the note above for eliminate_macros().
602
603 # Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
604 # in any directory specification, in order to avoid juxtaposing two
605 # VMS-syntax directories when MM[SK] is run.  Also expands expressions which
606 # are all macro, so that we can tell how long the expansion is, and avoid
607 # overrunning DCL's command buffer when MM[KS] is running.
608
609 # fixpath() checks to see whether the result matches the name of a
610 # directory in the current default directory and returns a directory or
611 # file specification accordingly.  C<$is_dir> can be set to true to
612 # force fixpath() to consider the path to be a directory or false to force
613 # it to be a file.
614
615 sub fixpath {
616     my($self,$path,$force_path) = @_;
617     return '' unless $path;
618     $self = bless {}, $self unless ref $self;
619     my($fixedpath,$prefix,$name);
620
621     if ($path =~ /\s/) {
622       return join ' ',
623              map { $self->fixpath($_,$force_path) }
624              split /\s+/, $path;
625     }
626
627     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
628         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
629             $fixedpath = vmspath($self->eliminate_macros($path));
630         }
631         else {
632             $fixedpath = vmsify($self->eliminate_macros($path));
633         }
634     }
635     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
636         my($vmspre) = $self->eliminate_macros("\$($prefix)");
637         # is it a dir or just a name?
638         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
639         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
640         $fixedpath = vmspath($fixedpath) if $force_path;
641     }
642     else {
643         $fixedpath = $path;
644         $fixedpath = vmspath($fixedpath) if $force_path;
645     }
646     # No hints, so we try to guess
647     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
648         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
649     }
650
651     # Trim off root dirname if it's had other dirs inserted in front of it.
652     $fixedpath =~ s/\.000000([\]>])/$1/;
653     # Special case for VMS absolute directory specs: these will have had device
654     # prepended during trip through Unix syntax in eliminate_macros(), since
655     # Unix syntax has no way to express "absolute from the top of this device's
656     # directory tree".
657     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
658     $fixedpath;
659 }
660
661
662 =back
663
664 =head1 COPYRIGHT
665
666 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
667
668 This program is free software; you can redistribute it and/or modify
669 it under the same terms as Perl itself.
670
671 =head1 SEE ALSO
672
673 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
674 implementation of these methods, not the semantics.
675
676 An explanation of VMS file specs can be found at
677 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
678
679 =cut
680
681 1;