This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
File::Spec::Epoc: Small pod clean-up
[perl5.git] / dist / Cwd / 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
2d3da5df 7$VERSION = '3.41';
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
a384e9e1
RGS
274Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
275is tainted, it is not used.
276
cbc7acb0
JD
277=cut
278
279my $tmpdir;
280sub tmpdir {
ae5a807c 281 my $self = shift @_;
cbc7acb0 282 return $tmpdir if defined $tmpdir;
ae5a807c
JM
283 if ($self->_unix_rpt) {
284 $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
285 return $tmpdir;
286 }
287
288 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{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
JD
337 $file =~ m![<\[][^.\-\]>]! ||
338 $file =~ /:[^<\[]/);
270d1e39
GS
339}
340
46726cbe
CB
341=item splitpath (override)
342
486bcc50 343 ($volume,$directories,$file) = File::Spec->splitpath( $path );
2f03b6be
FC
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
CB
440 return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
441 if grep m{/}, @_;
ae5a807c 442
13688ce5
CB
443 my($path,$base) = @_;
444 $base = $self->_cwd() unless defined $base and length $base;
0994714a 445
638113eb 446 for ($path, $base) { $_ = $self->canonpath($_) }
0994714a 447
d84c672d
JH
448 # Are we even starting $path on the same (node::)device as $base? Note that
449 # logical paths or nodename differences may be on the "same device"
450 # but the comparison that ignores device differences so as to concatenate
451 # [---] up directory specs is not even a good idea in cases where there is
452 # a logical path difference between $path and $base nodename and/or device.
453 # Hence we fall back to returning the absolute $path spec
454 # if there is a case blind device (or node) difference of any sort
455 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
456 # (this module needs to run on non VMS platforms after all).
638113eb
JH
457
458 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
459 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
460 return $path unless lc($path_volume) eq lc($base_volume);
d84c672d 461
638113eb 462 for ($path, $base) { $_ = $self->rel2abs($_) }
0994714a
GS
463
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
9596c75c
RGS
547# eliminate_macros() and fixpath() are MakeMaker-specific methods
548# which are used inside catfile() and catdir(). MakeMaker has its own
549# copies as of 6.06_03 which are the canonical ones. We leave these
550# here, in peace, so that File::Spec continues to work with MakeMakers
551# prior to 6.06_03.
552#
553# Please consider these two methods deprecated. Do not patch them,
554# patch the ones in ExtUtils::MM_VMS instead.
ae5a807c
JM
555#
556# Update: MakeMaker 6.48 is still using these routines on VMS.
557# so they need to be kept up to date with ExtUtils::MM_VMS.
ae5a807c 558
9596c75c
RGS
559sub eliminate_macros {
560 my($self,$path) = @_;
ff235dd6 561 return '' unless (defined $path) && ($path ne '');
9596c75c
RGS
562 $self = {} unless ref $self;
563
564 if ($path =~ /\s/) {
565 return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
566 }
567
ae5a807c
JM
568 my $npath = unixify($path);
569 # sometimes unixify will return a string with an off-by-one trailing null
570 $npath =~ s{\0$}{};
571
9596c75c
RGS
572 my($complex) = 0;
573 my($head,$macro,$tail);
574
575 # perform m##g in scalar context so it acts as an iterator
576 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
ae5a807c 577 if (defined $self->{$2}) {
9596c75c
RGS
578 ($head,$macro,$tail) = ($1,$2,$3);
579 if (ref $self->{$macro}) {
580 if (ref $self->{$macro} eq 'ARRAY') {
581 $macro = join ' ', @{$self->{$macro}};
582 }
583 else {
584 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
585 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
586 $macro = "\cB$macro\cB";
587 $complex = 1;
588 }
589 }
590 else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
591 $npath = "$head$macro$tail";
592 }
593 }
594 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
595 $npath;
596}
597
598# Deprecated. See the note above for eliminate_macros().
ae5a807c
JM
599
600# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
601# in any directory specification, in order to avoid juxtaposing two
602# VMS-syntax directories when MM[SK] is run. Also expands expressions which
603# are all macro, so that we can tell how long the expansion is, and avoid
604# overrunning DCL's command buffer when MM[KS] is running.
605
606# fixpath() checks to see whether the result matches the name of a
607# directory in the current default directory and returns a directory or
608# file specification accordingly. C<$is_dir> can be set to true to
609# force fixpath() to consider the path to be a directory or false to force
610# it to be a file.
611
9596c75c
RGS
612sub fixpath {
613 my($self,$path,$force_path) = @_;
614 return '' unless $path;
486bcc50 615 $self = bless {}, $self unless ref $self;
9596c75c
RGS
616 my($fixedpath,$prefix,$name);
617
618 if ($path =~ /\s/) {
619 return join ' ',
620 map { $self->fixpath($_,$force_path) }
621 split /\s+/, $path;
622 }
623
624 if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
625 if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
626 $fixedpath = vmspath($self->eliminate_macros($path));
627 }
628 else {
629 $fixedpath = vmsify($self->eliminate_macros($path));
630 }
631 }
632 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
633 my($vmspre) = $self->eliminate_macros("\$($prefix)");
634 # is it a dir or just a name?
635 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
636 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
637 $fixedpath = vmspath($fixedpath) if $force_path;
638 }
639 else {
640 $fixedpath = $path;
641 $fixedpath = vmspath($fixedpath) if $force_path;
642 }
643 # No hints, so we try to guess
644 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
645 $fixedpath = vmspath($fixedpath) if -d $fixedpath;
646 }
647
648 # Trim off root dirname if it's had other dirs inserted in front of it.
649 $fixedpath =~ s/\.000000([\]>])/$1/;
650 # Special case for VMS absolute directory specs: these will have had device
651 # prepended during trip through Unix syntax in eliminate_macros(), since
652 # Unix syntax has no way to express "absolute from the top of this device's
653 # directory tree".
654 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
655 $fixedpath;
656}
657
658
cbc7acb0 659=back
270d1e39 660
99f36a73
RGS
661=head1 COPYRIGHT
662
663Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
664
665This program is free software; you can redistribute it and/or modify
666it under the same terms as Perl itself.
667
cbc7acb0
JD
668=head1 SEE ALSO
669
72f15715
T
670See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
671implementation of these methods, not the semantics.
cbc7acb0 672
638113eb 673An explanation of VMS file specs can be found at
385aae1c 674L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
638113eb 675
cbc7acb0
JD
676=cut
677
6781;