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/\[\]// unless $path eq '[]';	# []		==>
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 = shift;
89    my $dir = pop;
90    my @dirs = grep {defined() && length()} @_;
91
92    my $rslt;
93    if (@dirs) {
94	my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
95	my ($spath,$sdir) = ($path,$dir);
96	$spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
97	$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
98	$rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
99
100	# Special case for VMS absolute directory specs: these will have had device
101	# prepended during trip through Unix syntax in eliminate_macros(), since
102	# Unix syntax has no way to express "absolute from the top of this device's
103	# directory tree".
104	if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
105    }
106    else {
107	if    (not defined $dir or not length $dir) { $rslt = ''; }
108	elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s)          { $rslt = $dir; }
109	else                                        { $rslt = vmspath($dir); }
110    }
111    return $self->canonpath($rslt);
112}
113
114=item catfile (override)
115
116Concatenates a list of file specifications, and returns the result as a
117VMS-syntax file specification.
118
119=cut
120
121sub catfile {
122    my $self = shift;
123    my $file = $self->canonpath(pop());
124    my @files = grep {defined() && length()} @_;
125
126    my $rslt;
127    if (@files) {
128	my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
129	my $spath = $path;
130	$spath =~ s/\.dir\Z(?!\n)//;
131	if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
132	    $rslt = "$spath$file";
133	}
134	else {
135	    $rslt = $self->eliminate_macros($spath);
136	    $rslt = vmsify($rslt.((defined $rslt) && ($rslt ne '') ? '/' : '').unixify($file));
137	}
138    }
139    else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
140    return $self->canonpath($rslt);
141}
142
143
144=item curdir (override)
145
146Returns a string representation of the current directory: '[]'
147
148=cut
149
150sub curdir {
151    return '[]';
152}
153
154=item devnull (override)
155
156Returns a string representation of the null device: '_NLA0:'
157
158=cut
159
160sub devnull {
161    return "_NLA0:";
162}
163
164=item rootdir (override)
165
166Returns a string representation of the root directory: 'SYS$DISK:[000000]'
167
168=cut
169
170sub rootdir {
171    return 'SYS$DISK:[000000]';
172}
173
174=item tmpdir (override)
175
176Returns a string representation of the first writable directory
177from the following list or '' if none are writable:
178
179    sys$scratch:
180    $ENV{TMPDIR}
181
182Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
183is tainted, it is not used.
184
185=cut
186
187my $tmpdir;
188sub tmpdir {
189    return $tmpdir if defined $tmpdir;
190    $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
191}
192
193=item updir (override)
194
195Returns a string representation of the parent directory: '[-]'
196
197=cut
198
199sub updir {
200    return '[-]';
201}
202
203=item case_tolerant (override)
204
205VMS file specification syntax is case-tolerant.
206
207=cut
208
209sub case_tolerant {
210    return 1;
211}
212
213=item path (override)
214
215Translate logical name DCL$PATH as a searchlist, rather than trying
216to C<split> string value of C<$ENV{'PATH'}>.
217
218=cut
219
220sub path {
221    my (@dirs,$dir,$i);
222    while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
223    return @dirs;
224}
225
226=item file_name_is_absolute (override)
227
228Checks for VMS directory spec as well as Unix separators.
229
230=cut
231
232sub file_name_is_absolute {
233    my ($self,$file) = @_;
234    # If it's a logical name, expand it.
235    $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
236    return scalar($file =~ m!^/!s             ||
237		  $file =~ m![<\[][^.\-\]>]!  ||
238		  $file =~ /:[^<\[]/);
239}
240
241=item splitpath (override)
242
243Splits using VMS syntax.
244
245=cut
246
247sub splitpath {
248    my($self,$path) = @_;
249    my($dev,$dir,$file) = ('','','');
250
251    vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
252    return ($1 || '',$2 || '',$3);
253}
254
255=item splitdir (override)
256
257Split dirspec using VMS syntax.
258
259=cut
260
261sub splitdir {
262    my($self,$dirspec) = @_;
263    $dirspec =~ tr/<>/[]/;			# < and >	==> [ and ]
264    $dirspec =~ s/\]\[\./\.\]\[/g;		# ][.		==> .][
265    $dirspec =~ s/\[000000\.\]\[/\[/g;		# [000000.][	==> [
266    $dirspec =~ s/\[000000\./\[/g;		# [000000.	==> [
267    $dirspec =~ s/\.\]\[000000\]/\]/g;		# .][000000]	==> ]
268    $dirspec =~ s/\.\]\[/\./g;			# foo.][bar	==> foo.bar
269    while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
270						# That loop does the following
271						# with any amount of dashes:
272						# .--.		==> .-.-.
273						# [--.		==> [-.-.
274						# .--]		==> .-.-]
275						# [--]		==> [-.-]
276    $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
277    my(@dirs) = split('\.', vmspath($dirspec));
278    $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
279    @dirs;
280}
281
282
283=item catpath (override)
284
285Construct a complete filespec using VMS syntax
286
287=cut
288
289sub catpath {
290    my($self,$dev,$dir,$file) = @_;
291
292    # We look for a volume in $dev, then in $dir, but not both
293    my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
294    $dev = $dir_volume unless length $dev;
295    $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
296
297    if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
298    else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
299    if (length($dev) or length($dir)) {
300      $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
301      $dir = vmspath($dir);
302    }
303    "$dev$dir$file";
304}
305
306=item abs2rel (override)
307
308Use VMS syntax when converting filespecs.
309
310=cut
311
312sub abs2rel {
313    my $self = shift;
314    return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
315        if grep m{/}, @_;
316
317    my($path,$base) = @_;
318    $base = $self->_cwd() unless defined $base and length $base;
319
320    for ($path, $base) { $_ = $self->canonpath($_) }
321
322    # Are we even starting $path on the same (node::)device as $base?  Note that
323    # logical paths or nodename differences may be on the "same device"
324    # but the comparison that ignores device differences so as to concatenate
325    # [---] up directory specs is not even a good idea in cases where there is
326    # a logical path difference between $path and $base nodename and/or device.
327    # Hence we fall back to returning the absolute $path spec
328    # if there is a case blind device (or node) difference of any sort
329    # and we do not even try to call $parse() or consult %ENV for $trnlnm()
330    # (this module needs to run on non VMS platforms after all).
331
332    my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
333    my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
334    return $path unless lc($path_volume) eq lc($base_volume);
335
336    for ($path, $base) { $_ = $self->rel2abs($_) }
337
338    # Now, remove all leading components that are the same
339    my @pathchunks = $self->splitdir( $path_directories );
340    my $pathchunks = @pathchunks;
341    unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
342    my @basechunks = $self->splitdir( $base_directories );
343    my $basechunks = @basechunks;
344    unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
345
346    while ( @pathchunks &&
347            @basechunks &&
348            lc( $pathchunks[0] ) eq lc( $basechunks[0] )
349          ) {
350        shift @pathchunks ;
351        shift @basechunks ;
352    }
353
354    # @basechunks now contains the directories to climb out of,
355    # @pathchunks now has the directories to descend in to.
356    if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
357      $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
358    }
359    else {
360      $path_directories = join '.', @pathchunks;
361    }
362    $path_directories = '['.$path_directories.']';
363    return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
364}
365
366
367=item rel2abs (override)
368
369Use VMS syntax when converting filespecs.
370
371=cut
372
373sub rel2abs {
374    my $self = shift ;
375    my ($path,$base ) = @_;
376    return undef unless defined $path;
377    if ($path =~ m/\//) {
378	$path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
379		   ? vmspath($path)             # whether it's a directory
380		   : vmsify($path) );
381    }
382    $base = vmspath($base) if defined $base && $base =~ m/\//;
383    # Clean up and split up $path
384    if ( ! $self->file_name_is_absolute( $path ) ) {
385        # Figure out the effective $base and clean it up.
386        if ( !defined( $base ) || $base eq '' ) {
387            $base = $self->_cwd;
388        }
389        elsif ( ! $self->file_name_is_absolute( $base ) ) {
390            $base = $self->rel2abs( $base ) ;
391        }
392        else {
393            $base = $self->canonpath( $base ) ;
394        }
395
396        # Split up paths
397        my ( $path_directories, $path_file ) =
398            ($self->splitpath( $path ))[1,2] ;
399
400        my ( $base_volume, $base_directories ) =
401            $self->splitpath( $base ) ;
402
403        $path_directories = '' if $path_directories eq '[]' ||
404                                  $path_directories eq '<>';
405        my $sep = '' ;
406        $sep = '.'
407            if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
408                 $path_directories =~ m{^[^.\[<]}s
409            ) ;
410        $base_directories = "$base_directories$sep$path_directories";
411        $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
412
413        $path = $self->catpath( $base_volume, $base_directories, $path_file );
414   }
415
416    return $self->canonpath( $path ) ;
417}
418
419
420# eliminate_macros() and fixpath() are MakeMaker-specific methods
421# which are used inside catfile() and catdir().  MakeMaker has its own
422# copies as of 6.06_03 which are the canonical ones.  We leave these
423# here, in peace, so that File::Spec continues to work with MakeMakers
424# prior to 6.06_03.
425#
426# Please consider these two methods deprecated.  Do not patch them,
427# patch the ones in ExtUtils::MM_VMS instead.
428sub eliminate_macros {
429    my($self,$path) = @_;
430    return '' unless (defined $path) && ($path ne '');
431    $self = {} unless ref $self;
432
433    if ($path =~ /\s/) {
434      return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
435    }
436
437    my($npath) = unixify($path);
438    my($complex) = 0;
439    my($head,$macro,$tail);
440
441    # perform m##g in scalar context so it acts as an iterator
442    while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
443        if ($self->{$2}) {
444            ($head,$macro,$tail) = ($1,$2,$3);
445            if (ref $self->{$macro}) {
446                if (ref $self->{$macro} eq 'ARRAY') {
447                    $macro = join ' ', @{$self->{$macro}};
448                }
449                else {
450                    print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
451                          "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
452                    $macro = "\cB$macro\cB";
453                    $complex = 1;
454                }
455            }
456            else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
457            $npath = "$head$macro$tail";
458        }
459    }
460    if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
461    $npath;
462}
463
464# Deprecated.  See the note above for eliminate_macros().
465sub fixpath {
466    my($self,$path,$force_path) = @_;
467    return '' unless $path;
468    $self = bless {} unless ref $self;
469    my($fixedpath,$prefix,$name);
470
471    if ($path =~ /\s/) {
472      return join ' ',
473             map { $self->fixpath($_,$force_path) }
474	     split /\s+/, $path;
475    }
476
477    if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
478        if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
479            $fixedpath = vmspath($self->eliminate_macros($path));
480        }
481        else {
482            $fixedpath = vmsify($self->eliminate_macros($path));
483        }
484    }
485    elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
486        my($vmspre) = $self->eliminate_macros("\$($prefix)");
487        # is it a dir or just a name?
488        $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
489        $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
490        $fixedpath = vmspath($fixedpath) if $force_path;
491    }
492    else {
493        $fixedpath = $path;
494        $fixedpath = vmspath($fixedpath) if $force_path;
495    }
496    # No hints, so we try to guess
497    if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
498        $fixedpath = vmspath($fixedpath) if -d $fixedpath;
499    }
500
501    # Trim off root dirname if it's had other dirs inserted in front of it.
502    $fixedpath =~ s/\.000000([\]>])/$1/;
503    # Special case for VMS absolute directory specs: these will have had device
504    # prepended during trip through Unix syntax in eliminate_macros(), since
505    # Unix syntax has no way to express "absolute from the top of this device's
506    # directory tree".
507    if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
508    $fixedpath;
509}
510
511
512=back
513
514=head1 COPYRIGHT
515
516Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
517
518This program is free software; you can redistribute it and/or modify
519it under the same terms as Perl itself.
520
521=head1 SEE ALSO
522
523See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
524implementation of these methods, not the semantics.
525
526An explanation of VMS file specs can be found at
527L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
528
529=cut
530
5311;
532