1package File::Spec::VMS;
2
3use strict;
4use Cwd ();
5require File::Spec::Unix;
6
7our $VERSION = '3.84';
8$VERSION =~ tr/_//d;
9
10our @ISA = qw(File::Spec::Unix);
11
12use File::Basename;
13use VMS::Filespec;
14
15=head1 NAME
16
17File::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
25See File::Spec::Unix for a documentation of the methods provided
26there. This package overrides the implementation of these methods, not
27the semantics.
28
29The default behavior is to allow either VMS or Unix syntax on input and to
30return VMS syntax on output unless Unix syntax has been explicitly requested
31via 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
40my $use_feature;
41BEGIN {
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.
52sub _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
65Removes redundant portions of file specifications and returns results
66in native syntax unless Unix filename reporting has been enabled.
67
68=cut
69
70
71sub 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
123Concatenates a list of file specifications, and returns the result as a
124native directory specification unless the Unix filename reporting feature
125has been enabled.  No check is made for "impossible" cases (e.g. elements
126other than the first being absolute filespecs).
127
128=cut
129
130sub 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
173Concatenates a list of directory specifications with a filename specification
174to build a path.
175
176=cut
177
178sub 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
220Returns a string representation of the current directory: '[]' or '.'
221
222=cut
223
224sub curdir {
225    my $self = shift @_;
226    return '.' if ($self->_unix_rpt);
227    return '[]';
228}
229
230=item devnull (override)
231
232Returns a string representation of the null device: '_NLA0:' or '/dev/null'
233
234=cut
235
236sub devnull {
237    my $self = shift @_;
238    return '/dev/null' if ($self->_unix_rpt);
239    return "_NLA0:";
240}
241
242=item rootdir (override)
243
244Returns a string representation of the root directory: 'SYS$DISK:[000000]'
245or '/'
246
247=cut
248
249sub 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
269Returns a string representation of the first writable directory
270from 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
276If running under taint mode, and if $ENV{TMPDIR}
277is tainted, it is not used.
278
279=cut
280
281sub 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
296Returns a string representation of the parent directory: '[-]' or '..'
297
298=cut
299
300sub updir {
301    my $self = shift @_;
302    return '..' if ($self->_unix_rpt);
303    return '[-]';
304}
305
306=item case_tolerant (override)
307
308VMS file specification syntax is case-tolerant.
309
310=cut
311
312sub case_tolerant {
313    return 1;
314}
315
316=item path (override)
317
318Translate logical name DCL$PATH as a searchlist, rather than trying
319to C<split> string value of C<$ENV{'PATH'}>.
320
321=cut
322
323sub 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
331Checks for VMS directory spec as well as Unix separators.
332
333=cut
334
335sub 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
350Passing a true value for C<$no_file> indicates that the path being
351split only contains directory components, even on systems where you
352can usually (when not supporting a foreign syntax) tell the difference
353between directories and files at a glance.
354
355=cut
356
357sub 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
380Split a directory specification into the components.
381
382=cut
383
384sub 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
413Construct a complete filespec.
414
415=cut
416
417sub 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
437Attempt to convert an absolute file specification to a relative specification.
438
439=cut
440
441sub 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
498Return an absolute file specification from a relative one.
499
500=cut
501
502sub 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
554Copyright (c) 2004-14 by the Perl 5 Porters.  All rights reserved.
555
556This program is free software; you can redistribute it and/or modify
557it under the same terms as Perl itself.
558
559=head1 SEE ALSO
560
561See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
562implementation of these methods, not the semantics.
563
564An explanation of VMS file specs can be found at
565L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
566
567=cut
568
5691;
570