Commit | Line | Data |
---|---|---|
920dae64 AT |
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; |