This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Suggestion from Slaven - reverse the part of 23348 that removed the
[perl5.git] / lib / File / Spec / VMS.pm
CommitLineData
270d1e39
GS
1package File::Spec::VMS;
2
cbc7acb0 3use strict;
ee8c7f54 4use vars qw(@ISA $VERSION);
cbc7acb0 5require File::Spec::Unix;
ee8c7f54 6
795ee885 7$VERSION = '3.2701';
ee8c7f54 8
270d1e39
GS
9@ISA = qw(File::Spec::Unix);
10
cbc7acb0
JD
11use File::Basename;
12use VMS::Filespec;
270d1e39
GS
13
14=head1 NAME
15
16File::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
24See File::Spec::Unix for a documentation of the methods provided
25there. This package overrides the implementation of these methods, not
26the semantics.
27
bbc7dcd2 28=over 4
a45bd81d 29
46726cbe
CB
30=item canonpath (override)
31
fd7385b9 32Removes redundant portions of file specifications according to VMS syntax.
46726cbe
CB
33
34=cut
35
36sub 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
83Concatenates a list of file specifications, and returns the result as a
46726cbe
CB
84VMS-syntax directory specification. No check is made for "impossible"
85cases (e.g. elements other than the first being absolute filespecs).
270d1e39
GS
86
87=cut
88
89sub 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
118Concatenates a list of file specifications, and returns the result as a
46726cbe 119VMS-syntax file specification.
270d1e39
GS
120
121=cut
122
123sub 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 148Returns a string representation of the current directory: '[]'
270d1e39
GS
149
150=cut
151
152sub curdir {
153 return '[]';
154}
155
99804bbb
GS
156=item devnull (override)
157
cbc7acb0 158Returns a string representation of the null device: '_NLA0:'
99804bbb
GS
159
160=cut
161
162sub devnull {
cbc7acb0 163 return "_NLA0:";
99804bbb
GS
164}
165
270d1e39
GS
166=item rootdir (override)
167
cbc7acb0 168Returns a string representation of the root directory: 'SYS$DISK:[000000]'
270d1e39
GS
169
170=cut
171
172sub rootdir {
cbc7acb0
JD
173 return 'SYS$DISK:[000000]';
174}
175
176=item tmpdir (override)
177
178Returns a string representation of the first writable directory
179from the following list or '' if none are writable:
180
188ff3c1 181 sys$scratch:
cbc7acb0
JD
182 $ENV{TMPDIR}
183
a384e9e1
RGS
184Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
185is tainted, it is not used.
186
cbc7acb0
JD
187=cut
188
189my $tmpdir;
190sub 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 197Returns a string representation of the parent directory: '[-]'
270d1e39
GS
198
199=cut
200
201sub updir {
202 return '[-]';
203}
204
46726cbe
CB
205=item case_tolerant (override)
206
207VMS file specification syntax is case-tolerant.
208
209=cut
210
211sub case_tolerant {
212 return 1;
213}
214
270d1e39
GS
215=item path (override)
216
217Translate logical name DCL$PATH as a searchlist, rather than trying
218to C<split> string value of C<$ENV{'PATH'}>.
219
220=cut
221
222sub 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
230Checks for VMS directory spec as well as Unix separators.
231
232=cut
233
234sub 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
245Splits using VMS syntax.
246
247=cut
248
249sub 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
259Split dirspec using VMS syntax.
260
261=cut
262
263sub 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
290Construct a complete filespec using VMS syntax
291
292=cut
293
294sub 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 313Use VMS syntax when converting filespecs.
0994714a
GS
314
315=cut
316
0994714a
GS
317sub 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
374Use VMS syntax when converting filespecs.
375
376=cut
377
786b702f 378sub 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.
433sub 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().
470sub 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
521Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
522
523This program is free software; you can redistribute it and/or modify
524it under the same terms as Perl itself.
525
cbc7acb0
JD
526=head1 SEE ALSO
527
72f15715
T
528See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
529implementation of these methods, not the semantics.
cbc7acb0 530
638113eb
JH
531An explanation of VMS file specs can be found at
532L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
533
cbc7acb0
JD
534=cut
535
5361;