This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid runtime module loading in File::Spec
[perl5.git] / dist / PathTools / lib / File / Spec / VMS.pm
1 package File::Spec::VMS;
2
3 use strict;
4 use Cwd ();
5 require File::Spec::Unix;
6
7 our $VERSION = '3.69';
8 $VERSION =~ tr/_//d;
9
10 our @ISA = qw(File::Spec::Unix);
11
12 use File::Basename;
13 use VMS::Filespec;
14
15 =head1 NAME
16
17 File::Spec::VMS - methods for VMS file specs
18
19 =head1 SYNOPSIS
20
21  require File::Spec::VMS; # Done internally by File::Spec if needed
22
23 =head1 DESCRIPTION
24
25 See File::Spec::Unix for a documentation of the methods provided
26 there. This package overrides the implementation of these methods, not
27 the semantics.
28
29 The default behavior is to allow either VMS or Unix syntax on input and to 
30 return VMS syntax on output unless Unix syntax has been explicitly requested
31 via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
32
33 =over 4
34
35 =cut
36
37 # Need to look up the feature settings.  The preferred way is to use the
38 # VMS::Feature module, but that may not be available to dual life modules.
39
40 my $use_feature;
41 BEGIN {
42     if (eval { local $SIG{__DIE__};
43                local @INC = @INC;
44                pop @INC if $INC[-1] eq '.';
45                require VMS::Feature; }) {
46         $use_feature = 1;
47     }
48 }
49
50 # Need to look up the UNIX report mode.  This may become a dynamic mode
51 # in the future.
52 sub _unix_rpt {
53     my $unix_rpt;
54     if ($use_feature) {
55         $unix_rpt = VMS::Feature::current("filename_unix_report");
56     } else {
57         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
58         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
59     }
60     return $unix_rpt;
61 }
62
63 =item canonpath (override)
64
65 Removes redundant portions of file specifications and returns results
66 in native syntax unless Unix filename reporting has been enabled.
67
68 =cut
69
70
71 sub canonpath {
72     my($self,$path) = @_;
73
74     return undef unless defined $path;
75
76     my $unix_rpt = $self->_unix_rpt;
77
78     if ($path =~ m|/|) {
79       my $pathify = $path =~ m|/\Z(?!\n)|;
80       $path = $self->SUPER::canonpath($path);
81
82       return $path if $unix_rpt;
83       $path = $pathify ? vmspath($path) : vmsify($path);
84     }
85
86     $path =~ s/(?<!\^)</[/;                     # < and >       ==> [ and ]
87     $path =~ s/(?<!\^)>/]/;
88     $path =~ s/(?<!\^)\]\[\./\.\]\[/g;          # ][.           ==> .][
89     $path =~ s/(?<!\^)\[000000\.\]\[/\[/g;      # [000000.][    ==> [
90     $path =~ s/(?<!\^)\[000000\./\[/g;          # [000000.      ==> [
91     $path =~ s/(?<!\^)\.\]\[000000\]/\]/g;      # .][000000]    ==> ]
92     $path =~ s/(?<!\^)\.\]\[/\./g;              # foo.][bar     ==> foo.bar
93     1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
94                                                 # That loop does the following
95                                                 # with any amount of dashes:
96                                                 # .-.-.         ==> .--.
97                                                 # [-.-.         ==> [--.
98                                                 # .-.-]         ==> .--]
99                                                 # [-.-]         ==> [--]
100     1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/);
101                                                 # That loop does the following
102                                                 # with any amount (minimum 2)
103                                                 # of dashes:
104                                                 # .foo.--.      ==> .-.
105                                                 # .foo.--]      ==> .-]
106                                                 # [foo.--.      ==> [-.
107                                                 # [foo.--]      ==> [-]
108                                                 #
109                                                 # And then, the remaining cases
110     $path =~ s/(?<!\^)\[\.-/[-/;                # [.-           ==> [-
111     $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g;     # .foo.-.       ==> .
112     $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g;     # [foo.-.       ==> [
113     $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g;     # .foo.-]       ==> ]
114                                                 # [foo.-]       ==> [000000]
115     $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g;
116                                                 # []            ==>
117     $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
118     return $unix_rpt ? unixify($path) : $path;
119 }
120
121 =item catdir (override)
122
123 Concatenates a list of file specifications, and returns the result as a
124 native directory specification unless the Unix filename reporting feature
125 has been enabled.  No check is made for "impossible" cases (e.g. elements
126 other than the first being absolute filespecs).
127
128 =cut
129
130 sub catdir {
131     my $self = shift;
132     my $dir = pop;
133
134     my $unix_rpt = $self->_unix_rpt;
135
136     my @dirs = grep {defined() && length()} @_;
137
138     my $rslt;
139     if (@dirs) {
140         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
141         my ($spath,$sdir) = ($path,$dir);
142         $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 
143
144         if ($unix_rpt) {
145             $spath = unixify($spath) unless $spath =~ m#/#;
146             $sdir= unixify($sdir) unless $sdir =~ m#/#;
147             return $self->SUPER::catdir($spath, $sdir)
148         }
149
150         $rslt = vmspath( unixify($spath) . '/' . unixify($sdir));
151
152         # Special case for VMS absolute directory specs: these will have
153         # had device prepended during trip through Unix syntax in
154         # eliminate_macros(), since Unix syntax has no way to express
155         # "absolute from the top of this device's directory tree".
156         if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
157
158     } else {
159         # Single directory. Return an empty string on null input; otherwise
160         # just return a canonical path.
161
162         if    (not defined $dir or not length $dir) {
163             $rslt = '';
164         } else {
165             $rslt = $unix_rpt ? $dir : vmspath($dir);
166         }
167     }
168     return $self->canonpath($rslt);
169 }
170
171 =item catfile (override)
172
173 Concatenates a list of directory specifications with a filename specification
174 to build a path.
175
176 =cut
177
178 sub catfile {
179     my $self = shift;
180     my $tfile = pop();
181     my $file = $self->canonpath($tfile);
182     my @files = grep {defined() && length()} @_;
183
184     my $unix_rpt = $self->_unix_rpt;
185
186     my $rslt;
187     if (@files) {
188         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
189         my $spath = $path;
190
191         # Something building a VMS path in pieces may try to pass a
192         # directory name in filename format, so normalize it.
193         $spath =~ s/\.dir\Z(?!\n)//i;
194
195         # If the spath ends with a directory delimiter and the file is bare,
196         # then just concatenate them.
197         if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
198             $rslt = "$spath$file";
199         } else {
200            $rslt = unixify($spath);
201            $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
202            $rslt = vmsify($rslt) unless $unix_rpt;
203         }
204     }
205     else {
206         # Only passed a single file?
207         my $xfile = (defined($file) && length($file)) ? $file : '';
208
209         $rslt = $unix_rpt ? $xfile : vmsify($xfile);
210     }
211     return $self->canonpath($rslt) unless $unix_rpt;
212
213     # In Unix report mode, do not strip off redundant path information.
214     return $rslt;
215 }
216
217
218 =item curdir (override)
219
220 Returns a string representation of the current directory: '[]' or '.'
221
222 =cut
223
224 sub curdir {
225     my $self = shift @_;
226     return '.' if ($self->_unix_rpt);
227     return '[]';
228 }
229
230 =item devnull (override)
231
232 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
233
234 =cut
235
236 sub devnull {
237     my $self = shift @_;
238     return '/dev/null' if ($self->_unix_rpt);
239     return "_NLA0:";
240 }
241
242 =item rootdir (override)
243
244 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
245 or '/'
246
247 =cut
248
249 sub rootdir {
250     my $self = shift @_;
251     if ($self->_unix_rpt) {
252        # Root may exist, try it first.
253        my $try = '/';
254        my ($dev1, $ino1) = stat('/');
255        my ($dev2, $ino2) = stat('.');
256
257        # Perl falls back to '.' if it can not determine '/'
258        if (($dev1 != $dev2) || ($ino1 != $ino2)) {
259            return $try;
260        }
261        # Fall back to UNIX format sys$disk.
262        return '/sys$disk/';
263     }
264     return 'SYS$DISK:[000000]';
265 }
266
267 =item tmpdir (override)
268
269 Returns a string representation of the first writable directory
270 from the following list or '' if none are writable:
271
272     /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
273     sys$scratch:
274     $ENV{TMPDIR}
275
276 If running under taint mode, and if $ENV{TMPDIR}
277 is tainted, it is not used.
278
279 =cut
280
281 sub tmpdir {
282     my $self = shift @_;
283     my $tmpdir = $self->_cached_tmpdir('TMPDIR');
284     return $tmpdir if defined $tmpdir;
285     if ($self->_unix_rpt) {
286         $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
287     }
288     else {
289         $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
290     }
291     $self->_cache_tmpdir($tmpdir, 'TMPDIR');
292 }
293
294 =item updir (override)
295
296 Returns a string representation of the parent directory: '[-]' or '..'
297
298 =cut
299
300 sub updir {
301     my $self = shift @_;
302     return '..' if ($self->_unix_rpt);
303     return '[-]';
304 }
305
306 =item case_tolerant (override)
307
308 VMS file specification syntax is case-tolerant.
309
310 =cut
311
312 sub case_tolerant {
313     return 1;
314 }
315
316 =item path (override)
317
318 Translate logical name DCL$PATH as a searchlist, rather than trying
319 to C<split> string value of C<$ENV{'PATH'}>.
320
321 =cut
322
323 sub path {
324     my (@dirs,$dir,$i);
325     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
326     return @dirs;
327 }
328
329 =item file_name_is_absolute (override)
330
331 Checks for VMS directory spec as well as Unix separators.
332
333 =cut
334
335 sub file_name_is_absolute {
336     my ($self,$file) = @_;
337     # If it's a logical name, expand it.
338     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
339     return scalar($file =~ m!^/!s             ||
340                   $file =~ m![<\[][^.\-\]>]!  ||
341                   $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
342 }
343
344 =item splitpath (override)
345
346    ($volume,$directories,$file) = File::Spec->splitpath( $path );
347    ($volume,$directories,$file) = File::Spec->splitpath( $path,
348                                                          $no_file );
349
350 Passing a true value for C<$no_file> indicates that the path being
351 split only contains directory components, even on systems where you
352 can usually (when not supporting a foreign syntax) tell the difference
353 between directories and files at a glance.
354
355 =cut
356
357 sub splitpath {
358     my($self,$path, $nofile) = @_;
359     my($dev,$dir,$file)      = ('','','');
360     my $vmsify_path = vmsify($path);
361
362     if ( $nofile ) {
363         #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
364         #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
365         if( $vmsify_path =~ /(.*)\](.+)/ ){
366             $vmsify_path = $1.'.'.$2.']';
367         }
368         $vmsify_path =~ /(.+:)?(.*)/s;
369         $dir = defined $2 ? $2 : ''; # dir can be '0'
370         return ($1 || '',$dir,$file);
371     }
372     else {
373         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
374         return ($1 || '',$2 || '',$3);
375     }
376 }
377
378 =item splitdir (override)
379
380 Split a directory specification into the components.
381
382 =cut
383
384 sub splitdir {
385     my($self,$dirspec) = @_;
386     my @dirs = ();
387     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
388
389     $dirspec =~ s/(?<!\^)</[/;                  # < and >       ==> [ and ]
390     $dirspec =~ s/(?<!\^)>/]/;
391     $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g;       # ][.           ==> .][
392     $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g;   # [000000.][    ==> [
393     $dirspec =~ s/(?<!\^)\[000000\./\[/g;       # [000000.      ==> [
394     $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g;   # .][000000]    ==> ]
395     $dirspec =~ s/(?<!\^)\.\]\[/\./g;           # foo.][bar     ==> foo.bar
396     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
397                                                 # That loop does the following
398                                                 # with any amount of dashes:
399                                                 # .--.          ==> .-.-.
400                                                 # [--.          ==> [-.-.
401                                                 # .--]          ==> .-.-]
402                                                 # [--]          ==> [-.-]
403     $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
404     $dirspec =~ s/^(\[|<)\./$1/;
405     @dirs = split /(?<!\^)\./, vmspath($dirspec);
406     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
407     @dirs;
408 }
409
410
411 =item catpath (override)
412
413 Construct a complete filespec.
414
415 =cut
416
417 sub catpath {
418     my($self,$dev,$dir,$file) = @_;
419     
420     # We look for a volume in $dev, then in $dir, but not both
421     my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
422     $dev = $dir_volume unless length $dev;
423     $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
424     
425     if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
426     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
427     if (length($dev) or length($dir)) {
428         $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
429         $dir = vmspath($dir);
430     }
431     $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
432     "$dev$dir$file";
433 }
434
435 =item abs2rel (override)
436
437 Attempt to convert an absolute file specification to a relative specification.
438
439 =cut
440
441 sub abs2rel {
442     my $self = shift;
443     my($path,$base) = @_;
444
445     $base = Cwd::getcwd() unless defined $base and length $base;
446
447     # If there is no device or directory syntax on $base, make sure it
448     # is treated as a directory.
449     $base = vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};
450
451     for ($path, $base) { $_ = $self->rel2abs($_) }
452
453     # Are we even starting $path on the same (node::)device as $base?  Note that
454     # logical paths or nodename differences may be on the "same device" 
455     # but the comparison that ignores device differences so as to concatenate 
456     # [---] up directory specs is not even a good idea in cases where there is 
457     # a logical path difference between $path and $base nodename and/or device.
458     # Hence we fall back to returning the absolute $path spec
459     # if there is a case blind device (or node) difference of any sort
460     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
461     # (this module needs to run on non VMS platforms after all).
462     
463     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
464     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
465     return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume);
466
467     # Now, remove all leading components that are the same
468     my @pathchunks = $self->splitdir( $path_directories );
469     my $pathchunks = @pathchunks;
470     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
471     my @basechunks = $self->splitdir( $base_directories );
472     my $basechunks = @basechunks;
473     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
474
475     while ( @pathchunks && 
476             @basechunks && 
477             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
478           ) {
479         shift @pathchunks ;
480         shift @basechunks ;
481     }
482
483     # @basechunks now contains the directories to climb out of,
484     # @pathchunks now has the directories to descend in to.
485     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
486       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
487     }
488     else {
489       $path_directories = join '.', @pathchunks;
490     }
491     $path_directories = '['.$path_directories.']';
492     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
493 }
494
495
496 =item rel2abs (override)
497
498 Return an absolute file specification from a relative one.
499
500 =cut
501
502 sub rel2abs {
503     my $self = shift ;
504     my ($path,$base ) = @_;
505     return undef unless defined $path;
506     if ($path =~ m/\//) {
507        $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
508                   ? vmspath($path)             # whether it's a directory
509                   : vmsify($path) );
510     }
511     $base = vmspath($base) if defined $base && $base =~ m/\//;
512
513     # Clean up and split up $path
514     if ( ! $self->file_name_is_absolute( $path ) ) {
515         # Figure out the effective $base and clean it up.
516         if ( !defined( $base ) || $base eq '' ) {
517             $base = Cwd::getcwd();
518         }
519         elsif ( ! $self->file_name_is_absolute( $base ) ) {
520             $base = $self->rel2abs( $base ) ;
521         }
522         else {
523             $base = $self->canonpath( $base ) ;
524         }
525
526         # Split up paths
527         my ( $path_directories, $path_file ) =
528             ($self->splitpath( $path ))[1,2] ;
529
530         my ( $base_volume, $base_directories ) =
531             $self->splitpath( $base ) ;
532
533         $path_directories = '' if $path_directories eq '[]' ||
534                                   $path_directories eq '<>';
535         my $sep = '' ;
536         $sep = '.'
537             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
538                  $path_directories =~ m{^[^.\[<]}s
539             ) ;
540         $base_directories = "$base_directories$sep$path_directories";
541         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
542
543         $path = $self->catpath( $base_volume, $base_directories, $path_file );
544    }
545
546     return $self->canonpath( $path ) ;
547 }
548
549
550 =back
551
552 =head1 COPYRIGHT
553
554 Copyright (c) 2004-14 by the Perl 5 Porters.  All rights reserved.
555
556 This program is free software; you can redistribute it and/or modify
557 it under the same terms as Perl itself.
558
559 =head1 SEE ALSO
560
561 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
562 implementation of these methods, not the semantics.
563
564 An explanation of VMS file specs can be found at
565 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
566
567 =cut
568
569 1;