Update PathTools to CPAN version 3.60
[perl.git] / dist / PathTools / 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 = '3.60';
8 $VERSION =~ tr/_//d;
9
10 @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__}; require VMS::Feature; }) {
43         $use_feature = 1;
44     }
45 }
46
47 # Need to look up the UNIX report mode.  This may become a dynamic mode
48 # in the future.
49 sub _unix_rpt {
50     my $unix_rpt;
51     if ($use_feature) {
52         $unix_rpt = VMS::Feature::current("filename_unix_report");
53     } else {
54         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
55         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
56     }
57     return $unix_rpt;
58 }
59
60 =item canonpath (override)
61
62 Removes redundant portions of file specifications and returns results
63 in native syntax unless Unix filename reporting has been enabled.
64
65 =cut
66
67
68 sub canonpath {
69     my($self,$path) = @_;
70
71     return undef unless defined $path;
72
73     my $unix_rpt = $self->_unix_rpt;
74
75     if ($path =~ m|/|) {
76       my $pathify = $path =~ m|/\Z(?!\n)|;
77       $path = $self->SUPER::canonpath($path);
78
79       return $path if $unix_rpt;
80       $path = $pathify ? vmspath($path) : vmsify($path);
81     }
82
83     $path =~ s/(?<!\^)</[/;                     # < and >       ==> [ and ]
84     $path =~ s/(?<!\^)>/]/;
85     $path =~ s/(?<!\^)\]\[\./\.\]\[/g;          # ][.           ==> .][
86     $path =~ s/(?<!\^)\[000000\.\]\[/\[/g;      # [000000.][    ==> [
87     $path =~ s/(?<!\^)\[000000\./\[/g;          # [000000.      ==> [
88     $path =~ s/(?<!\^)\.\]\[000000\]/\]/g;      # .][000000]    ==> ]
89     $path =~ s/(?<!\^)\.\]\[/\./g;              # foo.][bar     ==> foo.bar
90     1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
91                                                 # That loop does the following
92                                                 # with any amount of dashes:
93                                                 # .-.-.         ==> .--.
94                                                 # [-.-.         ==> [--.
95                                                 # .-.-]         ==> .--]
96                                                 # [-.-]         ==> [--]
97     1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
98                                                 # That loop does the following
99                                                 # with any amount (minimum 2)
100                                                 # of dashes:
101                                                 # .foo.--.      ==> .-.
102                                                 # .foo.--]      ==> .-]
103                                                 # [foo.--.      ==> [-.
104                                                 # [foo.--]      ==> [-]
105                                                 #
106                                                 # And then, the remaining cases
107     $path =~ s/(?<!\^)\[\.-/[-/;                # [.-           ==> [-
108     $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g;     # .foo.-.       ==> .
109     $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g;     # [foo.-.       ==> [
110     $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g;     # .foo.-]       ==> ]
111                                                 # [foo.-]       ==> [000000]
112     $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g;
113                                                 # []            ==>
114     $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
115     return $unix_rpt ? unixify($path) : $path;
116 }
117
118 =item catdir (override)
119
120 Concatenates a list of file specifications, and returns the result as a
121 native directory specification unless the Unix filename reporting feature
122 has been enabled.  No check is made for "impossible" cases (e.g. elements
123 other than the first being absolute filespecs).
124
125 =cut
126
127 sub catdir {
128     my $self = shift;
129     my $dir = pop;
130
131     my $unix_rpt = $self->_unix_rpt;
132
133     my @dirs = grep {defined() && length()} @_;
134
135     my $rslt;
136     if (@dirs) {
137         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
138         my ($spath,$sdir) = ($path,$dir);
139         $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 
140
141         if ($unix_rpt) {
142             $spath = unixify($spath) unless $spath =~ m#/#;
143             $sdir= unixify($sdir) unless $sdir =~ m#/#;
144             return $self->SUPER::catdir($spath, $sdir)
145         }
146
147         $rslt = vmspath( unixify($spath) . '/' . unixify($sdir));
148
149         # Special case for VMS absolute directory specs: these will have
150         # had device prepended during trip through Unix syntax in
151         # eliminate_macros(), since Unix syntax has no way to express
152         # "absolute from the top of this device's directory tree".
153         if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
154
155     } else {
156         # Single directory. Return an empty string on null input; otherwise
157         # just return a canonical path.
158
159         if    (not defined $dir or not length $dir) {
160             $rslt = '';
161         } else {
162             $rslt = $unix_rpt ? $dir : vmspath($dir);
163         }
164     }
165     return $self->canonpath($rslt);
166 }
167
168 =item catfile (override)
169
170 Concatenates a list of directory specifications with a filename specification
171 to build a path.
172
173 =cut
174
175 sub catfile {
176     my $self = shift;
177     my $tfile = pop();
178     my $file = $self->canonpath($tfile);
179     my @files = grep {defined() && length()} @_;
180
181     my $unix_rpt = $self->_unix_rpt;
182
183     my $rslt;
184     if (@files) {
185         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
186         my $spath = $path;
187
188         # Something building a VMS path in pieces may try to pass a
189         # directory name in filename format, so normalize it.
190         $spath =~ s/\.dir\Z(?!\n)//i;
191
192         # If the spath ends with a directory delimiter and the file is bare,
193         # then just concatenate them.
194         if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
195             $rslt = "$spath$file";
196         } else {
197            $rslt = unixify($spath);
198            $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
199            $rslt = vmsify($rslt) unless $unix_rpt;
200         }
201     }
202     else {
203         # Only passed a single file?
204         my $xfile = (defined($file) && length($file)) ? $file : '';
205
206         $rslt = $unix_rpt ? $xfile : vmsify($xfile);
207     }
208     return $self->canonpath($rslt) unless $unix_rpt;
209
210     # In Unix report mode, do not strip off redundant path information.
211     return $rslt;
212 }
213
214
215 =item curdir (override)
216
217 Returns a string representation of the current directory: '[]' or '.'
218
219 =cut
220
221 sub curdir {
222     my $self = shift @_;
223     return '.' if ($self->_unix_rpt);
224     return '[]';
225 }
226
227 =item devnull (override)
228
229 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
230
231 =cut
232
233 sub devnull {
234     my $self = shift @_;
235     return '/dev/null' if ($self->_unix_rpt);
236     return "_NLA0:";
237 }
238
239 =item rootdir (override)
240
241 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
242 or '/'
243
244 =cut
245
246 sub rootdir {
247     my $self = shift @_;
248     if ($self->_unix_rpt) {
249        # Root may exist, try it first.
250        my $try = '/';
251        my ($dev1, $ino1) = stat('/');
252        my ($dev2, $ino2) = stat('.');
253
254        # Perl falls back to '.' if it can not determine '/'
255        if (($dev1 != $dev2) || ($ino1 != $ino2)) {
256            return $try;
257        }
258        # Fall back to UNIX format sys$disk.
259        return '/sys$disk/';
260     }
261     return 'SYS$DISK:[000000]';
262 }
263
264 =item tmpdir (override)
265
266 Returns a string representation of the first writable directory
267 from the following list or '' if none are writable:
268
269     /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
270     sys$scratch:
271     $ENV{TMPDIR}
272
273 If running under taint mode, and if $ENV{TMPDIR}
274 is tainted, it is not used.
275
276 =cut
277
278 sub tmpdir {
279     my $self = shift @_;
280     my $tmpdir = $self->_cached_tmpdir('TMPDIR');
281     return $tmpdir if defined $tmpdir;
282     if ($self->_unix_rpt) {
283         $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
284     }
285     else {
286         $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
287     }
288     $self->_cache_tmpdir($tmpdir, 'TMPDIR');
289 }
290
291 =item updir (override)
292
293 Returns a string representation of the parent directory: '[-]' or '..'
294
295 =cut
296
297 sub updir {
298     my $self = shift @_;
299     return '..' if ($self->_unix_rpt);
300     return '[-]';
301 }
302
303 =item case_tolerant (override)
304
305 VMS file specification syntax is case-tolerant.
306
307 =cut
308
309 sub case_tolerant {
310     return 1;
311 }
312
313 =item path (override)
314
315 Translate logical name DCL$PATH as a searchlist, rather than trying
316 to C<split> string value of C<$ENV{'PATH'}>.
317
318 =cut
319
320 sub path {
321     my (@dirs,$dir,$i);
322     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
323     return @dirs;
324 }
325
326 =item file_name_is_absolute (override)
327
328 Checks for VMS directory spec as well as Unix separators.
329
330 =cut
331
332 sub file_name_is_absolute {
333     my ($self,$file) = @_;
334     # If it's a logical name, expand it.
335     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
336     return scalar($file =~ m!^/!s             ||
337                   $file =~ m![<\[][^.\-\]>]!  ||
338                   $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
339 }
340
341 =item splitpath (override)
342
343    ($volume,$directories,$file) = File::Spec->splitpath( $path );
344    ($volume,$directories,$file) = File::Spec->splitpath( $path,
345                                                          $no_file );
346
347 Passing a true value for C<$no_file> indicates that the path being
348 split only contains directory components, even on systems where you
349 can usually (when not supporting a foreign syntax) tell the difference
350 between directories and files at a glance.
351
352 =cut
353
354 sub splitpath {
355     my($self,$path, $nofile) = @_;
356     my($dev,$dir,$file)      = ('','','');
357     my $vmsify_path = vmsify($path);
358
359     if ( $nofile ) {
360         #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
361         #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
362         if( $vmsify_path =~ /(.*)\](.+)/ ){
363             $vmsify_path = $1.'.'.$2.']';
364         }
365         $vmsify_path =~ /(.+:)?(.*)/s;
366         $dir = defined $2 ? $2 : ''; # dir can be '0'
367         return ($1 || '',$dir,$file);
368     }
369     else {
370         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
371         return ($1 || '',$2 || '',$3);
372     }
373 }
374
375 =item splitdir (override)
376
377 Split a directory specification into the components.
378
379 =cut
380
381 sub splitdir {
382     my($self,$dirspec) = @_;
383     my @dirs = ();
384     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
385
386     $dirspec =~ s/(?<!\^)</[/;                  # < and >       ==> [ and ]
387     $dirspec =~ s/(?<!\^)>/]/;
388     $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g;       # ][.           ==> .][
389     $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g;   # [000000.][    ==> [
390     $dirspec =~ s/(?<!\^)\[000000\./\[/g;       # [000000.      ==> [
391     $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g;   # .][000000]    ==> ]
392     $dirspec =~ s/(?<!\^)\.\]\[/\./g;           # foo.][bar     ==> foo.bar
393     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
394                                                 # That loop does the following
395                                                 # with any amount of dashes:
396                                                 # .--.          ==> .-.-.
397                                                 # [--.          ==> [-.-.
398                                                 # .--]          ==> .-.-]
399                                                 # [--]          ==> [-.-]
400     $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
401     $dirspec =~ s/^(\[|<)\./$1/;
402     @dirs = split /(?<!\^)\./, vmspath($dirspec);
403     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
404     @dirs;
405 }
406
407
408 =item catpath (override)
409
410 Construct a complete filespec.
411
412 =cut
413
414 sub catpath {
415     my($self,$dev,$dir,$file) = @_;
416     
417     # We look for a volume in $dev, then in $dir, but not both
418     my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
419     $dev = $dir_volume unless length $dev;
420     $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
421     
422     if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
423     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
424     if (length($dev) or length($dir)) {
425         $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
426         $dir = vmspath($dir);
427     }
428     $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
429     "$dev$dir$file";
430 }
431
432 =item abs2rel (override)
433
434 Attempt to convert an absolute file specification to a relative specification.
435
436 =cut
437
438 sub abs2rel {
439     my $self = shift;
440     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
441         if ((grep m{/}, @_) && !(grep m{(?<!\^)[\[<:]}, @_));
442
443     my($path,$base) = @_;
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 = VMS::Filespec::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 $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;