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