This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Basic 5.6.0 RC1 build patches for VMS
[perl5.git] / lib / File / Spec / VMS.pm
CommitLineData
270d1e39
GS
1package File::Spec::VMS;
2
cbc7acb0
JD
3use strict;
4use vars qw(@ISA);
5require File::Spec::Unix;
270d1e39
GS
6@ISA = qw(File::Spec::Unix);
7
178326fd 8use Cwd;
cbc7acb0
JD
9use File::Basename;
10use VMS::Filespec;
270d1e39
GS
11
12=head1 NAME
13
14File::Spec::VMS - methods for VMS file specs
15
16=head1 SYNOPSIS
17
cbc7acb0 18 require File::Spec::VMS; # Done internally by File::Spec if needed
270d1e39
GS
19
20=head1 DESCRIPTION
21
22See File::Spec::Unix for a documentation of the methods provided
23there. This package overrides the implementation of these methods, not
24the semantics.
25
a45bd81d
GS
26=over
27
377875b9
CB
28=item eliminate_macros
29
30Expands MM[KS]/Make macros in a text string, using the contents of
31identically named elements of C<%$self>, and returns the result
32as a file specification in Unix syntax.
33
1f47e8e2
CB
34=cut
35
36sub eliminate_macros {
37 my($self,$path) = @_;
38 return '' unless $path;
39 $self = {} unless ref $self;
40 my($npath) = unixify($path);
41 my($complex) = 0;
42 my($head,$macro,$tail);
43
44 # perform m##g in scalar context so it acts as an iterator
14a089c5 45 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
1f47e8e2
CB
46 if ($self->{$2}) {
47 ($head,$macro,$tail) = ($1,$2,$3);
48 if (ref $self->{$macro}) {
49 if (ref $self->{$macro} eq 'ARRAY') {
50 $macro = join ' ', @{$self->{$macro}};
51 }
52 else {
53 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
54 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
55 $macro = "\cB$macro\cB";
56 $complex = 1;
57 }
58 }
1b1e14d3 59 else { ($macro = unixify($self->{$macro})) =~ s#/\z##; }
1f47e8e2
CB
60 $npath = "$head$macro$tail";
61 }
62 }
14a089c5 63 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1f47e8e2
CB
64 $npath;
65}
66
377875b9
CB
67=item fixpath
68
69Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
70in any directory specification, in order to avoid juxtaposing two
71VMS-syntax directories when MM[SK] is run. Also expands expressions which
72are all macro, so that we can tell how long the expansion is, and avoid
73overrunning DCL's command buffer when MM[KS] is running.
74
75If optional second argument has a TRUE value, then the return string is
76a VMS-syntax directory specification, if it is FALSE, the return string
77is a VMS-syntax file specification, and if it is not specified, fixpath()
78checks to see whether it matches the name of a directory in the current
79default directory, and returns a directory or file specification accordingly.
80
81=cut
82
1f47e8e2
CB
83sub fixpath {
84 my($self,$path,$force_path) = @_;
85 return '' unless $path;
86 $self = bless {} unless ref $self;
87 my($fixedpath,$prefix,$name);
88
1b1e14d3
GS
89 if ($path =~ m#^\$\([^\)]+\)\z#s || $path =~ m#[/:>\]]#) {
90 if ($force_path or $path =~ /(?:DIR\)|\])\z/) {
1f47e8e2
CB
91 $fixedpath = vmspath($self->eliminate_macros($path));
92 }
93 else {
94 $fixedpath = vmsify($self->eliminate_macros($path));
95 }
96 }
1b1e14d3 97 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1f47e8e2
CB
98 my($vmspre) = $self->eliminate_macros("\$($prefix)");
99 # is it a dir or just a name?
1b1e14d3 100 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\z/) ? vmspath($vmspre) : '';
1f47e8e2
CB
101 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
102 $fixedpath = vmspath($fixedpath) if $force_path;
103 }
104 else {
105 $fixedpath = $path;
106 $fixedpath = vmspath($fixedpath) if $force_path;
107 }
108 # No hints, so we try to guess
109 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
110 $fixedpath = vmspath($fixedpath) if -d $fixedpath;
111 }
46726cbe 112
1f47e8e2
CB
113 # Trim off root dirname if it's had other dirs inserted in front of it.
114 $fixedpath =~ s/\.000000([\]>])/$1/;
46726cbe
CB
115 # Special case for VMS absolute directory specs: these will have had device
116 # prepended during trip through Unix syntax in eliminate_macros(), since
117 # Unix syntax has no way to express "absolute from the top of this device's
118 # directory tree".
119 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1f47e8e2
CB
120 $fixedpath;
121}
122
a45bd81d 123=back
1f47e8e2 124
270d1e39
GS
125=head2 Methods always loaded
126
127=over
128
46726cbe
CB
129=item canonpath (override)
130
131Removes redundant portions of file specifications according to VMS syntax
132
133=cut
134
135sub canonpath {
136 my($self,$path,$reduce_ricochet) = @_;
137
138 if ($path =~ m|/|) { # Fake Unix
14a089c5 139 my $pathify = $path =~ m|/\z|;
46726cbe
CB
140 $path = $self->SUPER::canonpath($path,$reduce_ricochet);
141 if ($pathify) { return vmspath($path); }
142 else { return vmsify($path); }
143 }
144 else {
178326fd
CB
145 $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar
146 $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo
147 if ($reduce_ricochet) {
148 $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/g;
149 $path =~ s/([\[<\.])([^\[<\.]+)\.-\.?/$1/g;
150 }
46726cbe
CB
151 return $path;
152 }
153}
154
270d1e39
GS
155=item catdir
156
157Concatenates a list of file specifications, and returns the result as a
46726cbe
CB
158VMS-syntax directory specification. No check is made for "impossible"
159cases (e.g. elements other than the first being absolute filespecs).
270d1e39
GS
160
161=cut
162
163sub catdir {
cbc7acb0
JD
164 my ($self,@dirs) = @_;
165 my $dir = pop @dirs;
270d1e39 166 @dirs = grep($_,@dirs);
cbc7acb0 167 my $rslt;
270d1e39 168 if (@dirs) {
cbc7acb0
JD
169 my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
170 my ($spath,$sdir) = ($path,$dir);
14a089c5 171 $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//;
1b1e14d3 172 $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/s;
cbc7acb0 173 $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
46726cbe
CB
174
175 # Special case for VMS absolute directory specs: these will have had device
176 # prepended during trip through Unix syntax in eliminate_macros(), since
177 # Unix syntax has no way to express "absolute from the top of this device's
178 # directory tree".
1b1e14d3 179 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
270d1e39 180 }
cbc7acb0 181 else {
1b1e14d3
GS
182 if ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; }
183 else { $rslt = vmspath($dir); }
270d1e39 184 }
cbc7acb0 185 return $rslt;
270d1e39
GS
186}
187
188=item catfile
189
190Concatenates a list of file specifications, and returns the result as a
46726cbe 191VMS-syntax file specification.
270d1e39
GS
192
193=cut
194
195sub catfile {
cbc7acb0
JD
196 my ($self,@files) = @_;
197 my $file = pop @files;
270d1e39 198 @files = grep($_,@files);
cbc7acb0 199 my $rslt;
270d1e39 200 if (@files) {
cbc7acb0
JD
201 my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
202 my $spath = $path;
14a089c5 203 $spath =~ s/\.dir\z//;
1b1e14d3 204 if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) {
cbc7acb0
JD
205 $rslt = "$spath$file";
206 }
207 else {
208 $rslt = $self->eliminate_macros($spath);
209 $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
210 }
270d1e39
GS
211 }
212 else { $rslt = vmsify($file); }
cbc7acb0 213 return $rslt;
270d1e39
GS
214}
215
46726cbe 216
270d1e39
GS
217=item curdir (override)
218
cbc7acb0 219Returns a string representation of the current directory: '[]'
270d1e39
GS
220
221=cut
222
223sub curdir {
224 return '[]';
225}
226
99804bbb
GS
227=item devnull (override)
228
cbc7acb0 229Returns a string representation of the null device: '_NLA0:'
99804bbb
GS
230
231=cut
232
233sub devnull {
cbc7acb0 234 return "_NLA0:";
99804bbb
GS
235}
236
270d1e39
GS
237=item rootdir (override)
238
cbc7acb0 239Returns a string representation of the root directory: 'SYS$DISK:[000000]'
270d1e39
GS
240
241=cut
242
243sub rootdir {
cbc7acb0
JD
244 return 'SYS$DISK:[000000]';
245}
246
247=item tmpdir (override)
248
249Returns a string representation of the first writable directory
250from the following list or '' if none are writable:
251
252 /sys$scratch
253 $ENV{TMPDIR}
254
255=cut
256
257my $tmpdir;
258sub tmpdir {
259 return $tmpdir if defined $tmpdir;
260 foreach ('/sys$scratch', $ENV{TMPDIR}) {
261 next unless defined && -d && -w _;
262 $tmpdir = $_;
263 last;
264 }
265 $tmpdir = '' unless defined $tmpdir;
266 return $tmpdir;
270d1e39
GS
267}
268
269=item updir (override)
270
cbc7acb0 271Returns a string representation of the parent directory: '[-]'
270d1e39
GS
272
273=cut
274
275sub updir {
276 return '[-]';
277}
278
46726cbe
CB
279=item case_tolerant (override)
280
281VMS file specification syntax is case-tolerant.
282
283=cut
284
285sub case_tolerant {
286 return 1;
287}
288
270d1e39
GS
289=item path (override)
290
291Translate logical name DCL$PATH as a searchlist, rather than trying
292to C<split> string value of C<$ENV{'PATH'}>.
293
294=cut
295
296sub path {
cbc7acb0 297 my (@dirs,$dir,$i);
270d1e39 298 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
cbc7acb0 299 return @dirs;
270d1e39
GS
300}
301
302=item file_name_is_absolute (override)
303
304Checks for VMS directory spec as well as Unix separators.
305
306=cut
307
308sub file_name_is_absolute {
cbc7acb0 309 my ($self,$file) = @_;
270d1e39 310 # If it's a logical name, expand it.
1b1e14d3
GS
311 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file};
312 return scalar($file =~ m!^/!s ||
cbc7acb0
JD
313 $file =~ m![<\[][^.\-\]>]! ||
314 $file =~ /:[^<\[]/);
270d1e39
GS
315}
316
46726cbe
CB
317=item splitpath (override)
318
319Splits using VMS syntax.
320
321=cut
322
323sub splitpath {
324 my($self,$path) = @_;
325 my($dev,$dir,$file) = ('','','');
326
1b1e14d3 327 vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
46726cbe
CB
328 return ($1 || '',$2 || '',$3);
329}
330
331=item splitdir (override)
332
333Split dirspec using VMS syntax.
334
335=cut
336
337sub splitdir {
338 my($self,$dirspec) = @_;
339 $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g;
340 my(@dirs) = split('\.', vmspath($dirspec));
1b1e14d3 341 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\z//s;
46726cbe
CB
342 @dirs;
343}
344
345
346=item catpath (override)
347
348Construct a complete filespec using VMS syntax
349
350=cut
351
352sub catpath {
353 my($self,$dev,$dir,$file) = @_;
354 if ($dev =~ m|^/+([^/]+)|) { $dev =~ "$1:"; }
14a089c5 355 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; }
46726cbe
CB
356 $dir = vmspath($dir);
357 "$dev$dir$file";
358}
359
0994714a
GS
360=item splitpath
361
362 ($volume,$directories,$file) = File::Spec->splitpath( $path );
363 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
364
365Splits a VMS path in to volume, directory, and filename portions.
366Ignores $no_file, if present, since VMS paths indicate the 'fileness' of a
367file.
368
369The results can be passed to L</catpath()> to get back a path equivalent to
370(usually identical to) the original path.
371
372=cut
373
374sub splitpath {
375 my $self = shift ;
376 my ($path, $nofile) = @_;
377
378 my ($volume,$directory,$file) ;
379
380 if ( $path =~ m{/} ) {
381 $path =~
382 m{^ ( (?: /[^/]* )? )
14a089c5 383 ( (?: .*/(?:[^/]+\.dir)? )? )
0994714a 384 (.*)
1b1e14d3 385 }xs;
0994714a
GS
386 $volume = $1;
387 $directory = $2;
388 $file = $3;
389 }
390 else {
391 $path =~
392 m{^ ( (?: (?: (?: [\w\$-]+ (?: "[^"]*")?:: )? [\w\$-]+: )? ) )
393 ( (?:\[.*\])? )
394 (.*)
1b1e14d3 395 }xs;
0994714a
GS
396 $volume = $1;
397 $directory = $2;
398 $file = $3;
399 }
400
401 $directory = $1
1b1e14d3 402 if $directory =~ /^\[(.*)\]\z/s ;
0994714a
GS
403
404 return ($volume,$directory,$file);
405}
406
407
408=item splitdir
409
410The opposite of L</catdir()>.
411
412 @dirs = File::Spec->splitdir( $directories );
413
414$directories must be only the directory portion of the path.
415
416'[' and ']' delimiters are optional. An empty string argument is
417equivalent to '[]': both return an array with no elements.
418
419=cut
420
421sub splitdir {
422 my $self = shift ;
423 my $directories = $_[0] ;
424
425 return File::Spec::Unix::splitdir( $self, @_ )
426 if ( $directories =~ m{/} ) ;
427
1b1e14d3 428 $directories =~ s/^\[(.*)\]\z/$1/s ;
0994714a
GS
429
430 #
431 # split() likes to forget about trailing null fields, so here we
432 # check to be sure that there will not be any before handling the
433 # simple case.
434 #
1b1e14d3 435 if ( $directories !~ m{\.\z} ) {
0994714a
GS
436 return split( m{\.}, $directories );
437 }
438 else {
439 #
440 # since there was a trailing separator, add a file name to the end,
441 # then do the split, then replace it with ''.
442 #
443 my( @directories )= split( m{\.}, "${directories}dummy" ) ;
444 $directories[ $#directories ]= '' ;
445 return @directories ;
446 }
447}
448
449
450sub catpath {
451 my $self = shift;
452
453 return File::Spec::Unix::catpath( $self, @_ )
454 if ( join( '', @_ ) =~ m{/} ) ;
455
456 my ($volume,$directory,$file) = @_;
457
458 $volume .= ':'
1b1e14d3 459 if $volume =~ /[^:]\z/ ;
0994714a
GS
460
461 $directory = "[$directory"
1b1e14d3 462 if $directory =~ /^[^\[]/s ;
0994714a
GS
463
464 $directory .= ']'
1b1e14d3 465 if $directory =~ /[^\]]\z/ ;
0994714a
GS
466
467 return "$volume$directory$file" ;
468}
469
470
471sub abs2rel {
472 my $self = shift;
473
474 return File::Spec::Unix::abs2rel( $self, @_ )
475 if ( join( '', @_ ) =~ m{/} ) ;
476
477 my($path,$base) = @_;
478
479 # Note: we use '/' to glue things together here, then let canonpath()
480 # clean them up at the end.
481
482 # Clean up $path
483 if ( ! $self->file_name_is_absolute( $path ) ) {
484 $path = $self->rel2abs( $path ) ;
485 }
486 else {
487 $path = $self->canonpath( $path ) ;
488 }
489
490 # Figure out the effective $base and clean it up.
1d7cb664 491 if ( !defined( $base ) || $base eq '' ) {
0994714a
GS
492 $base = cwd() ;
493 }
1d7cb664
GS
494 elsif ( ! $self->file_name_is_absolute( $base ) ) {
495 $base = $self->rel2abs( $base ) ;
496 }
0994714a
GS
497 else {
498 $base = $self->canonpath( $base ) ;
499 }
500
501 # Split up paths
502 my ( undef, $path_directories, $path_file ) =
503 $self->splitpath( $path, 1 ) ;
504
505 $path_directories = $1
1b1e14d3 506 if $path_directories =~ /^\[(.*)\]\z/s ;
0994714a
GS
507
508 my ( undef, $base_directories, undef ) =
509 $self->splitpath( $base, 1 ) ;
510
511 $base_directories = $1
1b1e14d3 512 if $base_directories =~ /^\[(.*)\]\z/s ;
0994714a
GS
513
514 # Now, remove all leading components that are the same
515 my @pathchunks = $self->splitdir( $path_directories );
516 my @basechunks = $self->splitdir( $base_directories );
517
518 while ( @pathchunks &&
519 @basechunks &&
520 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
521 ) {
522 shift @pathchunks ;
523 shift @basechunks ;
524 }
525
526 # @basechunks now contains the directories to climb out of,
527 # @pathchunks now has the directories to descend in to.
528 $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
1b1e14d3 529 $path_directories =~ s{\.\z}{} ;
0994714a
GS
530 return $self->catpath( '', $path_directories, $path_file ) ;
531}
532
533
534sub rel2abs($;$;) {
535 my $self = shift ;
536 return File::Spec::Unix::rel2abs( $self, @_ )
537 if ( join( '', @_ ) =~ m{/} ) ;
538
539 my ($path,$base ) = @_;
540 # Clean up and split up $path
541 if ( ! $self->file_name_is_absolute( $path ) ) {
542 # Figure out the effective $base and clean it up.
543 if ( !defined( $base ) || $base eq '' ) {
544 $base = cwd() ;
545 }
546 elsif ( ! $self->file_name_is_absolute( $base ) ) {
547 $base = $self->rel2abs( $base ) ;
548 }
549 else {
550 $base = $self->canonpath( $base ) ;
551 }
552
553 # Split up paths
554 my ( undef, $path_directories, $path_file ) =
555 $self->splitpath( $path ) ;
556
557 my ( $base_volume, $base_directories, undef ) =
558 $self->splitpath( $base ) ;
559
560 my $sep = '' ;
561 $sep = '.'
1b1e14d3
GS
562 if ( $base_directories =~ m{[^.]\z} &&
563 $path_directories =~ m{^[^.]}s
0994714a
GS
564 ) ;
565 $base_directories = "$base_directories$sep$path_directories" ;
566
567 $path = $self->catpath( $base_volume, $base_directories, $path_file );
568 }
569
570 return $self->canonpath( $path ) ;
571}
572
573
cbc7acb0 574=back
270d1e39 575
cbc7acb0
JD
576=head1 SEE ALSO
577
578L<File::Spec>
579
580=cut
581
5821;