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