1package File::Spec::VMS;
2
3use strict;
4use vars qw(@ISA $VERSION);
5require File::Spec::Unix;
6
7$VERSION = '1.4';
8
9@ISA = qw(File::Spec::Unix);
10
11use File::Basename;
12use VMS::Filespec;
13
14=head1 NAME
15
16File::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
24See File::Spec::Unix for a documentation of the methods provided
25there. This package overrides the implementation of these methods, not
26the semantics.
27
28=over 4
29
30=item canonpath (override)
31
32Removes redundant portions of file specifications according to VMS syntax.
33
34=cut
35
36sub 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
81Concatenates a list of file specifications, and returns the result as a
82VMS-syntax directory specification.  No check is made for "impossible"
83cases (e.g. elements other than the first being absolute filespecs).
84
85=cut
86
87sub 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
115Concatenates a list of file specifications, and returns the result as a
116VMS-syntax file specification.
117
118=cut
119
120sub 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
144Returns a string representation of the current directory: '[]'
145
146=cut
147
148sub curdir {
149    return '[]';
150}
151
152=item devnull (override)
153
154Returns a string representation of the null device: '_NLA0:'
155
156=cut
157
158sub devnull {
159    return "_NLA0:";
160}
161
162=item rootdir (override)
163
164Returns a string representation of the root directory: 'SYS$DISK:[000000]'
165
166=cut
167
168sub rootdir {
169    return 'SYS$DISK:[000000]';
170}
171
172=item tmpdir (override)
173
174Returns a string representation of the first writable directory
175from the following list or '' if none are writable:
176
177    sys$scratch:
178    $ENV{TMPDIR}
179
180Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
181is tainted, it is not used.
182
183=cut
184
185my $tmpdir;
186sub tmpdir {
187    return $tmpdir if defined $tmpdir;
188    $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
189}
190
191=item updir (override)
192
193Returns a string representation of the parent directory: '[-]'
194
195=cut
196
197sub updir {
198    return '[-]';
199}
200
201=item case_tolerant (override)
202
203VMS file specification syntax is case-tolerant.
204
205=cut
206
207sub case_tolerant {
208    return 1;
209}
210
211=item path (override)
212
213Translate logical name DCL$PATH as a searchlist, rather than trying
214to C<split> string value of C<$ENV{'PATH'}>.
215
216=cut
217
218sub 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
226Checks for VMS directory spec as well as Unix separators.
227
228=cut
229
230sub 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
241Splits using VMS syntax.
242
243=cut
244
245sub 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
255Split dirspec using VMS syntax.
256
257=cut
258
259sub 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
283Construct a complete filespec using VMS syntax
284
285=cut
286
287sub 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
306Use VMS syntax when converting filespecs.
307
308=cut
309
310sub 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
359Use VMS syntax when converting filespecs.
360
361=cut
362
363sub 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.
418sub 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().
455sub 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
506Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
507
508This program is free software; you can redistribute it and/or modify
509it under the same terms as Perl itself.
510
511=head1 SEE ALSO
512
513See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
514implementation of these methods, not the semantics.
515
516An explanation of VMS file specs can be found at
517L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
518
519=cut
520
5211;
522