This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
speed up building with less disk IO pod moves+__END__+misc
[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.51';
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 ? $file : vmsify($file);
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{/}, @_;
443
444     my($path,$base) = @_;
445     $base = $self->_cwd() unless defined $base and length $base;
446
447     for ($path, $base) { $_ = $self->canonpath($_) }
448
449     # Are we even starting $path on the same (node::)device as $base?  Note that
450     # logical paths or nodename differences may be on the "same device" 
451     # but the comparison that ignores device differences so as to concatenate 
452     # [---] up directory specs is not even a good idea in cases where there is 
453     # a logical path difference between $path and $base nodename and/or device.
454     # Hence we fall back to returning the absolute $path spec
455     # if there is a case blind device (or node) difference of any sort
456     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
457     # (this module needs to run on non VMS platforms after all).
458     
459     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
460     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
461     return $path unless lc($path_volume) eq lc($base_volume);
462
463     for ($path, $base) { $_ = $self->rel2abs($_) }
464
465     # Now, remove all leading components that are the same
466     my @pathchunks = $self->splitdir( $path_directories );
467     my $pathchunks = @pathchunks;
468     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
469     my @basechunks = $self->splitdir( $base_directories );
470     my $basechunks = @basechunks;
471     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
472
473     while ( @pathchunks && 
474             @basechunks && 
475             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
476           ) {
477         shift @pathchunks ;
478         shift @basechunks ;
479     }
480
481     # @basechunks now contains the directories to climb out of,
482     # @pathchunks now has the directories to descend in to.
483     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
484       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
485     }
486     else {
487       $path_directories = join '.', @pathchunks;
488     }
489     $path_directories = '['.$path_directories.']';
490     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
491 }
492
493
494 =item rel2abs (override)
495
496 Return an absolute file specification from a relative one.
497
498 =cut
499
500 sub rel2abs {
501     my $self = shift ;
502     my ($path,$base ) = @_;
503     return undef unless defined $path;
504     if ($path =~ m/\//) {
505        $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
506                   ? vmspath($path)             # whether it's a directory
507                   : vmsify($path) );
508     }
509     $base = vmspath($base) if defined $base && $base =~ m/\//;
510
511     # Clean up and split up $path
512     if ( ! $self->file_name_is_absolute( $path ) ) {
513         # Figure out the effective $base and clean it up.
514         if ( !defined( $base ) || $base eq '' ) {
515             $base = $self->_cwd;
516         }
517         elsif ( ! $self->file_name_is_absolute( $base ) ) {
518             $base = $self->rel2abs( $base ) ;
519         }
520         else {
521             $base = $self->canonpath( $base ) ;
522         }
523
524         # Split up paths
525         my ( $path_directories, $path_file ) =
526             ($self->splitpath( $path ))[1,2] ;
527
528         my ( $base_volume, $base_directories ) =
529             $self->splitpath( $base ) ;
530
531         $path_directories = '' if $path_directories eq '[]' ||
532                                   $path_directories eq '<>';
533         my $sep = '' ;
534         $sep = '.'
535             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
536                  $path_directories =~ m{^[^.\[<]}s
537             ) ;
538         $base_directories = "$base_directories$sep$path_directories";
539         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
540
541         $path = $self->catpath( $base_volume, $base_directories, $path_file );
542    }
543
544     return $self->canonpath( $path ) ;
545 }
546
547
548 # eliminate_macros() and fixpath() are MakeMaker-specific methods
549 # which are used inside catfile() and catdir().  MakeMaker has its own
550 # copies as of 6.06_03 which are the canonical ones.  We leave these
551 # here, in peace, so that File::Spec continues to work with MakeMakers
552 # prior to 6.06_03.
553
554 # Please consider these two methods deprecated.  Do not patch them,
555 # patch the ones in ExtUtils::MM_VMS instead.
556 #
557 # Update:  MakeMaker 6.48 is still using these routines on VMS.
558 # so they need to be kept up to date with ExtUtils::MM_VMS.
559
560 sub eliminate_macros {
561     my($self,$path) = @_;
562     return '' unless (defined $path) && ($path ne '');
563     $self = {} unless ref $self;
564
565     if ($path =~ /\s/) {
566       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
567     }
568
569     my $npath = unixify($path);
570     # sometimes unixify will return a string with an off-by-one trailing null
571     $npath =~ s{\0$}{};
572
573     my($complex) = 0;
574     my($head,$macro,$tail);
575
576     # perform m##g in scalar context so it acts as an iterator
577     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
578         if (defined $self->{$2}) {
579             ($head,$macro,$tail) = ($1,$2,$3);
580             if (ref $self->{$macro}) {
581                 if (ref $self->{$macro} eq 'ARRAY') {
582                     $macro = join ' ', @{$self->{$macro}};
583                 }
584                 else {
585                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
586                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
587                     $macro = "\cB$macro\cB";
588                     $complex = 1;
589                 }
590             }
591             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
592             $npath = "$head$macro$tail";
593         }
594     }
595     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
596     $npath;
597 }
598
599 # Deprecated.  See the note above for eliminate_macros().
600
601 # Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
602 # in any directory specification, in order to avoid juxtaposing two
603 # VMS-syntax directories when MM[SK] is run.  Also expands expressions which
604 # are all macro, so that we can tell how long the expansion is, and avoid
605 # overrunning DCL's command buffer when MM[KS] is running.
606
607 # fixpath() checks to see whether the result matches the name of a
608 # directory in the current default directory and returns a directory or
609 # file specification accordingly.  C<$is_dir> can be set to true to
610 # force fixpath() to consider the path to be a directory or false to force
611 # it to be a file.
612
613 sub fixpath {
614     my($self,$path,$force_path) = @_;
615     return '' unless $path;
616     $self = bless {}, $self unless ref $self;
617     my($fixedpath,$prefix,$name);
618
619     if ($path =~ /\s/) {
620       return join ' ',
621              map { $self->fixpath($_,$force_path) }
622              split /\s+/, $path;
623     }
624
625     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
626         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
627             $fixedpath = vmspath($self->eliminate_macros($path));
628         }
629         else {
630             $fixedpath = vmsify($self->eliminate_macros($path));
631         }
632     }
633     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
634         my($vmspre) = $self->eliminate_macros("\$($prefix)");
635         # is it a dir or just a name?
636         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
637         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
638         $fixedpath = vmspath($fixedpath) if $force_path;
639     }
640     else {
641         $fixedpath = $path;
642         $fixedpath = vmspath($fixedpath) if $force_path;
643     }
644     # No hints, so we try to guess
645     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
646         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
647     }
648
649     # Trim off root dirname if it's had other dirs inserted in front of it.
650     $fixedpath =~ s/\.000000([\]>])/$1/;
651     # Special case for VMS absolute directory specs: these will have had device
652     # prepended during trip through Unix syntax in eliminate_macros(), since
653     # Unix syntax has no way to express "absolute from the top of this device's
654     # directory tree".
655     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
656     $fixedpath;
657 }
658
659
660 =back
661
662 =head1 COPYRIGHT
663
664 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
665
666 This program is free software; you can redistribute it and/or modify
667 it under the same terms as Perl itself.
668
669 =head1 SEE ALSO
670
671 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
672 implementation of these methods, not the semantics.
673
674 An explanation of VMS file specs can be found at
675 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
676
677 =cut
678
679 1;