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