This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
File::Spec::Unix->tmpdir: Always return an absolute path
[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
e0580a69 7$VERSION = '3.45_01';
3d2a0adf 8$VERSION =~ tr/_//;
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
147 $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
148 $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
149
150 # Special case for VMS absolute directory specs: these will have
151 # had device prepended during trip through Unix syntax in
152 # eliminate_macros(), since Unix syntax has no way to express
153 # "absolute from the top of this device's directory tree".
154 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
ae5a807c 155
ae5a807c 156 } else {
13688ce5
CB
157 # Single directory. Return an empty string on null input; otherwise
158 # just return a canonical path.
ae5a807c 159
13688ce5
CB
160 if (not defined $dir or not length $dir) {
161 $rslt = '';
ae5a807c 162 } else {
13688ce5 163 $rslt = $unix_rpt ? $dir : vmspath($dir);
ae5a807c 164 }
270d1e39 165 }
099f76bb 166 return $self->canonpath($rslt);
270d1e39
GS
167}
168
9596c75c 169=item catfile (override)
270d1e39 170
ae5a807c
JM
171Concatenates a list of directory specifications with a filename specification
172to build a path.
270d1e39
GS
173
174=cut
175
176sub catfile {
ff235dd6 177 my $self = shift;
ae5a807c
JM
178 my $tfile = pop();
179 my $file = $self->canonpath($tfile);
ff235dd6
SP
180 my @files = grep {defined() && length()} @_;
181
ae5a807c
JM
182 my $unix_rpt = $self->_unix_rpt;
183
cbc7acb0 184 my $rslt;
270d1e39 185 if (@files) {
13688ce5 186 my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
cbc7acb0 187 my $spath = $path;
ae5a807c 188
13688ce5 189 # Something building a VMS path in pieces may try to pass a
ae5a807c
JM
190 # directory name in filename format, so normalize it.
191 $spath =~ s/\.dir\Z(?!\n)//i;
192
13688ce5
CB
193 # If the spath ends with a directory delimiter and the file is bare,
194 # then just concatenate them.
61196b43 195 if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
cbc7acb0 196 $rslt = "$spath$file";
ae5a807c 197 } else {
13688ce5
CB
198 $rslt = $self->eliminate_macros($spath);
199 $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
200 $rslt = vmsify($rslt) unless $unix_rpt;
cbc7acb0 201 }
270d1e39 202 }
ae5a807c
JM
203 else {
204 # Only passed a single file?
13688ce5 205 my $xfile = (defined($file) && length($file)) ? $file : '';
ae5a807c 206
13688ce5 207 $rslt = $unix_rpt ? $file : vmsify($file);
ae5a807c
JM
208 }
209 return $self->canonpath($rslt) unless $unix_rpt;
210
c4a6f826 211 # In Unix report mode, do not strip off redundant path information.
ae5a807c 212 return $rslt;
270d1e39
GS
213}
214
46726cbe 215
270d1e39
GS
216=item curdir (override)
217
ae5a807c 218Returns a string representation of the current directory: '[]' or '.'
270d1e39
GS
219
220=cut
221
222sub curdir {
ae5a807c
JM
223 my $self = shift @_;
224 return '.' if ($self->_unix_rpt);
270d1e39
GS
225 return '[]';
226}
227
99804bbb
GS
228=item devnull (override)
229
ae5a807c 230Returns a string representation of the null device: '_NLA0:' or '/dev/null'
99804bbb
GS
231
232=cut
233
234sub devnull {
ae5a807c
JM
235 my $self = shift @_;
236 return '/dev/null' if ($self->_unix_rpt);
cbc7acb0 237 return "_NLA0:";
99804bbb
GS
238}
239
270d1e39
GS
240=item rootdir (override)
241
cbc7acb0 242Returns a string representation of the root directory: 'SYS$DISK:[000000]'
ae5a807c 243or '/'
270d1e39
GS
244
245=cut
246
247sub rootdir {
ae5a807c
JM
248 my $self = shift @_;
249 if ($self->_unix_rpt) {
250 # Root may exist, try it first.
251 my $try = '/';
252 my ($dev1, $ino1) = stat('/');
253 my ($dev2, $ino2) = stat('.');
254
255 # Perl falls back to '.' if it can not determine '/'
256 if (($dev1 != $dev2) || ($ino1 != $ino2)) {
257 return $try;
258 }
259 # Fall back to UNIX format sys$disk.
260 return '/sys$disk/';
261 }
cbc7acb0
JD
262 return 'SYS$DISK:[000000]';
263}
264
265=item tmpdir (override)
266
267Returns a string representation of the first writable directory
268from the following list or '' if none are writable:
269
61196b43 270 /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
188ff3c1 271 sys$scratch:
cbc7acb0
JD
272 $ENV{TMPDIR}
273
1d0806cf 274If running under taint mode, and if $ENV{TMPDIR}
a384e9e1
RGS
275is tainted, it is not used.
276
cbc7acb0
JD
277=cut
278
cbc7acb0 279sub tmpdir {
ae5a807c 280 my $self = shift @_;
82730d4c 281 my $tmpdir = $self->_cached_tmpdir('TMPDIR');
cbc7acb0 282 return $tmpdir if defined $tmpdir;
ae5a807c
JM
283 if ($self->_unix_rpt) {
284 $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
ae5a807c 285 }
82730d4c
FC
286 else {
287 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
288 }
289 $self->_cache_tmpdir($tmpdir, 'TMPDIR');
270d1e39
GS
290}
291
292=item updir (override)
293
ae5a807c 294Returns a string representation of the parent directory: '[-]' or '..'
270d1e39
GS
295
296=cut
297
298sub updir {
ae5a807c
JM
299 my $self = shift @_;
300 return '..' if ($self->_unix_rpt);
270d1e39
GS
301 return '[-]';
302}
303
46726cbe
CB
304=item case_tolerant (override)
305
306VMS file specification syntax is case-tolerant.
307
308=cut
309
310sub case_tolerant {
311 return 1;
312}
313
270d1e39
GS
314=item path (override)
315
316Translate logical name DCL$PATH as a searchlist, rather than trying
317to C<split> string value of C<$ENV{'PATH'}>.
318
319=cut
320
321sub path {
cbc7acb0 322 my (@dirs,$dir,$i);
270d1e39 323 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
cbc7acb0 324 return @dirs;
270d1e39
GS
325}
326
327=item file_name_is_absolute (override)
328
329Checks for VMS directory spec as well as Unix separators.
330
331=cut
332
333sub file_name_is_absolute {
cbc7acb0 334 my ($self,$file) = @_;
270d1e39 335 # If it's a logical name, expand it.
ee8c7f54 336 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
1b1e14d3 337 return scalar($file =~ m!^/!s ||
cbc7acb0 338 $file =~ m![<\[][^.\-\]>]! ||
fc827b9c 339 $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
270d1e39
GS
340}
341
46726cbe
CB
342=item splitpath (override)
343
555bd962
BG
344 ($volume,$directories,$file) = File::Spec->splitpath( $path );
345 ($volume,$directories,$file) = File::Spec->splitpath( $path,
346 $no_file );
486bcc50
NC
347
348Passing a true value for C<$no_file> indicates that the path being
349split only contains directory components, even on systems where you
350can usually (when not supporting a foreign syntax) tell the difference
351between directories and files at a glance.
46726cbe
CB
352
353=cut
354
355sub splitpath {
486bcc50
NC
356 my($self,$path, $nofile) = @_;
357 my($dev,$dir,$file) = ('','','');
ae5a807c 358 my $vmsify_path = vmsify($path);
ae5a807c
JM
359
360 if ( $nofile ) {
486bcc50
NC
361 #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
362 #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
363 if( $vmsify_path =~ /(.*)\](.+)/ ){
364 $vmsify_path = $1.'.'.$2.']';
365 }
366 $vmsify_path =~ /(.+:)?(.*)/s;
367 $dir = defined $2 ? $2 : ''; # dir can be '0'
368 return ($1 || '',$dir,$file);
369 }
370 else {
371 $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
372 return ($1 || '',$2 || '',$3);
373 }
46726cbe
CB
374}
375
376=item splitdir (override)
377
ae5a807c 378Split a directory specification into the components.
46726cbe
CB
379
380=cut
381
382sub splitdir {
383 my($self,$dirspec) = @_;
13fbb5b1
JM
384 my @dirs = ();
385 return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
ae5a807c 386
13688ce5
CB
387 $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ]
388 $dirspec =~ s/(?<!\^)>/]/;
389 $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
390 $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
391 $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
392 $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
393 $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
bdc74e5c
CB
394 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
395 # That loop does the following
396 # with any amount of dashes:
397 # .--. ==> .-.-.
398 # [--. ==> [-.-.
399 # .--] ==> .-.-]
400 # [--] ==> [-.-]
61196b43 401 $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
2e74f398 402 $dirspec =~ s/^(\[|<)\./$1/;
13fbb5b1 403 @dirs = split /(?<!\^)\./, vmspath($dirspec);
ee8c7f54 404 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
46726cbe
CB
405 @dirs;
406}
407
408
409=item catpath (override)
410
ae5a807c 411Construct a complete filespec.
46726cbe
CB
412
413=cut
414
415sub catpath {
416 my($self,$dev,$dir,$file) = @_;
638113eb
JH
417
418 # We look for a volume in $dev, then in $dir, but not both
13688ce5
CB
419 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
420 $dev = $dir_volume unless length $dev;
421 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
422
423 if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
ee8c7f54 424 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
fd7385b9 425 if (length($dev) or length($dir)) {
13688ce5
CB
426 $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
427 $dir = vmspath($dir);
0994714a 428 }
385aae1c 429 $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
fd7385b9 430 "$dev$dir$file";
0994714a
GS
431}
432
fd7385b9 433=item abs2rel (override)
0994714a 434
13688ce5 435Attempt to convert an absolute file specification to a relative specification.
0994714a
GS
436
437=cut
438
0994714a
GS
439sub abs2rel {
440 my $self = shift;
13688ce5
CB
441 return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
442 if grep m{/}, @_;
ae5a807c 443
13688ce5
CB
444 my($path,$base) = @_;
445 $base = $self->_cwd() unless defined $base and length $base;
0994714a 446
638113eb 447 for ($path, $base) { $_ = $self->canonpath($_) }
0994714a 448
d84c672d
JH
449 # Are we even starting $path on the same (node::)device as $base? Note that
450 # logical paths or nodename differences may be on the "same device"
451 # but the comparison that ignores device differences so as to concatenate
452 # [---] up directory specs is not even a good idea in cases where there is
453 # a logical path difference between $path and $base nodename and/or device.
454 # Hence we fall back to returning the absolute $path spec
455 # if there is a case blind device (or node) difference of any sort
456 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
457 # (this module needs to run on non VMS platforms after all).
638113eb
JH
458
459 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
460 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
461 return $path unless lc($path_volume) eq lc($base_volume);
d84c672d 462
638113eb 463 for ($path, $base) { $_ = $self->rel2abs($_) }
0994714a
GS
464
465 # Now, remove all leading components that are the same
466 my @pathchunks = $self->splitdir( $path_directories );
fa52125f 467 my $pathchunks = @pathchunks;
737c380e 468 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
0994714a 469 my @basechunks = $self->splitdir( $base_directories );
fa52125f 470 my $basechunks = @basechunks;
737c380e 471 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
0994714a
GS
472
473 while ( @pathchunks &&
474 @basechunks &&
475 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
476 ) {
477 shift @pathchunks ;
478 shift @basechunks ;
479 }
480
481 # @basechunks now contains the directories to climb out of,
482 # @pathchunks now has the directories to descend in to.
fa52125f
SP
483 if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
484 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
485 }
486 else {
487 $path_directories = join '.', @pathchunks;
488 }
489 $path_directories = '['.$path_directories.']';
fd7385b9 490 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
0994714a
GS
491}
492
493
fd7385b9
CB
494=item rel2abs (override)
495
ae5a807c 496Return an absolute file specification from a relative one.
fd7385b9
CB
497
498=cut
499
786b702f 500sub rel2abs {
0994714a 501 my $self = shift ;
0994714a 502 my ($path,$base ) = @_;
bdc74e5c 503 return undef unless defined $path;
13688ce5
CB
504 if ($path =~ m/\//) {
505 $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
506 ? vmspath($path) # whether it's a directory
507 : vmsify($path) );
ae5a807c 508 }
13688ce5 509 $base = vmspath($base) if defined $base && $base =~ m/\//;
ae5a807c 510
0994714a
GS
511 # Clean up and split up $path
512 if ( ! $self->file_name_is_absolute( $path ) ) {
513 # Figure out the effective $base and clean it up.
514 if ( !defined( $base ) || $base eq '' ) {
0fab864c 515 $base = $self->_cwd;
0994714a
GS
516 }
517 elsif ( ! $self->file_name_is_absolute( $base ) ) {
518 $base = $self->rel2abs( $base ) ;
519 }
520 else {
521 $base = $self->canonpath( $base ) ;
522 }
523
524 # Split up paths
ee8c7f54
CB
525 my ( $path_directories, $path_file ) =
526 ($self->splitpath( $path ))[1,2] ;
0994714a 527
ee8c7f54 528 my ( $base_volume, $base_directories ) =
0994714a
GS
529 $self->splitpath( $base ) ;
530
fd7385b9
CB
531 $path_directories = '' if $path_directories eq '[]' ||
532 $path_directories eq '<>';
0994714a 533 my $sep = '' ;
13688ce5
CB
534 $sep = '.'
535 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
536 $path_directories =~ m{^[^.\[<]}s
537 ) ;
538 $base_directories = "$base_directories$sep$path_directories";
539 $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
0994714a
GS
540
541 $path = $self->catpath( $base_volume, $base_directories, $path_file );
542 }
543
544 return $self->canonpath( $path ) ;
545}
546
547
9596c75c
RGS
548# eliminate_macros() and fixpath() are MakeMaker-specific methods
549# which are used inside catfile() and catdir(). MakeMaker has its own
550# copies as of 6.06_03 which are the canonical ones. We leave these
551# here, in peace, so that File::Spec continues to work with MakeMakers
552# prior to 6.06_03.
553#
554# Please consider these two methods deprecated. Do not patch them,
555# patch the ones in ExtUtils::MM_VMS instead.
ae5a807c
JM
556#
557# Update: MakeMaker 6.48 is still using these routines on VMS.
558# so they need to be kept up to date with ExtUtils::MM_VMS.
ae5a807c 559
9596c75c
RGS
560sub eliminate_macros {
561 my($self,$path) = @_;
ff235dd6 562 return '' unless (defined $path) && ($path ne '');
9596c75c
RGS
563 $self = {} unless ref $self;
564
565 if ($path =~ /\s/) {
566 return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
567 }
568
ae5a807c
JM
569 my $npath = unixify($path);
570 # sometimes unixify will return a string with an off-by-one trailing null
571 $npath =~ s{\0$}{};
572
9596c75c
RGS
573 my($complex) = 0;
574 my($head,$macro,$tail);
575
576 # perform m##g in scalar context so it acts as an iterator
577 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
ae5a807c 578 if (defined $self->{$2}) {
9596c75c
RGS
579 ($head,$macro,$tail) = ($1,$2,$3);
580 if (ref $self->{$macro}) {
581 if (ref $self->{$macro} eq 'ARRAY') {
582 $macro = join ' ', @{$self->{$macro}};
583 }
584 else {
585 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
586 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
587 $macro = "\cB$macro\cB";
588 $complex = 1;
589 }
590 }
591 else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
592 $npath = "$head$macro$tail";
593 }
594 }
595 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
596 $npath;
597}
598
599# Deprecated. See the note above for eliminate_macros().
ae5a807c
JM
600
601# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
602# in any directory specification, in order to avoid juxtaposing two
603# VMS-syntax directories when MM[SK] is run. Also expands expressions which
604# are all macro, so that we can tell how long the expansion is, and avoid
605# overrunning DCL's command buffer when MM[KS] is running.
606
607# fixpath() checks to see whether the result matches the name of a
608# directory in the current default directory and returns a directory or
609# file specification accordingly. C<$is_dir> can be set to true to
610# force fixpath() to consider the path to be a directory or false to force
611# it to be a file.
612
9596c75c
RGS
613sub fixpath {
614 my($self,$path,$force_path) = @_;
615 return '' unless $path;
486bcc50 616 $self = bless {}, $self unless ref $self;
9596c75c
RGS
617 my($fixedpath,$prefix,$name);
618
619 if ($path =~ /\s/) {
620 return join ' ',
621 map { $self->fixpath($_,$force_path) }
622 split /\s+/, $path;
623 }
624
625 if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
626 if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
627 $fixedpath = vmspath($self->eliminate_macros($path));
628 }
629 else {
630 $fixedpath = vmsify($self->eliminate_macros($path));
631 }
632 }
633 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
634 my($vmspre) = $self->eliminate_macros("\$($prefix)");
635 # is it a dir or just a name?
636 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
637 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
638 $fixedpath = vmspath($fixedpath) if $force_path;
639 }
640 else {
641 $fixedpath = $path;
642 $fixedpath = vmspath($fixedpath) if $force_path;
643 }
644 # No hints, so we try to guess
645 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
646 $fixedpath = vmspath($fixedpath) if -d $fixedpath;
647 }
648
649 # Trim off root dirname if it's had other dirs inserted in front of it.
650 $fixedpath =~ s/\.000000([\]>])/$1/;
651 # Special case for VMS absolute directory specs: these will have had device
652 # prepended during trip through Unix syntax in eliminate_macros(), since
653 # Unix syntax has no way to express "absolute from the top of this device's
654 # directory tree".
655 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
656 $fixedpath;
657}
658
659
cbc7acb0 660=back
270d1e39 661
99f36a73
RGS
662=head1 COPYRIGHT
663
664Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
665
666This program is free software; you can redistribute it and/or modify
667it under the same terms as Perl itself.
668
cbc7acb0
JD
669=head1 SEE ALSO
670
72f15715
T
671See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
672implementation of these methods, not the semantics.
cbc7acb0 673
638113eb 674An explanation of VMS file specs can be found at
385aae1c 675L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
638113eb 676
cbc7acb0
JD
677=cut
678
6791;