This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
There is no G_LIST, only G_ARRAY
[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
3d2a0adf
SM
7$VERSION = '3.39_01';
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
CB
29The default behavior is to allow either VMS or Unix syntax on input and to
30return VMS syntax on output, even when Unix syntax was given on input.
ae5a807c 31
385aae1c
CB
32When used with a Perl of version 5.10 or greater and a CRTL possessing the
33relevant capabilities, override behavior depends on the CRTL features
34C<DECC$FILENAME_UNIX_REPORT> and C<DECC$EFS_CHARSET>. When the
35C<DECC$EFS_CHARSET> feature is enabled and the input parameters are clearly
36in Unix syntax, the output will be in Unix syntax. If
37C<DECC$FILENAME_UNIX_REPORT> is enabled and the output syntax cannot be
38determined from the input syntax, the output will be in Unix syntax.
ae5a807c 39
bbc7dcd2 40=over 4
a45bd81d 41
ae5a807c
JM
42=cut
43
44# Need to look up the feature settings. The preferred way is to use the
45# VMS::Feature module, but that may not be available to dual life modules.
46
47my $use_feature;
48BEGIN {
49 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
50 $use_feature = 1;
51 }
52}
53
54# Need to look up the UNIX report mode. This may become a dynamic mode
55# in the future.
56sub _unix_rpt {
57 my $unix_rpt;
58 if ($use_feature) {
59 $unix_rpt = VMS::Feature::current("filename_unix_report");
60 } else {
61 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
62 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
63 }
64 return $unix_rpt;
65}
66
67# Need to look up the EFS character set mode. This may become a dynamic
68# mode in the future.
69sub _efs {
70 my $efs;
71 if ($use_feature) {
72 $efs = VMS::Feature::current("efs_charset");
73 } else {
74 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
75 $efs = $env_efs =~ /^[ET1]/i;
76 }
77 return $efs;
78}
79
46726cbe
CB
80=item canonpath (override)
81
ae5a807c
JM
82Removes redundant portions of file specifications according to the syntax
83detected.
46726cbe
CB
84
85=cut
86
ae5a807c 87
46726cbe 88sub canonpath {
fd7385b9 89 my($self,$path) = @_;
46726cbe 90
13fbb5b1
JM
91 return undef unless defined $path;
92
ae5a807c
JM
93 my $efs = $self->_efs;
94
46726cbe 95 if ($path =~ m|/|) { # Fake Unix
ee8c7f54 96 my $pathify = $path =~ m|/\Z(?!\n)|;
fd7385b9 97 $path = $self->SUPER::canonpath($path);
ae5a807c
JM
98
99 # Do not convert to VMS when EFS character sets are in use
100 return $path if $efs;
101
46726cbe
CB
102 if ($pathify) { return vmspath($path); }
103 else { return vmsify($path); }
104 }
105 else {
ae5a807c
JM
106
107#FIXME - efs parsing has different rules. Characters in a VMS filespec
108# are only delimiters if not preceded by '^';
109
bdc74e5c
CB
110 $path =~ tr/<>/[]/; # < and > ==> [ and ]
111 $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
112 $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
113 $path =~ s/\[000000\./\[/g; # [000000. ==> [
114 $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
115 $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
116 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
117 # That loop does the following
118 # with any amount of dashes:
119 # .-.-. ==> .--.
120 # [-.-. ==> [--.
121 # .-.-] ==> .--]
122 # [-.-] ==> [--]
123 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
124 # That loop does the following
125 # with any amount (minimum 2)
126 # of dashes:
127 # .foo.--. ==> .-.
128 # .foo.--] ==> .-]
129 # [foo.--. ==> [-.
130 # [foo.--] ==> [-]
131 #
132 # And then, the remaining cases
133 $path =~ s/\[\.-/[-/; # [.- ==> [-
134 $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
135 $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
136 $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
99f36a73 137 $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
fa52125f 138 $path =~ s/\[\]// unless $path eq '[]'; # [] ==>
bdc74e5c 139 return $path;
46726cbe
CB
140 }
141}
142
9596c75c 143=item catdir (override)
270d1e39
GS
144
145Concatenates a list of file specifications, and returns the result as a
ae5a807c 146directory specification. No check is made for "impossible"
46726cbe 147cases (e.g. elements other than the first being absolute filespecs).
270d1e39
GS
148
149=cut
150
151sub catdir {
ff235dd6
SP
152 my $self = shift;
153 my $dir = pop;
ae5a807c
JM
154
155 my $efs = $self->_efs;
156 my $unix_rpt = $self->_unix_rpt;
157
158
ff235dd6 159 my @dirs = grep {defined() && length()} @_;
ae5a807c
JM
160 if ($efs) {
161 # Legacy mode removes blank entries.
162 # But that breaks existing generic perl code that
163 # uses a blank path at the beginning of the array
164 # to indicate an absolute path.
165 # So put it back if found.
166 if (@_) {
167 if ($_[0] eq '') {
168 unshift @dirs, '';
169 }
170 }
171 }
ff235dd6 172
cbc7acb0 173 my $rslt;
270d1e39 174 if (@dirs) {
cbc7acb0
JD
175 my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
176 my ($spath,$sdir) = ($path,$dir);
ae5a807c
JM
177
178 if ($efs) {
179 # Extended character set in use, go into DWIM mode.
180
181 # Now we need to identify what the directory is in
182 # of the specification in order to merge them.
183 my $path_unix = 0;
184 $path_unix = 1 if ($path =~ m#/#);
185 $path_unix = 1 if ($path =~ /^\.\.?$/);
186 my $path_vms = 0;
61196b43 187 $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
188 $path_vms = 1 if ($path =~ /^--?$/);
189 my $dir_unix = 0;
190 $dir_unix = 1 if ($dir =~ m#/#);
191 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
192 my $dir_vms = 0;
61196b43 193 $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
194 $dir_vms = 1 if ($dir =~ /^--?$/);
195
196 my $unix_mode = 0;
197 if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) {
198 # Ambiguous, so if in $unix_rpt mode then assume UNIX.
199 $unix_mode = 1 if $unix_rpt;
200 } else {
201 $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt);
202 $unix_mode = 1 if ($path_unix || $dir_unix);
203 }
204
205 if ($unix_mode) {
206
c4a6f826 207 # Fix up mixed syntax input as good as possible - GIGO
ae5a807c
JM
208 $path = unixify($path) if $path_vms;
209 $dir = unixify($dir) if $dir_vms;
210
211 $rslt = $path;
212 # Append a path delimiter
213 $rslt .= '/' unless ($rslt =~ m#/$#);
214
215 $rslt .= $dir;
216 return $self->SUPER::canonpath($rslt);
217 } else {
218
c4a6f826 219 #with <> possible instead of [.
ae5a807c
JM
220 # Normalize the brackets
221 # Fixme - need to not switch when preceded by ^.
222 $path =~ s/</\[/g;
223 $path =~ s/>/\]/g;
224 $dir =~ s/</\[/g;
225 $dir =~ s/>/\]/g;
226
c4a6f826 227 # Fix up mixed syntax input as good as possible - GIGO
ae5a807c
JM
228 $path = vmsify($path) if $path_unix;
229 $dir = vmsify($dir) if $dir_unix;
230
231 #Possible path values: foo: [.foo] [foo] foo, and $(foo)
232 #or starting with '-', or foo.dir
233 #If path is foo, it needs to be converted to [.foo]
234
235 # Fix up a bare path name.
236 unless ($path_vms) {
237 $path =~ s/\.dir\Z(?!\n)//i;
238 if (($path ne '') && ($path !~ /^-/)) {
239 # Non blank and not prefixed with '-', add a dot
240 $path = '[.' . $path;
241 } else {
242 # Just start a directory.
243 $path = '[' . $path;
244 }
245 } else {
246 $path =~ s/\]$//;
247 }
248
249 #Possible dir values: [.dir] dir and $(foo)
250
251 # No punctuation may have a trailing .dir
252 unless ($dir_vms) {
253 $dir =~ s/\.dir\Z(?!\n)//i;
254 } else {
255
256 #strip off the brackets
257 $dir =~ s/^\[//;
258 $dir =~ s/\]$//;
259 }
260
261 #strip off the leading dot if present.
262 $dir =~ s/^\.//;
263
264 # Now put the specifications together.
265 if ($dir ne '') {
266 # Add a separator unless this is an absolute path
267 $path .= '.' if ($path ne '[');
268 $rslt = $path . $dir . ']';
269 } else {
270 $rslt = $path . ']';
271 }
272 }
273
274 } else {
275 # Traditional ODS-2 mode.
276 $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
277
278 $sdir = $self->eliminate_macros($sdir)
279 unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
280 $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
281
282 # Special case for VMS absolute directory specs: these will have
283 # had device prepended during trip through Unix syntax in
284 # eliminate_macros(), since Unix syntax has no way to express
285 # "absolute from the top of this device's directory tree".
286 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
287 }
288 } else {
289 # Single directory, just make sure it is in directory format
290 # Return an empty string on null input, and pass through macros.
291
fd7385b9 292 if (not defined $dir or not length $dir) { $rslt = ''; }
ae5a807c
JM
293 elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) {
294 $rslt = $dir;
295 } else {
296 my $unix_mode = 0;
297
298 if ($efs) {
299 my $dir_unix = 0;
300 $dir_unix = 1 if ($dir =~ m#/#);
301 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
302 my $dir_vms = 0;
61196b43 303 $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
304 $dir_vms = 1 if ($dir =~ /^--?$/);
305
306 if ($dir_vms == $dir_unix) {
307 # Ambiguous, so if in $unix_rpt mode then assume UNIX.
308 $unix_mode = 1 if $unix_rpt;
309 } else {
310 $unix_mode = 1 if $dir_unix;
311 }
312 }
313
314 if ($unix_mode) {
315 return $dir;
316 } else {
317 # For VMS, force it to be in directory format
318 $rslt = vmspath($dir);
319 }
320 }
270d1e39 321 }
099f76bb 322 return $self->canonpath($rslt);
270d1e39
GS
323}
324
9596c75c 325=item catfile (override)
270d1e39 326
ae5a807c
JM
327Concatenates a list of directory specifications with a filename specification
328to build a path.
270d1e39
GS
329
330=cut
331
332sub catfile {
ff235dd6 333 my $self = shift;
ae5a807c
JM
334 my $tfile = pop();
335 my $file = $self->canonpath($tfile);
ff235dd6
SP
336 my @files = grep {defined() && length()} @_;
337
ae5a807c
JM
338 my $efs = $self->_efs;
339 my $unix_rpt = $self->_unix_rpt;
340
341 # Assume VMS mode
342 my $unix_mode = 0;
343 my $file_unix = 0;
344 my $file_vms = 0;
345 if ($efs) {
346
347 # Now we need to identify format the file is in
348 # of the specification in order to merge them.
349 $file_unix = 1 if ($tfile =~ m#/#);
350 $file_unix = 1 if ($tfile =~ /^\.\.?$/);
61196b43 351 $file_vms = 1 if ($tfile =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
352 $file_vms = 1 if ($tfile =~ /^--?$/);
353
354 # We may know for sure what the format is.
355 if (($file_unix != $file_vms)) {
356 $unix_mode = 1 if ($file_unix && $unix_rpt);
357 }
358 }
359
cbc7acb0 360 my $rslt;
270d1e39 361 if (@files) {
ae5a807c
JM
362 # concatenate the directories.
363 my $path;
364 if (@files == 1) {
365 $path = $files[0];
366 } else {
367 if ($file_vms) {
368 # We need to make sure this is in VMS mode to avoid doing
369 # both a vmsify and unixfy on the same path, as that may
370 # lose significant data.
371 my $i = @files - 1;
372 my $tdir = $files[$i];
373 my $tdir_vms = 0;
374 my $tdir_unix = 0;
61196b43 375 $tdir_vms = 1 if ($tdir =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
376 $tdir_unix = 1 if ($tdir =~ m#/#);
377 $tdir_unix = 1 if ($tdir =~ /^\.\.?$/);
378
379 if (!$tdir_vms) {
380 if ($tdir_unix) {
381 $tdir = vmspath($tdir);
382 } else {
383 $tdir =~ s/\.dir\Z(?!\n)//i;
384 $tdir = '[.' . $tdir . ']';
385 }
386 $files[$i] = $tdir;
387 }
388 }
389 $path = $self->catdir(@files);
390 }
cbc7acb0 391 my $spath = $path;
ae5a807c
JM
392
393 # Some thing building a VMS path in pieces may try to pass a
394 # directory name in filename format, so normalize it.
395 $spath =~ s/\.dir\Z(?!\n)//i;
396
397 # if the spath ends with a directory delimiter and the file is bare,
398 # then just concat them.
61196b43 399 if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
cbc7acb0 400 $rslt = "$spath$file";
ae5a807c
JM
401 } else {
402 if ($efs) {
403
404 # Now we need to identify what the directory is in
405 # of the specification in order to merge them.
406 my $spath_unix = 0;
407 $spath_unix = 1 if ($spath =~ m#/#);
408 $spath_unix = 1 if ($spath =~ /^\.\.?$/);
409 my $spath_vms = 0;
61196b43 410 $spath_vms = 1 if ($spath =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
411 $spath_vms = 1 if ($spath =~ /^--?$/);
412
413 # Assume VMS mode
414 if (($spath_unix == $spath_vms) &&
415 ($file_unix == $file_vms)) {
c4a6f826 416 # Ambiguous, so if in $unix_rpt mode then assume UNIX.
ae5a807c
JM
417 $unix_mode = 1 if $unix_rpt;
418 } else {
419 $unix_mode = 1
420 if (($spath_unix || $file_unix) && $unix_rpt);
421 }
422
423 if (!$unix_mode) {
424 if ($spath_vms) {
425 $spath = '[' . $spath . ']' if $spath =~ /^-/;
426 $rslt = vmspath($spath);
427 } else {
428 $rslt = '[.' . $spath . ']';
429 }
430 $file = vmsify($file) if ($file_unix);
431 } else {
432 $spath = unixify($spath) if ($spath_vms);
433 $rslt = $spath;
434 $file = unixify($file) if ($file_vms);
435
c4a6f826 436 # Unix merge may need a directory delimiter.
ae5a807c
JM
437 # A null path indicates root on Unix.
438 $rslt .= '/' unless ($rslt =~ m#/$#);
439 }
440
441 $rslt .= $file;
442 $rslt =~ s/\]\[//;
443
444 } else {
445 # Traditional VMS Perl mode expects that this is done.
446 # Note for future maintainers:
447 # This is left here for compatibility with perl scripts
448 # that have come to expect this behavior, even though
449 # usually the Perl scripts ported to VMS have to be
450 # patched because of it changing Unix syntax file
451 # to VMS format.
452
453 $rslt = $self->eliminate_macros($spath);
454
455
456 $rslt = vmsify($rslt.((defined $rslt) &&
457 ($rslt ne '') ? '/' : '').unixify($file));
458 }
cbc7acb0 459 }
270d1e39 460 }
ae5a807c
JM
461 else {
462 # Only passed a single file?
463 my $xfile = $file;
464
465 # Traditional VMS perl expects this conversion.
466 $xfile = vmsify($file) unless ($efs);
467
468 $rslt = (defined($file) && length($file)) ? $xfile : '';
469 }
470 return $self->canonpath($rslt) unless $unix_rpt;
471
c4a6f826 472 # In Unix report mode, do not strip off redundant path information.
ae5a807c 473 return $rslt;
270d1e39
GS
474}
475
46726cbe 476
270d1e39
GS
477=item curdir (override)
478
ae5a807c 479Returns a string representation of the current directory: '[]' or '.'
270d1e39
GS
480
481=cut
482
483sub curdir {
ae5a807c
JM
484 my $self = shift @_;
485 return '.' if ($self->_unix_rpt);
270d1e39
GS
486 return '[]';
487}
488
99804bbb
GS
489=item devnull (override)
490
ae5a807c 491Returns a string representation of the null device: '_NLA0:' or '/dev/null'
99804bbb
GS
492
493=cut
494
495sub devnull {
ae5a807c
JM
496 my $self = shift @_;
497 return '/dev/null' if ($self->_unix_rpt);
cbc7acb0 498 return "_NLA0:";
99804bbb
GS
499}
500
270d1e39
GS
501=item rootdir (override)
502
cbc7acb0 503Returns a string representation of the root directory: 'SYS$DISK:[000000]'
ae5a807c 504or '/'
270d1e39
GS
505
506=cut
507
508sub rootdir {
ae5a807c
JM
509 my $self = shift @_;
510 if ($self->_unix_rpt) {
511 # Root may exist, try it first.
512 my $try = '/';
513 my ($dev1, $ino1) = stat('/');
514 my ($dev2, $ino2) = stat('.');
515
516 # Perl falls back to '.' if it can not determine '/'
517 if (($dev1 != $dev2) || ($ino1 != $ino2)) {
518 return $try;
519 }
520 # Fall back to UNIX format sys$disk.
521 return '/sys$disk/';
522 }
cbc7acb0
JD
523 return 'SYS$DISK:[000000]';
524}
525
526=item tmpdir (override)
527
528Returns a string representation of the first writable directory
529from the following list or '' if none are writable:
530
61196b43 531 /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
188ff3c1 532 sys$scratch:
cbc7acb0
JD
533 $ENV{TMPDIR}
534
a384e9e1
RGS
535Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
536is tainted, it is not used.
537
cbc7acb0
JD
538=cut
539
540my $tmpdir;
541sub tmpdir {
ae5a807c 542 my $self = shift @_;
cbc7acb0 543 return $tmpdir if defined $tmpdir;
ae5a807c
JM
544 if ($self->_unix_rpt) {
545 $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
546 return $tmpdir;
547 }
548
549 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
270d1e39
GS
550}
551
552=item updir (override)
553
ae5a807c 554Returns a string representation of the parent directory: '[-]' or '..'
270d1e39
GS
555
556=cut
557
558sub updir {
ae5a807c
JM
559 my $self = shift @_;
560 return '..' if ($self->_unix_rpt);
270d1e39
GS
561 return '[-]';
562}
563
46726cbe
CB
564=item case_tolerant (override)
565
566VMS file specification syntax is case-tolerant.
567
568=cut
569
570sub case_tolerant {
571 return 1;
572}
573
270d1e39
GS
574=item path (override)
575
576Translate logical name DCL$PATH as a searchlist, rather than trying
577to C<split> string value of C<$ENV{'PATH'}>.
578
579=cut
580
581sub path {
cbc7acb0 582 my (@dirs,$dir,$i);
270d1e39 583 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
cbc7acb0 584 return @dirs;
270d1e39
GS
585}
586
587=item file_name_is_absolute (override)
588
589Checks for VMS directory spec as well as Unix separators.
590
591=cut
592
593sub file_name_is_absolute {
cbc7acb0 594 my ($self,$file) = @_;
270d1e39 595 # If it's a logical name, expand it.
ee8c7f54 596 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
1b1e14d3 597 return scalar($file =~ m!^/!s ||
cbc7acb0
JD
598 $file =~ m![<\[][^.\-\]>]! ||
599 $file =~ /:[^<\[]/);
270d1e39
GS
600}
601
46726cbe
CB
602=item splitpath (override)
603
486bcc50 604 ($volume,$directories,$file) = File::Spec->splitpath( $path );
2f03b6be
FC
605 ($volume,$directories,$file) = File::Spec->splitpath( $path,
606 $no_file );
486bcc50
NC
607
608Passing a true value for C<$no_file> indicates that the path being
609split only contains directory components, even on systems where you
610can usually (when not supporting a foreign syntax) tell the difference
611between directories and files at a glance.
46726cbe
CB
612
613=cut
614
615sub splitpath {
486bcc50
NC
616 my($self,$path, $nofile) = @_;
617 my($dev,$dir,$file) = ('','','');
ae5a807c
JM
618 my $efs = $self->_efs;
619 my $vmsify_path = vmsify($path);
620 if ($efs) {
621 my $path_vms = 0;
61196b43 622 $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
623 $path_vms = 1 if ($path =~ /^--?$/);
624 if (!$path_vms) {
625 return $self->SUPER::splitpath($path, $nofile);
626 }
627 $vmsify_path = $path;
628 }
629
630 if ( $nofile ) {
486bcc50
NC
631 #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
632 #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
633 if( $vmsify_path =~ /(.*)\](.+)/ ){
634 $vmsify_path = $1.'.'.$2.']';
635 }
636 $vmsify_path =~ /(.+:)?(.*)/s;
637 $dir = defined $2 ? $2 : ''; # dir can be '0'
638 return ($1 || '',$dir,$file);
639 }
640 else {
641 $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
642 return ($1 || '',$2 || '',$3);
643 }
46726cbe
CB
644}
645
646=item splitdir (override)
647
ae5a807c 648Split a directory specification into the components.
46726cbe
CB
649
650=cut
651
652sub splitdir {
653 my($self,$dirspec) = @_;
13fbb5b1
JM
654 my @dirs = ();
655 return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
ae5a807c
JM
656
657 my $efs = $self->_efs;
658
659 my $dir_unix = 0;
660 $dir_unix = 1 if ($dirspec =~ m#/#);
661 $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
662
663 # Unix filespecs in EFS mode handled by Unix routines.
664 if ($efs && $dir_unix) {
665 return $self->SUPER::splitdir($dirspec);
666 }
667
668 # FIX ME, only split for VMS delimiters not prefixed with '^'.
669
bdc74e5c
CB
670 $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
671 $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
672 $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
673 $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
674 $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
675 $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
676 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
677 # That loop does the following
678 # with any amount of dashes:
679 # .--. ==> .-.-.
680 # [--. ==> [-.-.
681 # .--] ==> .-.-]
682 # [--] ==> [-.-]
61196b43 683 $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
2e74f398 684 $dirspec =~ s/^(\[|<)\./$1/;
13fbb5b1 685 @dirs = split /(?<!\^)\./, vmspath($dirspec);
ee8c7f54 686 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
46726cbe
CB
687 @dirs;
688}
689
690
691=item catpath (override)
692
ae5a807c 693Construct a complete filespec.
46726cbe
CB
694
695=cut
696
697sub catpath {
698 my($self,$dev,$dir,$file) = @_;
638113eb 699
ae5a807c
JM
700 my $efs = $self->_efs;
701 my $unix_rpt = $self->_unix_rpt;
702
703 my $unix_mode = 0;
704 my $dir_unix = 0;
705 $dir_unix = 1 if ($dir =~ m#/#);
706 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
707 my $dir_vms = 0;
61196b43 708 $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
709 $dir_vms = 1 if ($dir =~ /^--?$/);
710
711 if ($efs && (length($dev) == 0)) {
712 if ($dir_unix == $dir_vms) {
713 $unix_mode = $unix_rpt;
714 } else {
715 $unix_mode = $dir_unix;
716 }
717 }
718
638113eb 719 # We look for a volume in $dev, then in $dir, but not both
ae5a807c
JM
720 # but only if using VMS syntax.
721 if (!$unix_mode) {
722 $dir = vmspath($dir) if $dir_unix;
723 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
724 $dev = $dir_volume unless length $dev;
725 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) :
726 $dir_dir;
727 }
fd7385b9 728 if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
ee8c7f54 729 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
fd7385b9 730 if (length($dev) or length($dir)) {
ae5a807c
JM
731 if ($efs) {
732 if ($unix_mode) {
733 $dir .= '/' unless ($dir =~ m#/$#);
734 } else {
735 $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
736 $dir = "[$dir]" unless $dir =~ /^[\[<]/;
737 }
738 } else {
739 $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
740 $dir = vmspath($dir);
741 }
0994714a 742 }
385aae1c 743 $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
fd7385b9 744 "$dev$dir$file";
0994714a
GS
745}
746
fd7385b9 747=item abs2rel (override)
0994714a 748
ae5a807c
JM
749Attempt to convert a file specification to a relative specification.
750On a system with volumes, like VMS, this may not be possible.
0994714a
GS
751
752=cut
753
0994714a
GS
754sub abs2rel {
755 my $self = shift;
0994714a 756 my($path,$base) = @_;
ae5a807c
JM
757
758 my $efs = $self->_efs;
759 my $unix_rpt = $self->_unix_rpt;
760
ae5a807c
JM
761 # We need to identify what the directory is in
762 # of the specification in order to process them
763 my $path_unix = 0;
764 $path_unix = 1 if ($path =~ m#/#);
765 $path_unix = 1 if ($path =~ /^\.\.?$/);
766 my $path_vms = 0;
61196b43 767 $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
768 $path_vms = 1 if ($path =~ /^--?$/);
769
770 my $unix_mode = 0;
771 if ($path_vms == $path_unix) {
772 $unix_mode = $unix_rpt;
773 } else {
774 $unix_mode = $path_unix;
775 }
776
777 my $base_unix = 0;
778 my $base_vms = 0;
779
780 if (defined $base) {
781 $base_unix = 1 if ($base =~ m#/#);
782 $base_unix = 1 if ($base =~ /^\.\.?$/);
61196b43 783 $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
784 $base_vms = 1 if ($base =~ /^--?$/);
785
786 if ($path_vms == $path_unix) {
787 if ($base_vms == $base_unix) {
788 $unix_mode = $unix_rpt;
789 } else {
790 $unix_mode = $base_unix;
791 }
792 } else {
793 $unix_mode = 0 if $base_vms;
794 }
795 }
796
797 if ($efs) {
798 if ($unix_mode) {
799 # We are UNIX mode.
800 $base = unixpath($base) if $base_vms;
801 $base = unixify($path) if $path_vms;
802
803 # Here VMS is different, and in order to do this right
804 # we have to take the realpath for both the path and the base
805 # so that we can remove the common components.
806
807 if ($path =~ m#^/#) {
808 if (defined $base) {
809
810 # For the shorterm, if the starting directories are
811 # common, remove them.
812 my $bq = qq($base);
813 $bq =~ s/\$/\\\$/;
814 $path =~ s/^$bq//i;
815 }
816 return $path;
817 }
818
819 return File::Spec::Unix::abs2rel( $self, $path, $base );
820
821 } else {
822 $base = vmspath($base) if $base_unix;
823 $path = vmsify($path) if $path_unix;
824 }
825 }
826
827 unless (defined $base and length $base) {
828 $base = $self->_cwd();
829 if ($efs) {
830 $base_unix = 1 if ($base =~ m#/#);
831 $base_unix = 1 if ($base =~ /^\.\.?$/);
832 $base = vmspath($base) if $base_unix;
833 }
834 }
0994714a 835
638113eb 836 for ($path, $base) { $_ = $self->canonpath($_) }
0994714a 837
d84c672d
JH
838 # Are we even starting $path on the same (node::)device as $base? Note that
839 # logical paths or nodename differences may be on the "same device"
840 # but the comparison that ignores device differences so as to concatenate
841 # [---] up directory specs is not even a good idea in cases where there is
842 # a logical path difference between $path and $base nodename and/or device.
843 # Hence we fall back to returning the absolute $path spec
844 # if there is a case blind device (or node) difference of any sort
845 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
846 # (this module needs to run on non VMS platforms after all).
638113eb
JH
847
848 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
849 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
850 return $path unless lc($path_volume) eq lc($base_volume);
d84c672d 851
638113eb 852 for ($path, $base) { $_ = $self->rel2abs($_) }
0994714a
GS
853
854 # Now, remove all leading components that are the same
855 my @pathchunks = $self->splitdir( $path_directories );
fa52125f 856 my $pathchunks = @pathchunks;
737c380e 857 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
0994714a 858 my @basechunks = $self->splitdir( $base_directories );
fa52125f 859 my $basechunks = @basechunks;
737c380e 860 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
0994714a
GS
861
862 while ( @pathchunks &&
863 @basechunks &&
864 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
865 ) {
866 shift @pathchunks ;
867 shift @basechunks ;
868 }
869
870 # @basechunks now contains the directories to climb out of,
871 # @pathchunks now has the directories to descend in to.
fa52125f
SP
872 if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
873 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
874 }
875 else {
876 $path_directories = join '.', @pathchunks;
877 }
878 $path_directories = '['.$path_directories.']';
fd7385b9 879 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
0994714a
GS
880}
881
882
fd7385b9
CB
883=item rel2abs (override)
884
ae5a807c 885Return an absolute file specification from a relative one.
fd7385b9
CB
886
887=cut
888
786b702f 889sub rel2abs {
0994714a 890 my $self = shift ;
0994714a 891 my ($path,$base ) = @_;
bdc74e5c 892 return undef unless defined $path;
ae5a807c
JM
893
894 my $efs = $self->_efs;
895 my $unix_rpt = $self->_unix_rpt;
896
897 # We need to identify what the directory is in
898 # of the specification in order to process them
899 my $path_unix = 0;
900 $path_unix = 1 if ($path =~ m#/#);
901 $path_unix = 1 if ($path =~ /^\.\.?$/);
902 my $path_vms = 0;
61196b43 903 $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
904 $path_vms = 1 if ($path =~ /^--?$/);
905
906 my $unix_mode = 0;
907 if ($path_vms == $path_unix) {
908 $unix_mode = $unix_rpt;
909 } else {
910 $unix_mode = $path_unix;
911 }
912
913 my $base_unix = 0;
914 my $base_vms = 0;
915
916 if (defined $base) {
917 $base_unix = 1 if ($base =~ m#/#);
918 $base_unix = 1 if ($base =~ /^\.\.?$/);
61196b43 919 $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
920 $base_vms = 1 if ($base =~ /^--?$/);
921
922 # If we could not determine the path mode, see if we can find out
923 # from the base.
924 if ($path_vms == $path_unix) {
925 if ($base_vms != $base_unix) {
926 $unix_mode = $base_unix;
927 }
928 }
99f36a73 929 }
ae5a807c
JM
930
931 if (!$efs) {
932 # Legacy behavior, convert to VMS syntax.
933 $unix_mode = 0;
934 if (defined $base) {
935 $base = vmspath($base) if $base =~ m/\//;
936 }
937
938 if ($path =~ m/\//) {
939 $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
940 ? vmspath($path) # whether it's a directory
941 : vmsify($path) );
942 }
943 }
944
0994714a
GS
945 # Clean up and split up $path
946 if ( ! $self->file_name_is_absolute( $path ) ) {
947 # Figure out the effective $base and clean it up.
948 if ( !defined( $base ) || $base eq '' ) {
0fab864c 949 $base = $self->_cwd;
0994714a
GS
950 }
951 elsif ( ! $self->file_name_is_absolute( $base ) ) {
952 $base = $self->rel2abs( $base ) ;
953 }
954 else {
955 $base = $self->canonpath( $base ) ;
956 }
957
ae5a807c
JM
958 if ($efs) {
959 # base may have changed, so need to look up format again.
960 if ($unix_mode) {
61196b43 961 $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
ae5a807c
JM
962 $base_vms = 1 if ($base =~ /^--?$/);
963 $base = unixpath($base) if $base_vms;
964 $base .= '/' unless ($base =~ m#/$#);
965 } else {
966 $base_unix = 1 if ($base =~ m#/#);
967 $base_unix = 1 if ($base =~ /^\.\.?$/);
968 $base = vmspath($base) if $base_unix;
969 }
970 }
971
0994714a 972 # Split up paths
ee8c7f54
CB
973 my ( $path_directories, $path_file ) =
974 ($self->splitpath( $path ))[1,2] ;
0994714a 975
ee8c7f54 976 my ( $base_volume, $base_directories ) =
0994714a
GS
977 $self->splitpath( $base ) ;
978
fd7385b9
CB
979 $path_directories = '' if $path_directories eq '[]' ||
980 $path_directories eq '<>';
0994714a 981 my $sep = '' ;
ae5a807c
JM
982
983 if ($efs) {
984 # Merge the paths assuming that the base is absolute.
985 $base_directories = $self->catdir('',
986 $base_directories,
987 $path_directories);
988 } else {
989 # Legacy behavior assumes VMS only paths
990 $sep = '.'
991 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
992 $path_directories =~ m{^[^.\[<]}s
993 ) ;
994 $base_directories = "$base_directories$sep$path_directories";
995 $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
996 }
997
998 $path_file = '' if ($path_file eq '.') && $unix_mode;
0994714a
GS
999
1000 $path = $self->catpath( $base_volume, $base_directories, $path_file );
1001 }
1002
1003 return $self->canonpath( $path ) ;
1004}
1005
1006
9596c75c
RGS
1007# eliminate_macros() and fixpath() are MakeMaker-specific methods
1008# which are used inside catfile() and catdir(). MakeMaker has its own
1009# copies as of 6.06_03 which are the canonical ones. We leave these
1010# here, in peace, so that File::Spec continues to work with MakeMakers
1011# prior to 6.06_03.
1012#
1013# Please consider these two methods deprecated. Do not patch them,
1014# patch the ones in ExtUtils::MM_VMS instead.
ae5a807c
JM
1015#
1016# Update: MakeMaker 6.48 is still using these routines on VMS.
1017# so they need to be kept up to date with ExtUtils::MM_VMS.
1018#
1019# The traditional VMS mode using ODS-2 disks depends on these routines
1020# being here. These routines should not be called in when the
385aae1c 1021# C<DECC$EFS_CHARSET> or C<DECC$FILENAME_UNIX_REPORT> modes are enabled.
ae5a807c 1022
9596c75c
RGS
1023sub eliminate_macros {
1024 my($self,$path) = @_;
ff235dd6 1025 return '' unless (defined $path) && ($path ne '');
9596c75c
RGS
1026 $self = {} unless ref $self;
1027
1028 if ($path =~ /\s/) {
1029 return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1030 }
1031
ae5a807c
JM
1032 my $npath = unixify($path);
1033 # sometimes unixify will return a string with an off-by-one trailing null
1034 $npath =~ s{\0$}{};
1035
9596c75c
RGS
1036 my($complex) = 0;
1037 my($head,$macro,$tail);
1038
1039 # perform m##g in scalar context so it acts as an iterator
1040 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
ae5a807c 1041 if (defined $self->{$2}) {
9596c75c
RGS
1042 ($head,$macro,$tail) = ($1,$2,$3);
1043 if (ref $self->{$macro}) {
1044 if (ref $self->{$macro} eq 'ARRAY') {
1045 $macro = join ' ', @{$self->{$macro}};
1046 }
1047 else {
1048 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
1049 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
1050 $macro = "\cB$macro\cB";
1051 $complex = 1;
1052 }
1053 }
1054 else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1055 $npath = "$head$macro$tail";
1056 }
1057 }
1058 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1059 $npath;
1060}
1061
1062# Deprecated. See the note above for eliminate_macros().
ae5a807c
JM
1063
1064# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
1065# in any directory specification, in order to avoid juxtaposing two
1066# VMS-syntax directories when MM[SK] is run. Also expands expressions which
1067# are all macro, so that we can tell how long the expansion is, and avoid
1068# overrunning DCL's command buffer when MM[KS] is running.
1069
1070# fixpath() checks to see whether the result matches the name of a
1071# directory in the current default directory and returns a directory or
1072# file specification accordingly. C<$is_dir> can be set to true to
1073# force fixpath() to consider the path to be a directory or false to force
1074# it to be a file.
1075
9596c75c
RGS
1076sub fixpath {
1077 my($self,$path,$force_path) = @_;
1078 return '' unless $path;
486bcc50 1079 $self = bless {}, $self unless ref $self;
9596c75c
RGS
1080 my($fixedpath,$prefix,$name);
1081
1082 if ($path =~ /\s/) {
1083 return join ' ',
1084 map { $self->fixpath($_,$force_path) }
1085 split /\s+/, $path;
1086 }
1087
1088 if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
1089 if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
1090 $fixedpath = vmspath($self->eliminate_macros($path));
1091 }
1092 else {
1093 $fixedpath = vmsify($self->eliminate_macros($path));
1094 }
1095 }
1096 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1097 my($vmspre) = $self->eliminate_macros("\$($prefix)");
1098 # is it a dir or just a name?
1099 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
1100 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
1101 $fixedpath = vmspath($fixedpath) if $force_path;
1102 }
1103 else {
1104 $fixedpath = $path;
1105 $fixedpath = vmspath($fixedpath) if $force_path;
1106 }
1107 # No hints, so we try to guess
1108 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
1109 $fixedpath = vmspath($fixedpath) if -d $fixedpath;
1110 }
1111
1112 # Trim off root dirname if it's had other dirs inserted in front of it.
1113 $fixedpath =~ s/\.000000([\]>])/$1/;
1114 # Special case for VMS absolute directory specs: these will have had device
1115 # prepended during trip through Unix syntax in eliminate_macros(), since
1116 # Unix syntax has no way to express "absolute from the top of this device's
1117 # directory tree".
1118 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1119 $fixedpath;
1120}
1121
1122
cbc7acb0 1123=back
270d1e39 1124
99f36a73
RGS
1125=head1 COPYRIGHT
1126
1127Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
1128
1129This program is free software; you can redistribute it and/or modify
1130it under the same terms as Perl itself.
1131
cbc7acb0
JD
1132=head1 SEE ALSO
1133
72f15715
T
1134See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
1135implementation of these methods, not the semantics.
cbc7acb0 1136
638113eb 1137An explanation of VMS file specs can be found at
385aae1c 1138L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
638113eb 1139
cbc7acb0
JD
1140=cut
1141
11421;