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