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