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