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