This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Pod::LaTeX 0.58
[perl5.git] / 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
07824bd1 7$VERSION = '1.4';
ee8c7f54 8
270d1e39
GS
9@ISA = qw(File::Spec::Unix);
10
cbc7acb0
JD
11use File::Basename;
12use VMS::Filespec;
270d1e39
GS
13
14=head1 NAME
15
16File::Spec::VMS - methods for VMS file specs
17
18=head1 SYNOPSIS
19
cbc7acb0 20 require File::Spec::VMS; # Done internally by File::Spec if needed
270d1e39
GS
21
22=head1 DESCRIPTION
23
24See File::Spec::Unix for a documentation of the methods provided
25there. This package overrides the implementation of these methods, not
26the semantics.
27
bbc7dcd2 28=over 4
a45bd81d 29
377875b9
CB
30=item eliminate_macros
31
32Expands MM[KS]/Make macros in a text string, using the contents of
33identically named elements of C<%$self>, and returns the result
34as a file specification in Unix syntax.
35
1f47e8e2
CB
36=cut
37
38sub eliminate_macros {
39 my($self,$path) = @_;
40 return '' unless $path;
41 $self = {} unless ref $self;
bdb84599
CB
42
43 if ($path =~ /\s/) {
44 return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
45 }
46
1f47e8e2
CB
47 my($npath) = unixify($path);
48 my($complex) = 0;
49 my($head,$macro,$tail);
50
51 # perform m##g in scalar context so it acts as an iterator
14a089c5 52 while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
1f47e8e2
CB
53 if ($self->{$2}) {
54 ($head,$macro,$tail) = ($1,$2,$3);
55 if (ref $self->{$macro}) {
56 if (ref $self->{$macro} eq 'ARRAY') {
57 $macro = join ' ', @{$self->{$macro}};
58 }
59 else {
60 print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
61 "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
62 $macro = "\cB$macro\cB";
63 $complex = 1;
64 }
65 }
ee8c7f54 66 else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1f47e8e2
CB
67 $npath = "$head$macro$tail";
68 }
69 }
14a089c5 70 if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1f47e8e2
CB
71 $npath;
72}
73
377875b9
CB
74=item fixpath
75
76Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
77in any directory specification, in order to avoid juxtaposing two
78VMS-syntax directories when MM[SK] is run. Also expands expressions which
79are all macro, so that we can tell how long the expansion is, and avoid
80overrunning DCL's command buffer when MM[KS] is running.
81
82If optional second argument has a TRUE value, then the return string is
83a VMS-syntax directory specification, if it is FALSE, the return string
84is a VMS-syntax file specification, and if it is not specified, fixpath()
85checks to see whether it matches the name of a directory in the current
86default directory, and returns a directory or file specification accordingly.
87
88=cut
89
1f47e8e2
CB
90sub fixpath {
91 my($self,$path,$force_path) = @_;
92 return '' unless $path;
93 $self = bless {} unless ref $self;
94 my($fixedpath,$prefix,$name);
95
bdb84599
CB
96 if ($path =~ /\s/) {
97 return join ' ',
98 map { $self->fixpath($_,$force_path) }
99 split /\s+/, $path;
100 }
101
ee8c7f54
CB
102 if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
103 if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
1f47e8e2
CB
104 $fixedpath = vmspath($self->eliminate_macros($path));
105 }
106 else {
107 $fixedpath = vmsify($self->eliminate_macros($path));
108 }
109 }
1b1e14d3 110 elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1f47e8e2
CB
111 my($vmspre) = $self->eliminate_macros("\$($prefix)");
112 # is it a dir or just a name?
ee8c7f54 113 $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
1f47e8e2
CB
114 $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
115 $fixedpath = vmspath($fixedpath) if $force_path;
116 }
117 else {
118 $fixedpath = $path;
119 $fixedpath = vmspath($fixedpath) if $force_path;
120 }
121 # No hints, so we try to guess
122 if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
123 $fixedpath = vmspath($fixedpath) if -d $fixedpath;
124 }
46726cbe 125
1f47e8e2
CB
126 # Trim off root dirname if it's had other dirs inserted in front of it.
127 $fixedpath =~ s/\.000000([\]>])/$1/;
46726cbe
CB
128 # Special case for VMS absolute directory specs: these will have had device
129 # prepended during trip through Unix syntax in eliminate_macros(), since
130 # Unix syntax has no way to express "absolute from the top of this device's
131 # directory tree".
132 if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1f47e8e2
CB
133 $fixedpath;
134}
135
a45bd81d 136=back
1f47e8e2 137
270d1e39
GS
138=head2 Methods always loaded
139
bbc7dcd2 140=over 4
270d1e39 141
46726cbe
CB
142=item canonpath (override)
143
fd7385b9 144Removes redundant portions of file specifications according to VMS syntax.
46726cbe
CB
145
146=cut
147
148sub canonpath {
fd7385b9 149 my($self,$path) = @_;
46726cbe
CB
150
151 if ($path =~ m|/|) { # Fake Unix
ee8c7f54 152 my $pathify = $path =~ m|/\Z(?!\n)|;
fd7385b9 153 $path = $self->SUPER::canonpath($path);
46726cbe
CB
154 if ($pathify) { return vmspath($path); }
155 else { return vmsify($path); }
156 }
157 else {
bdc74e5c
CB
158 $path =~ tr/<>/[]/; # < and > ==> [ and ]
159 $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
160 $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
161 $path =~ s/\[000000\./\[/g; # [000000. ==> [
162 $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
163 $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
164 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
165 # That loop does the following
166 # with any amount of dashes:
167 # .-.-. ==> .--.
168 # [-.-. ==> [--.
169 # .-.-] ==> .--]
170 # [-.-] ==> [--]
171 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
172 # That loop does the following
173 # with any amount (minimum 2)
174 # of dashes:
175 # .foo.--. ==> .-.
176 # .foo.--] ==> .-]
177 # [foo.--. ==> [-.
178 # [foo.--] ==> [-]
179 #
180 # And then, the remaining cases
181 $path =~ s/\[\.-/[-/; # [.- ==> [-
182 $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
183 $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
184 $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
185 $path =~ s/\[[^\]\.]+\.-\]/\[\]/g; # [foo.-] ==> []
186 $path =~ s/\[\]//; # [] ==>
187 return $path;
46726cbe
CB
188 }
189}
190
270d1e39
GS
191=item catdir
192
193Concatenates a list of file specifications, and returns the result as a
46726cbe
CB
194VMS-syntax directory specification. No check is made for "impossible"
195cases (e.g. elements other than the first being absolute filespecs).
270d1e39
GS
196
197=cut
198
199sub catdir {
cbc7acb0
JD
200 my ($self,@dirs) = @_;
201 my $dir = pop @dirs;
270d1e39 202 @dirs = grep($_,@dirs);
cbc7acb0 203 my $rslt;
270d1e39 204 if (@dirs) {
cbc7acb0
JD
205 my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
206 my ($spath,$sdir) = ($path,$dir);
ee8c7f54
CB
207 $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
208 $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
cbc7acb0 209 $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
46726cbe 210
fd7385b9
CB
211 # Special case for VMS absolute directory specs: these will have had device
212 # prepended during trip through Unix syntax in eliminate_macros(), since
213 # Unix syntax has no way to express "absolute from the top of this device's
214 # directory tree".
215 if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
270d1e39 216 }
cbc7acb0 217 else {
fd7385b9 218 if (not defined $dir or not length $dir) { $rslt = ''; }
ee8c7f54 219 elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }
fd7385b9 220 else { $rslt = vmspath($dir); }
270d1e39 221 }
099f76bb 222 return $self->canonpath($rslt);
270d1e39
GS
223}
224
225=item catfile
226
227Concatenates a list of file specifications, and returns the result as a
46726cbe 228VMS-syntax file specification.
270d1e39
GS
229
230=cut
231
232sub catfile {
cbc7acb0 233 my ($self,@files) = @_;
9ba1b7d2 234 my $file = $self->canonpath(pop @files);
270d1e39 235 @files = grep($_,@files);
cbc7acb0 236 my $rslt;
270d1e39 237 if (@files) {
cbc7acb0
JD
238 my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
239 my $spath = $path;
ee8c7f54
CB
240 $spath =~ s/\.dir\Z(?!\n)//;
241 if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
cbc7acb0
JD
242 $rslt = "$spath$file";
243 }
244 else {
245 $rslt = $self->eliminate_macros($spath);
246 $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
247 }
270d1e39 248 }
fd7385b9 249 else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
099f76bb 250 return $self->canonpath($rslt);
270d1e39
GS
251}
252
46726cbe 253
270d1e39
GS
254=item curdir (override)
255
cbc7acb0 256Returns a string representation of the current directory: '[]'
270d1e39
GS
257
258=cut
259
260sub curdir {
261 return '[]';
262}
263
99804bbb
GS
264=item devnull (override)
265
cbc7acb0 266Returns a string representation of the null device: '_NLA0:'
99804bbb
GS
267
268=cut
269
270sub devnull {
cbc7acb0 271 return "_NLA0:";
99804bbb
GS
272}
273
270d1e39
GS
274=item rootdir (override)
275
cbc7acb0 276Returns a string representation of the root directory: 'SYS$DISK:[000000]'
270d1e39
GS
277
278=cut
279
280sub rootdir {
cbc7acb0
JD
281 return 'SYS$DISK:[000000]';
282}
283
284=item tmpdir (override)
285
286Returns a string representation of the first writable directory
287from the following list or '' if none are writable:
288
188ff3c1 289 sys$scratch:
cbc7acb0
JD
290 $ENV{TMPDIR}
291
a384e9e1
RGS
292Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
293is tainted, it is not used.
294
cbc7acb0
JD
295=cut
296
297my $tmpdir;
298sub tmpdir {
299 return $tmpdir if defined $tmpdir;
07824bd1
JH
300 my $self = shift;
301 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
270d1e39
GS
302}
303
304=item updir (override)
305
cbc7acb0 306Returns a string representation of the parent directory: '[-]'
270d1e39
GS
307
308=cut
309
310sub updir {
311 return '[-]';
312}
313
46726cbe
CB
314=item case_tolerant (override)
315
316VMS file specification syntax is case-tolerant.
317
318=cut
319
320sub case_tolerant {
321 return 1;
322}
323
270d1e39
GS
324=item path (override)
325
326Translate logical name DCL$PATH as a searchlist, rather than trying
327to C<split> string value of C<$ENV{'PATH'}>.
328
329=cut
330
331sub path {
cbc7acb0 332 my (@dirs,$dir,$i);
270d1e39 333 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
cbc7acb0 334 return @dirs;
270d1e39
GS
335}
336
337=item file_name_is_absolute (override)
338
339Checks for VMS directory spec as well as Unix separators.
340
341=cut
342
343sub file_name_is_absolute {
cbc7acb0 344 my ($self,$file) = @_;
270d1e39 345 # If it's a logical name, expand it.
ee8c7f54 346 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
1b1e14d3 347 return scalar($file =~ m!^/!s ||
cbc7acb0
JD
348 $file =~ m![<\[][^.\-\]>]! ||
349 $file =~ /:[^<\[]/);
270d1e39
GS
350}
351
46726cbe
CB
352=item splitpath (override)
353
354Splits using VMS syntax.
355
356=cut
357
358sub splitpath {
359 my($self,$path) = @_;
360 my($dev,$dir,$file) = ('','','');
361
1b1e14d3 362 vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
46726cbe
CB
363 return ($1 || '',$2 || '',$3);
364}
365
366=item splitdir (override)
367
368Split dirspec using VMS syntax.
369
370=cut
371
372sub splitdir {
373 my($self,$dirspec) = @_;
bdc74e5c
CB
374 $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
375 $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
376 $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
377 $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
378 $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
379 $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
380 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
381 # That loop does the following
382 # with any amount of dashes:
383 # .--. ==> .-.-.
384 # [--. ==> [-.-.
385 # .--] ==> .-.-]
386 # [--] ==> [-.-]
fd7385b9 387 $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
46726cbe 388 my(@dirs) = split('\.', vmspath($dirspec));
ee8c7f54 389 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
46726cbe
CB
390 @dirs;
391}
392
393
394=item catpath (override)
395
396Construct a complete filespec using VMS syntax
397
398=cut
399
400sub catpath {
401 my($self,$dev,$dir,$file) = @_;
638113eb
JH
402
403 # We look for a volume in $dev, then in $dir, but not both
404 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
405 $dev = $dir_volume unless length $dev;
406 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
407
fd7385b9 408 if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
ee8c7f54 409 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
fd7385b9
CB
410 if (length($dev) or length($dir)) {
411 $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
412 $dir = vmspath($dir);
0994714a 413 }
fd7385b9 414 "$dev$dir$file";
0994714a
GS
415}
416
fd7385b9 417=item abs2rel (override)
0994714a 418
fd7385b9 419Use VMS syntax when converting filespecs.
0994714a
GS
420
421=cut
422
0994714a
GS
423sub abs2rel {
424 my $self = shift;
fd7385b9 425 return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
638113eb 426 if grep m{/}, @_;
0994714a
GS
427
428 my($path,$base) = @_;
638113eb 429 $base = $self->_cwd() unless defined $base and length $base;
0994714a 430
638113eb 431 for ($path, $base) { $_ = $self->canonpath($_) }
0994714a 432
d84c672d
JH
433 # Are we even starting $path on the same (node::)device as $base? Note that
434 # logical paths or nodename differences may be on the "same device"
435 # but the comparison that ignores device differences so as to concatenate
436 # [---] up directory specs is not even a good idea in cases where there is
437 # a logical path difference between $path and $base nodename and/or device.
438 # Hence we fall back to returning the absolute $path spec
439 # if there is a case blind device (or node) difference of any sort
440 # and we do not even try to call $parse() or consult %ENV for $trnlnm()
441 # (this module needs to run on non VMS platforms after all).
638113eb
JH
442
443 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
444 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
445 return $path unless lc($path_volume) eq lc($base_volume);
d84c672d 446
638113eb 447 for ($path, $base) { $_ = $self->rel2abs($_) }
0994714a
GS
448
449 # Now, remove all leading components that are the same
450 my @pathchunks = $self->splitdir( $path_directories );
737c380e 451 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
0994714a 452 my @basechunks = $self->splitdir( $base_directories );
737c380e 453 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
0994714a
GS
454
455 while ( @pathchunks &&
456 @basechunks &&
457 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
458 ) {
459 shift @pathchunks ;
460 shift @basechunks ;
461 }
462
463 # @basechunks now contains the directories to climb out of,
464 # @pathchunks now has the directories to descend in to.
638113eb 465 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
fd7385b9 466 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
0994714a
GS
467}
468
469
fd7385b9
CB
470=item rel2abs (override)
471
472Use VMS syntax when converting filespecs.
473
474=cut
475
786b702f 476sub rel2abs {
0994714a 477 my $self = shift ;
0994714a 478 my ($path,$base ) = @_;
bdc74e5c 479 return undef unless defined $path;
21f4e7e5 480 $path = vmsify($path) if $path =~ m/\//;
bdc74e5c 481 $base = vmspath($base) if defined $base && $base =~ m/\//;
0994714a
GS
482 # Clean up and split up $path
483 if ( ! $self->file_name_is_absolute( $path ) ) {
484 # Figure out the effective $base and clean it up.
485 if ( !defined( $base ) || $base eq '' ) {
0fab864c 486 $base = $self->_cwd;
0994714a
GS
487 }
488 elsif ( ! $self->file_name_is_absolute( $base ) ) {
489 $base = $self->rel2abs( $base ) ;
490 }
491 else {
492 $base = $self->canonpath( $base ) ;
493 }
494
495 # Split up paths
ee8c7f54
CB
496 my ( $path_directories, $path_file ) =
497 ($self->splitpath( $path ))[1,2] ;
0994714a 498
ee8c7f54 499 my ( $base_volume, $base_directories ) =
0994714a
GS
500 $self->splitpath( $base ) ;
501
fd7385b9
CB
502 $path_directories = '' if $path_directories eq '[]' ||
503 $path_directories eq '<>';
0994714a
GS
504 my $sep = '' ;
505 $sep = '.'
ee8c7f54 506 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
fd7385b9 507 $path_directories =~ m{^[^.\[<]}s
0994714a 508 ) ;
fd7385b9
CB
509 $base_directories = "$base_directories$sep$path_directories";
510 $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
0994714a
GS
511
512 $path = $self->catpath( $base_volume, $base_directories, $path_file );
513 }
514
515 return $self->canonpath( $path ) ;
516}
517
518
cbc7acb0 519=back
270d1e39 520
cbc7acb0
JD
521=head1 SEE ALSO
522
72f15715
T
523See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
524implementation of these methods, not the semantics.
cbc7acb0 525
638113eb
JH
526An explanation of VMS file specs can be found at
527L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
528
cbc7acb0
JD
529=cut
530
5311;