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