This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use the base class cwd() method.
[perl5.git] / 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 = '1.4';
8
9 @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 =over 4
29
30 =item eliminate_macros
31
32 Expands MM[KS]/Make macros in a text string, using the contents of
33 identically named elements of C<%$self>, and returns the result
34 as a file specification in Unix syntax.
35
36 =cut
37
38 sub eliminate_macros {
39     my($self,$path) = @_;
40     return '' unless $path;
41     $self = {} unless ref $self;
42
43     if ($path =~ /\s/) {
44       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
45     }
46
47     my($npath) = unixify($path);
48     my($complex) = 0;
49     my($head,$macro,$tail);
50
51     # perform m##g in scalar context so it acts as an iterator
52     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
53         if ($self->{$2}) {
54             ($head,$macro,$tail) = ($1,$2,$3);
55             if (ref $self->{$macro}) {
56                 if (ref $self->{$macro} eq 'ARRAY') {
57                     $macro = join ' ', @{$self->{$macro}};
58                 }
59                 else {
60                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
61                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
62                     $macro = "\cB$macro\cB";
63                     $complex = 1;
64                 }
65             }
66             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
67             $npath = "$head$macro$tail";
68         }
69     }
70     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
71     $npath;
72 }
73
74 =item fixpath
75
76 Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
77 in any directory specification, in order to avoid juxtaposing two
78 VMS-syntax directories when MM[SK] is run.  Also expands expressions which
79 are all macro, so that we can tell how long the expansion is, and avoid
80 overrunning DCL's command buffer when MM[KS] is running.
81
82 If optional second argument has a TRUE value, then the return string is
83 a VMS-syntax directory specification, if it is FALSE, the return string
84 is a VMS-syntax file specification, and if it is not specified, fixpath()
85 checks to see whether it matches the name of a directory in the current
86 default directory, and returns a directory or file specification accordingly.
87
88 =cut
89
90 sub fixpath {
91     my($self,$path,$force_path) = @_;
92     return '' unless $path;
93     $self = bless {} unless ref $self;
94     my($fixedpath,$prefix,$name);
95
96     if ($path =~ /\s/) {
97       return join ' ',
98              map { $self->fixpath($_,$force_path) }
99              split /\s+/, $path;
100     }
101
102     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
103         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
104             $fixedpath = vmspath($self->eliminate_macros($path));
105         }
106         else {
107             $fixedpath = vmsify($self->eliminate_macros($path));
108         }
109     }
110     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
111         my($vmspre) = $self->eliminate_macros("\$($prefix)");
112         # is it a dir or just a name?
113         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
114         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
115         $fixedpath = vmspath($fixedpath) if $force_path;
116     }
117     else {
118         $fixedpath = $path;
119         $fixedpath = vmspath($fixedpath) if $force_path;
120     }
121     # No hints, so we try to guess
122     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
123         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
124     }
125
126     # Trim off root dirname if it's had other dirs inserted in front of it.
127     $fixedpath =~ s/\.000000([\]>])/$1/;
128     # Special case for VMS absolute directory specs: these will have had device
129     # prepended during trip through Unix syntax in eliminate_macros(), since
130     # Unix syntax has no way to express "absolute from the top of this device's
131     # directory tree".
132     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
133     $fixedpath;
134 }
135
136 =back
137
138 =head2 Methods always loaded
139
140 =over 4
141
142 =item canonpath (override)
143
144 Removes redundant portions of file specifications according to VMS syntax.
145
146 =cut
147
148 sub canonpath {
149     my($self,$path) = @_;
150
151     if ($path =~ m|/|) { # Fake Unix
152       my $pathify = $path =~ m|/\Z(?!\n)|;
153       $path = $self->SUPER::canonpath($path);
154       if ($pathify) { return vmspath($path); }
155       else          { return vmsify($path);  }
156     }
157     else {
158       $path =~ s/([\[<])000000\./$1/g;                  # [000000.foo     ==> [foo
159       $path =~ s/([^-]+)\.(\]\[|><)?000000([\]\>])/$1$3/g;  # foo.000000] ==> foo]
160       $path =~ s-\]\[--g;  $path =~ s/><//g;            # foo.][bar       ==> foo.bar
161       1 while $path =~ s{([\[<-])\.-}{$1-};             # [.-.-           ==> [--
162       $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/;            # bar.foo.-]      ==> bar]
163       $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s
164       $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g;    # bar.-.foo       ==> foo
165       $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode
166       $path =~ s/^[\[<\]>]{2}//;                        # []foo           ==> foo
167       return $path;
168     }
169 }
170
171 =item catdir
172
173 Concatenates a list of file specifications, and returns the result as a
174 VMS-syntax directory specification.  No check is made for "impossible"
175 cases (e.g. elements other than the first being absolute filespecs).
176
177 =cut
178
179 sub catdir {
180     my ($self,@dirs) = @_;
181     my $dir = pop @dirs;
182     @dirs = grep($_,@dirs);
183     my $rslt;
184     if (@dirs) {
185         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
186         my ($spath,$sdir) = ($path,$dir);
187         $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; 
188         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
189         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
190
191         # Special case for VMS absolute directory specs: these will have had device
192         # prepended during trip through Unix syntax in eliminate_macros(), since
193         # Unix syntax has no way to express "absolute from the top of this device's
194         # directory tree".
195         if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
196     }
197     else {
198         if    (not defined $dir or not length $dir) { $rslt = ''; }
199         elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s)          { $rslt = $dir; }
200         else                                        { $rslt = vmspath($dir); }
201     }
202     return $self->canonpath($rslt);
203 }
204
205 =item catfile
206
207 Concatenates a list of file specifications, and returns the result as a
208 VMS-syntax file specification.
209
210 =cut
211
212 sub catfile {
213     my ($self,@files) = @_;
214     my $file = $self->canonpath(pop @files);
215     @files = grep($_,@files);
216     my $rslt;
217     if (@files) {
218         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
219         my $spath = $path;
220         $spath =~ s/\.dir\Z(?!\n)//;
221         if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
222             $rslt = "$spath$file";
223         }
224         else {
225             $rslt = $self->eliminate_macros($spath);
226             $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
227         }
228     }
229     else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
230     return $self->canonpath($rslt);
231 }
232
233
234 =item curdir (override)
235
236 Returns a string representation of the current directory: '[]'
237
238 =cut
239
240 sub curdir {
241     return '[]';
242 }
243
244 =item devnull (override)
245
246 Returns a string representation of the null device: '_NLA0:'
247
248 =cut
249
250 sub devnull {
251     return "_NLA0:";
252 }
253
254 =item rootdir (override)
255
256 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
257
258 =cut
259
260 sub rootdir {
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     sys$scratch:
270     $ENV{TMPDIR}
271
272 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
273 is tainted, it is not used.
274
275 =cut
276
277 my $tmpdir;
278 sub tmpdir {
279     return $tmpdir if defined $tmpdir;
280     my $self = shift;
281     $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
282 }
283
284 =item updir (override)
285
286 Returns a string representation of the parent directory: '[-]'
287
288 =cut
289
290 sub updir {
291     return '[-]';
292 }
293
294 =item case_tolerant (override)
295
296 VMS file specification syntax is case-tolerant.
297
298 =cut
299
300 sub case_tolerant {
301     return 1;
302 }
303
304 =item path (override)
305
306 Translate logical name DCL$PATH as a searchlist, rather than trying
307 to C<split> string value of C<$ENV{'PATH'}>.
308
309 =cut
310
311 sub path {
312     my (@dirs,$dir,$i);
313     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
314     return @dirs;
315 }
316
317 =item file_name_is_absolute (override)
318
319 Checks for VMS directory spec as well as Unix separators.
320
321 =cut
322
323 sub file_name_is_absolute {
324     my ($self,$file) = @_;
325     # If it's a logical name, expand it.
326     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
327     return scalar($file =~ m!^/!s             ||
328                   $file =~ m![<\[][^.\-\]>]!  ||
329                   $file =~ /:[^<\[]/);
330 }
331
332 =item splitpath (override)
333
334 Splits using VMS syntax.
335
336 =cut
337
338 sub splitpath {
339     my($self,$path) = @_;
340     my($dev,$dir,$file) = ('','','');
341
342     vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
343     return ($1 || '',$2 || '',$3);
344 }
345
346 =item splitdir (override)
347
348 Split dirspec using VMS syntax.
349
350 =cut
351
352 sub splitdir {
353     my($self,$dirspec) = @_;
354     $dirspec =~ s/\]\[//g;  $dirspec =~ s/\-\-/-.-/g;
355     $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
356     my(@dirs) = split('\.', vmspath($dirspec));
357     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
358     @dirs;
359 }
360
361
362 =item catpath (override)
363
364 Construct a complete filespec using VMS syntax
365
366 =cut
367
368 sub catpath {
369     my($self,$dev,$dir,$file) = @_;
370     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
371     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
372     if (length($dev) or length($dir)) {
373       $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
374       $dir = vmspath($dir);
375     }
376     "$dev$dir$file";
377 }
378
379 =item abs2rel (override)
380
381 Use VMS syntax when converting filespecs.
382
383 =cut
384
385 sub abs2rel {
386     my $self = shift;
387
388     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
389         if ( join( '', @_ ) =~ m{/} ) ;
390
391     my($path,$base) = @_;
392
393     # Note: we use '/' to glue things together here, then let canonpath()
394     # clean them up at the end.
395
396     # Clean up $path
397     if ( ! $self->file_name_is_absolute( $path ) ) {
398         $path = $self->rel2abs( $path ) ;
399     }
400     else {
401         $path = $self->canonpath( $path ) ;
402     }
403
404     # Figure out the effective $base and clean it up.
405     if ( !defined( $base ) || $base eq '' ) {
406         $base = $self->canonpath( $self->cwd ) ;
407     }
408     elsif ( ! $self->file_name_is_absolute( $base ) ) {
409         $base = $self->rel2abs( $base ) ;
410     }
411     else {
412         $base = $self->canonpath( $base ) ;
413     }
414
415     # Split up paths
416     my ( $path_directories, $path_file ) =
417         ($self->splitpath( $path, 1 ))[1,2] ;
418
419     $path_directories = $1
420         if $path_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
421
422     my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
423
424     $base_directories = $1
425         if $base_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
426
427     # Now, remove all leading components that are the same
428     my @pathchunks = $self->splitdir( $path_directories );
429     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
430     my @basechunks = $self->splitdir( $base_directories );
431     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
432
433     while ( @pathchunks && 
434             @basechunks && 
435             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
436           ) {
437         shift @pathchunks ;
438         shift @basechunks ;
439     }
440
441     # @basechunks now contains the directories to climb out of,
442     # @pathchunks now has the directories to descend in to.
443     $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
444     $path_directories =~ s{\.\Z(?!\n)}{} ;
445     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
446 }
447
448
449 =item rel2abs (override)
450
451 Use VMS syntax when converting filespecs.
452
453 =cut
454
455 sub rel2abs {
456     my $self = shift ;
457     return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))
458         if ( join( '', @_ ) =~ m{/} ) ;
459
460     my ($path,$base ) = @_;
461     # Clean up and split up $path
462     if ( ! $self->file_name_is_absolute( $path ) ) {
463         # Figure out the effective $base and clean it up.
464         if ( !defined( $base ) || $base eq '' ) {
465             $base = $self->cwd;
466         }
467         elsif ( ! $self->file_name_is_absolute( $base ) ) {
468             $base = $self->rel2abs( $base ) ;
469         }
470         else {
471             $base = $self->canonpath( $base ) ;
472         }
473
474         # Split up paths
475         my ( $path_directories, $path_file ) =
476             ($self->splitpath( $path ))[1,2] ;
477
478         my ( $base_volume, $base_directories ) =
479             $self->splitpath( $base ) ;
480
481         $path_directories = '' if $path_directories eq '[]' ||
482                                   $path_directories eq '<>';
483         my $sep = '' ;
484         $sep = '.'
485             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
486                  $path_directories =~ m{^[^.\[<]}s
487             ) ;
488         $base_directories = "$base_directories$sep$path_directories";
489         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
490
491         $path = $self->catpath( $base_volume, $base_directories, $path_file );
492    }
493
494     return $self->canonpath( $path ) ;
495 }
496
497
498 =back
499
500 =head1 SEE ALSO
501
502 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
503 implementation of these methods, not the semantics.
504
505 =cut
506
507 1;