1 | package File::Spec::VMS;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use vars qw(@ISA $VERSION);
|
---|
5 | require File::Spec::Unix;
|
---|
6 |
|
---|
7 | $VERSION = '1.4';
|
---|
8 |
|
---|
9 | @ISA = qw(File::Spec::Unix);
|
---|
10 |
|
---|
11 | use File::Basename;
|
---|
12 | use VMS::Filespec;
|
---|
13 |
|
---|
14 | =head1 NAME
|
---|
15 |
|
---|
16 | File::Spec::VMS - methods for VMS file specs
|
---|
17 |
|
---|
18 | =head1 SYNOPSIS
|
---|
19 |
|
---|
20 | require File::Spec::VMS; # Done internally by File::Spec if needed
|
---|
21 |
|
---|
22 | =head1 DESCRIPTION
|
---|
23 |
|
---|
24 | See File::Spec::Unix for a documentation of the methods provided
|
---|
25 | there. This package overrides the implementation of these methods, not
|
---|
26 | the semantics.
|
---|
27 |
|
---|
28 | =over 4
|
---|
29 |
|
---|
30 | =item canonpath (override)
|
---|
31 |
|
---|
32 | Removes redundant portions of file specifications according to VMS syntax.
|
---|
33 |
|
---|
34 | =cut
|
---|
35 |
|
---|
36 | sub canonpath {
|
---|
37 | my($self,$path) = @_;
|
---|
38 |
|
---|
39 | if ($path =~ m|/|) { # Fake Unix
|
---|
40 | my $pathify = $path =~ m|/\Z(?!\n)|;
|
---|
41 | $path = $self->SUPER::canonpath($path);
|
---|
42 | if ($pathify) { return vmspath($path); }
|
---|
43 | else { return vmsify($path); }
|
---|
44 | }
|
---|
45 | else {
|
---|
46 | $path =~ tr/<>/[]/; # < and > ==> [ and ]
|
---|
47 | $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
|
---|
48 | $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
|
---|
49 | $path =~ s/\[000000\./\[/g; # [000000. ==> [
|
---|
50 | $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
|
---|
51 | $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
|
---|
52 | 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
|
---|
53 | # That loop does the following
|
---|
54 | # with any amount of dashes:
|
---|
55 | # .-.-. ==> .--.
|
---|
56 | # [-.-. ==> [--.
|
---|
57 | # .-.-] ==> .--]
|
---|
58 | # [-.-] ==> [--]
|
---|
59 | 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
|
---|
60 | # That loop does the following
|
---|
61 | # with any amount (minimum 2)
|
---|
62 | # of dashes:
|
---|
63 | # .foo.--. ==> .-.
|
---|
64 | # .foo.--] ==> .-]
|
---|
65 | # [foo.--. ==> [-.
|
---|
66 | # [foo.--] ==> [-]
|
---|
67 | #
|
---|
68 | # And then, the remaining cases
|
---|
69 | $path =~ s/\[\.-/[-/; # [.- ==> [-
|
---|
70 | $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
|
---|
71 | $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
|
---|
72 | $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
|
---|
73 | $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
|
---|
74 | $path =~ s/\[\]//; # [] ==>
|
---|
75 | return $path;
|
---|
76 | }
|
---|
77 | }
|
---|
78 |
|
---|
79 | =item catdir (override)
|
---|
80 |
|
---|
81 | Concatenates a list of file specifications, and returns the result as a
|
---|
82 | VMS-syntax directory specification. No check is made for "impossible"
|
---|
83 | cases (e.g. elements other than the first being absolute filespecs).
|
---|
84 |
|
---|
85 | =cut
|
---|
86 |
|
---|
87 | sub catdir {
|
---|
88 | my ($self,@dirs) = @_;
|
---|
89 | my $dir = pop @dirs;
|
---|
90 | @dirs = grep($_,@dirs);
|
---|
91 | my $rslt;
|
---|
92 | if (@dirs) {
|
---|
93 | my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
|
---|
94 | my ($spath,$sdir) = ($path,$dir);
|
---|
95 | $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
|
---|
96 | $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
|
---|
97 | $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
|
---|
98 |
|
---|
99 | # Special case for VMS absolute directory specs: these will have had device
|
---|
100 | # prepended during trip through Unix syntax in eliminate_macros(), since
|
---|
101 | # Unix syntax has no way to express "absolute from the top of this device's
|
---|
102 | # directory tree".
|
---|
103 | if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
|
---|
104 | }
|
---|
105 | else {
|
---|
106 | if (not defined $dir or not length $dir) { $rslt = ''; }
|
---|
107 | elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }
|
---|
108 | else { $rslt = vmspath($dir); }
|
---|
109 | }
|
---|
110 | return $self->canonpath($rslt);
|
---|
111 | }
|
---|
112 |
|
---|
113 | =item catfile (override)
|
---|
114 |
|
---|
115 | Concatenates a list of file specifications, and returns the result as a
|
---|
116 | VMS-syntax file specification.
|
---|
117 |
|
---|
118 | =cut
|
---|
119 |
|
---|
120 | sub catfile {
|
---|
121 | my ($self,@files) = @_;
|
---|
122 | my $file = $self->canonpath(pop @files);
|
---|
123 | @files = grep($_,@files);
|
---|
124 | my $rslt;
|
---|
125 | if (@files) {
|
---|
126 | my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
|
---|
127 | my $spath = $path;
|
---|
128 | $spath =~ s/\.dir\Z(?!\n)//;
|
---|
129 | if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
|
---|
130 | $rslt = "$spath$file";
|
---|
131 | }
|
---|
132 | else {
|
---|
133 | $rslt = $self->eliminate_macros($spath);
|
---|
134 | $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
|
---|
135 | }
|
---|
136 | }
|
---|
137 | else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
|
---|
138 | return $self->canonpath($rslt);
|
---|
139 | }
|
---|
140 |
|
---|
141 |
|
---|
142 | =item curdir (override)
|
---|
143 |
|
---|
144 | Returns a string representation of the current directory: '[]'
|
---|
145 |
|
---|
146 | =cut
|
---|
147 |
|
---|
148 | sub curdir {
|
---|
149 | return '[]';
|
---|
150 | }
|
---|
151 |
|
---|
152 | =item devnull (override)
|
---|
153 |
|
---|
154 | Returns a string representation of the null device: '_NLA0:'
|
---|
155 |
|
---|
156 | =cut
|
---|
157 |
|
---|
158 | sub devnull {
|
---|
159 | return "_NLA0:";
|
---|
160 | }
|
---|
161 |
|
---|
162 | =item rootdir (override)
|
---|
163 |
|
---|
164 | Returns a string representation of the root directory: 'SYS$DISK:[000000]'
|
---|
165 |
|
---|
166 | =cut
|
---|
167 |
|
---|
168 | sub rootdir {
|
---|
169 | return 'SYS$DISK:[000000]';
|
---|
170 | }
|
---|
171 |
|
---|
172 | =item tmpdir (override)
|
---|
173 |
|
---|
174 | Returns a string representation of the first writable directory
|
---|
175 | from the following list or '' if none are writable:
|
---|
176 |
|
---|
177 | sys$scratch:
|
---|
178 | $ENV{TMPDIR}
|
---|
179 |
|
---|
180 | Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
|
---|
181 | is tainted, it is not used.
|
---|
182 |
|
---|
183 | =cut
|
---|
184 |
|
---|
185 | my $tmpdir;
|
---|
186 | sub tmpdir {
|
---|
187 | return $tmpdir if defined $tmpdir;
|
---|
188 | $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
|
---|
189 | }
|
---|
190 |
|
---|
191 | =item updir (override)
|
---|
192 |
|
---|
193 | Returns a string representation of the parent directory: '[-]'
|
---|
194 |
|
---|
195 | =cut
|
---|
196 |
|
---|
197 | sub updir {
|
---|
198 | return '[-]';
|
---|
199 | }
|
---|
200 |
|
---|
201 | =item case_tolerant (override)
|
---|
202 |
|
---|
203 | VMS file specification syntax is case-tolerant.
|
---|
204 |
|
---|
205 | =cut
|
---|
206 |
|
---|
207 | sub case_tolerant {
|
---|
208 | return 1;
|
---|
209 | }
|
---|
210 |
|
---|
211 | =item path (override)
|
---|
212 |
|
---|
213 | Translate logical name DCL$PATH as a searchlist, rather than trying
|
---|
214 | to C<split> string value of C<$ENV{'PATH'}>.
|
---|
215 |
|
---|
216 | =cut
|
---|
217 |
|
---|
218 | sub path {
|
---|
219 | my (@dirs,$dir,$i);
|
---|
220 | while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
|
---|
221 | return @dirs;
|
---|
222 | }
|
---|
223 |
|
---|
224 | =item file_name_is_absolute (override)
|
---|
225 |
|
---|
226 | Checks for VMS directory spec as well as Unix separators.
|
---|
227 |
|
---|
228 | =cut
|
---|
229 |
|
---|
230 | sub file_name_is_absolute {
|
---|
231 | my ($self,$file) = @_;
|
---|
232 | # If it's a logical name, expand it.
|
---|
233 | $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
|
---|
234 | return scalar($file =~ m!^/!s ||
|
---|
235 | $file =~ m![<\[][^.\-\]>]! ||
|
---|
236 | $file =~ /:[^<\[]/);
|
---|
237 | }
|
---|
238 |
|
---|
239 | =item splitpath (override)
|
---|
240 |
|
---|
241 | Splits using VMS syntax.
|
---|
242 |
|
---|
243 | =cut
|
---|
244 |
|
---|
245 | sub splitpath {
|
---|
246 | my($self,$path) = @_;
|
---|
247 | my($dev,$dir,$file) = ('','','');
|
---|
248 |
|
---|
249 | vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
|
---|
250 | return ($1 || '',$2 || '',$3);
|
---|
251 | }
|
---|
252 |
|
---|
253 | =item splitdir (override)
|
---|
254 |
|
---|
255 | Split dirspec using VMS syntax.
|
---|
256 |
|
---|
257 | =cut
|
---|
258 |
|
---|
259 | sub splitdir {
|
---|
260 | my($self,$dirspec) = @_;
|
---|
261 | $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
|
---|
262 | $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
|
---|
263 | $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
|
---|
264 | $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
|
---|
265 | $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
|
---|
266 | $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
|
---|
267 | while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
|
---|
268 | # That loop does the following
|
---|
269 | # with any amount of dashes:
|
---|
270 | # .--. ==> .-.-.
|
---|
271 | # [--. ==> [-.-.
|
---|
272 | # .--] ==> .-.-]
|
---|
273 | # [--] ==> [-.-]
|
---|
274 | $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
|
---|
275 | my(@dirs) = split('\.', vmspath($dirspec));
|
---|
276 | $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
|
---|
277 | @dirs;
|
---|
278 | }
|
---|
279 |
|
---|
280 |
|
---|
281 | =item catpath (override)
|
---|
282 |
|
---|
283 | Construct a complete filespec using VMS syntax
|
---|
284 |
|
---|
285 | =cut
|
---|
286 |
|
---|
287 | sub catpath {
|
---|
288 | my($self,$dev,$dir,$file) = @_;
|
---|
289 |
|
---|
290 | # We look for a volume in $dev, then in $dir, but not both
|
---|
291 | my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
|
---|
292 | $dev = $dir_volume unless length $dev;
|
---|
293 | $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
|
---|
294 |
|
---|
295 | if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
|
---|
296 | else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
|
---|
297 | if (length($dev) or length($dir)) {
|
---|
298 | $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
|
---|
299 | $dir = vmspath($dir);
|
---|
300 | }
|
---|
301 | "$dev$dir$file";
|
---|
302 | }
|
---|
303 |
|
---|
304 | =item abs2rel (override)
|
---|
305 |
|
---|
306 | Use VMS syntax when converting filespecs.
|
---|
307 |
|
---|
308 | =cut
|
---|
309 |
|
---|
310 | sub abs2rel {
|
---|
311 | my $self = shift;
|
---|
312 | return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
|
---|
313 | if grep m{/}, @_;
|
---|
314 |
|
---|
315 | my($path,$base) = @_;
|
---|
316 | $base = $self->_cwd() unless defined $base and length $base;
|
---|
317 |
|
---|
318 | for ($path, $base) { $_ = $self->canonpath($_) }
|
---|
319 |
|
---|
320 | # Are we even starting $path on the same (node::)device as $base? Note that
|
---|
321 | # logical paths or nodename differences may be on the "same device"
|
---|
322 | # but the comparison that ignores device differences so as to concatenate
|
---|
323 | # [---] up directory specs is not even a good idea in cases where there is
|
---|
324 | # a logical path difference between $path and $base nodename and/or device.
|
---|
325 | # Hence we fall back to returning the absolute $path spec
|
---|
326 | # if there is a case blind device (or node) difference of any sort
|
---|
327 | # and we do not even try to call $parse() or consult %ENV for $trnlnm()
|
---|
328 | # (this module needs to run on non VMS platforms after all).
|
---|
329 |
|
---|
330 | my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
|
---|
331 | my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
|
---|
332 | return $path unless lc($path_volume) eq lc($base_volume);
|
---|
333 |
|
---|
334 | for ($path, $base) { $_ = $self->rel2abs($_) }
|
---|
335 |
|
---|
336 | # Now, remove all leading components that are the same
|
---|
337 | my @pathchunks = $self->splitdir( $path_directories );
|
---|
338 | unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
|
---|
339 | my @basechunks = $self->splitdir( $base_directories );
|
---|
340 | unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
|
---|
341 |
|
---|
342 | while ( @pathchunks &&
|
---|
343 | @basechunks &&
|
---|
344 | lc( $pathchunks[0] ) eq lc( $basechunks[0] )
|
---|
345 | ) {
|
---|
346 | shift @pathchunks ;
|
---|
347 | shift @basechunks ;
|
---|
348 | }
|
---|
349 |
|
---|
350 | # @basechunks now contains the directories to climb out of,
|
---|
351 | # @pathchunks now has the directories to descend in to.
|
---|
352 | $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
|
---|
353 | return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
|
---|
354 | }
|
---|
355 |
|
---|
356 |
|
---|
357 | =item rel2abs (override)
|
---|
358 |
|
---|
359 | Use VMS syntax when converting filespecs.
|
---|
360 |
|
---|
361 | =cut
|
---|
362 |
|
---|
363 | sub rel2abs {
|
---|
364 | my $self = shift ;
|
---|
365 | my ($path,$base ) = @_;
|
---|
366 | return undef unless defined $path;
|
---|
367 | if ($path =~ m/\//) {
|
---|
368 | $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
|
---|
369 | ? vmspath($path) # whether it's a directory
|
---|
370 | : vmsify($path) );
|
---|
371 | }
|
---|
372 | $base = vmspath($base) if defined $base && $base =~ m/\//;
|
---|
373 | # Clean up and split up $path
|
---|
374 | if ( ! $self->file_name_is_absolute( $path ) ) {
|
---|
375 | # Figure out the effective $base and clean it up.
|
---|
376 | if ( !defined( $base ) || $base eq '' ) {
|
---|
377 | $base = $self->_cwd;
|
---|
378 | }
|
---|
379 | elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
---|
380 | $base = $self->rel2abs( $base ) ;
|
---|
381 | }
|
---|
382 | else {
|
---|
383 | $base = $self->canonpath( $base ) ;
|
---|
384 | }
|
---|
385 |
|
---|
386 | # Split up paths
|
---|
387 | my ( $path_directories, $path_file ) =
|
---|
388 | ($self->splitpath( $path ))[1,2] ;
|
---|
389 |
|
---|
390 | my ( $base_volume, $base_directories ) =
|
---|
391 | $self->splitpath( $base ) ;
|
---|
392 |
|
---|
393 | $path_directories = '' if $path_directories eq '[]' ||
|
---|
394 | $path_directories eq '<>';
|
---|
395 | my $sep = '' ;
|
---|
396 | $sep = '.'
|
---|
397 | if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
|
---|
398 | $path_directories =~ m{^[^.\[<]}s
|
---|
399 | ) ;
|
---|
400 | $base_directories = "$base_directories$sep$path_directories";
|
---|
401 | $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
|
---|
402 |
|
---|
403 | $path = $self->catpath( $base_volume, $base_directories, $path_file );
|
---|
404 | }
|
---|
405 |
|
---|
406 | return $self->canonpath( $path ) ;
|
---|
407 | }
|
---|
408 |
|
---|
409 |
|
---|
410 | # eliminate_macros() and fixpath() are MakeMaker-specific methods
|
---|
411 | # which are used inside catfile() and catdir(). MakeMaker has its own
|
---|
412 | # copies as of 6.06_03 which are the canonical ones. We leave these
|
---|
413 | # here, in peace, so that File::Spec continues to work with MakeMakers
|
---|
414 | # prior to 6.06_03.
|
---|
415 | #
|
---|
416 | # Please consider these two methods deprecated. Do not patch them,
|
---|
417 | # patch the ones in ExtUtils::MM_VMS instead.
|
---|
418 | sub eliminate_macros {
|
---|
419 | my($self,$path) = @_;
|
---|
420 | return '' unless $path;
|
---|
421 | $self = {} unless ref $self;
|
---|
422 |
|
---|
423 | if ($path =~ /\s/) {
|
---|
424 | return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
|
---|
425 | }
|
---|
426 |
|
---|
427 | my($npath) = unixify($path);
|
---|
428 | my($complex) = 0;
|
---|
429 | my($head,$macro,$tail);
|
---|
430 |
|
---|
431 | # perform m##g in scalar context so it acts as an iterator
|
---|
432 | while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
|
---|
433 | if ($self->{$2}) {
|
---|
434 | ($head,$macro,$tail) = ($1,$2,$3);
|
---|
435 | if (ref $self->{$macro}) {
|
---|
436 | if (ref $self->{$macro} eq 'ARRAY') {
|
---|
437 | $macro = join ' ', @{$self->{$macro}};
|
---|
438 | }
|
---|
439 | else {
|
---|
440 | print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
|
---|
441 | "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
|
---|
442 | $macro = "\cB$macro\cB";
|
---|
443 | $complex = 1;
|
---|
444 | }
|
---|
445 | }
|
---|
446 | else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
|
---|
447 | $npath = "$head$macro$tail";
|
---|
448 | }
|
---|
449 | }
|
---|
450 | if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
|
---|
451 | $npath;
|
---|
452 | }
|
---|
453 |
|
---|
454 | # Deprecated. See the note above for eliminate_macros().
|
---|
455 | sub fixpath {
|
---|
456 | my($self,$path,$force_path) = @_;
|
---|
457 | return '' unless $path;
|
---|
458 | $self = bless {} unless ref $self;
|
---|
459 | my($fixedpath,$prefix,$name);
|
---|
460 |
|
---|
461 | if ($path =~ /\s/) {
|
---|
462 | return join ' ',
|
---|
463 | map { $self->fixpath($_,$force_path) }
|
---|
464 | split /\s+/, $path;
|
---|
465 | }
|
---|
466 |
|
---|
467 | if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
|
---|
468 | if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
|
---|
469 | $fixedpath = vmspath($self->eliminate_macros($path));
|
---|
470 | }
|
---|
471 | else {
|
---|
472 | $fixedpath = vmsify($self->eliminate_macros($path));
|
---|
473 | }
|
---|
474 | }
|
---|
475 | elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
|
---|
476 | my($vmspre) = $self->eliminate_macros("\$($prefix)");
|
---|
477 | # is it a dir or just a name?
|
---|
478 | $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
|
---|
479 | $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
|
---|
480 | $fixedpath = vmspath($fixedpath) if $force_path;
|
---|
481 | }
|
---|
482 | else {
|
---|
483 | $fixedpath = $path;
|
---|
484 | $fixedpath = vmspath($fixedpath) if $force_path;
|
---|
485 | }
|
---|
486 | # No hints, so we try to guess
|
---|
487 | if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
|
---|
488 | $fixedpath = vmspath($fixedpath) if -d $fixedpath;
|
---|
489 | }
|
---|
490 |
|
---|
491 | # Trim off root dirname if it's had other dirs inserted in front of it.
|
---|
492 | $fixedpath =~ s/\.000000([\]>])/$1/;
|
---|
493 | # Special case for VMS absolute directory specs: these will have had device
|
---|
494 | # prepended during trip through Unix syntax in eliminate_macros(), since
|
---|
495 | # Unix syntax has no way to express "absolute from the top of this device's
|
---|
496 | # directory tree".
|
---|
497 | if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
|
---|
498 | $fixedpath;
|
---|
499 | }
|
---|
500 |
|
---|
501 |
|
---|
502 | =back
|
---|
503 |
|
---|
504 | =head1 COPYRIGHT
|
---|
505 |
|
---|
506 | Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
---|
507 |
|
---|
508 | This program is free software; you can redistribute it and/or modify
|
---|
509 | it under the same terms as Perl itself.
|
---|
510 |
|
---|
511 | =head1 SEE ALSO
|
---|
512 |
|
---|
513 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
---|
514 | implementation of these methods, not the semantics.
|
---|
515 |
|
---|
516 | An explanation of VMS file specs can be found at
|
---|
517 | L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
|
---|
518 |
|
---|
519 | =cut
|
---|
520 |
|
---|
521 | 1;
|
---|