summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm
blob: cbafdce88abc9bde639895b3c2c0b6f4c9012436 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
package File::Spec::VMS;

use strict;
use Cwd ();
require File::Spec::Unix;

our $VERSION = '3.74';
$VERSION =~ tr/_//d;

our @ISA = qw(File::Spec::Unix);

use File::Basename;
use VMS::Filespec;

=head1 NAME

File::Spec::VMS - methods for VMS file specs

=head1 SYNOPSIS

 require File::Spec::VMS; # Done internally by File::Spec if needed

=head1 DESCRIPTION

See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

The default behavior is to allow either VMS or Unix syntax on input and to 
return VMS syntax on output unless Unix syntax has been explicitly requested
via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.

=over 4

=cut

# Need to look up the feature settings.  The preferred way is to use the
# VMS::Feature module, but that may not be available to dual life modules.

my $use_feature;
BEGIN {
    if (eval { local $SIG{__DIE__};
               local @INC = @INC;
               pop @INC if $INC[-1] eq '.';
               require VMS::Feature; }) {
        $use_feature = 1;
    }
}

# Need to look up the UNIX report mode.  This may become a dynamic mode
# in the future.
sub _unix_rpt {
    my $unix_rpt;
    if ($use_feature) {
        $unix_rpt = VMS::Feature::current("filename_unix_report");
    } else {
        my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
        $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
    }
    return $unix_rpt;
}

=item canonpath (override)

Removes redundant portions of file specifications and returns results
in native syntax unless Unix filename reporting has been enabled.

=cut


sub canonpath {
    my($self,$path) = @_;

    return undef unless defined $path;

    my $unix_rpt = $self->_unix_rpt;

    if ($path =~ m|/|) {
      my $pathify = $path =~ m|/\Z(?!\n)|;
      $path = $self->SUPER::canonpath($path);

      return $path if $unix_rpt;
      $path = $pathify ? vmspath($path) : vmsify($path);
    }

    $path =~ s/(?<!\^)</[/;			# < and >       ==> [ and ]
    $path =~ s/(?<!\^)>/]/;
    $path =~ s/(?<!\^)\]\[\./\.\]\[/g;		# ][.		==> .][
    $path =~ s/(?<!\^)\[000000\.\]\[/\[/g;	# [000000.][	==> [
    $path =~ s/(?<!\^)\[000000\./\[/g;		# [000000.	==> [
    $path =~ s/(?<!\^)\.\]\[000000\]/\]/g;	# .][000000]	==> ]
    $path =~ s/(?<!\^)\.\]\[/\./g;		# foo.][bar     ==> foo.bar
    1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
						# That loop does the following
						# with any amount of dashes:
						# .-.-.		==> .--.
						# [-.-.		==> [--.
						# .-.-]		==> .--]
						# [-.-]		==> [--]
    1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/);
						# That loop does the following
						# with any amount (minimum 2)
						# of dashes:
						# .foo.--.	==> .-.
						# .foo.--]	==> .-]
						# [foo.--.	==> [-.
						# [foo.--]	==> [-]
						#
						# And then, the remaining cases
    $path =~ s/(?<!\^)\[\.-/[-/;		# [.-		==> [-
    $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g;	# .foo.-.	==> .
    $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g;	# [foo.-.	==> [
    $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g;	# .foo.-]	==> ]
						# [foo.-]       ==> [000000]
    $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g;
						# []		==>
    $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
    return $unix_rpt ? unixify($path) : $path;
}

=item catdir (override)

Concatenates a list of file specifications, and returns the result as a
native directory specification unless the Unix filename reporting feature
has been enabled.  No check is made for "impossible" cases (e.g. elements
other than the first being absolute filespecs).

=cut

sub catdir {
    my $self = shift;
    my $dir = pop;

    my $unix_rpt = $self->_unix_rpt;

    my @dirs = grep {defined() && length()} @_;

    my $rslt;
    if (@dirs) {
	my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
	my ($spath,$sdir) = ($path,$dir);
	$spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 

	if ($unix_rpt) {
	    $spath = unixify($spath) unless $spath =~ m#/#;
	    $sdir= unixify($sdir) unless $sdir =~ m#/#;
            return $self->SUPER::catdir($spath, $sdir)
	}

	$rslt = vmspath( unixify($spath) . '/' . unixify($sdir));

	# Special case for VMS absolute directory specs: these will have
	# had device prepended during trip through Unix syntax in
	# eliminate_macros(), since Unix syntax has no way to express
	# "absolute from the top of this device's directory tree".
	if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }

    } else {
	# Single directory. Return an empty string on null input; otherwise
	# just return a canonical path.

	if    (not defined $dir or not length $dir) {
	    $rslt = '';
	} else {
	    $rslt = $unix_rpt ? $dir : vmspath($dir);
	}
    }
    return $self->canonpath($rslt);
}

=item catfile (override)

Concatenates a list of directory specifications with a filename specification
to build a path.

=cut

sub catfile {
    my $self = shift;
    my $tfile = pop();
    my $file = $self->canonpath($tfile);
    my @files = grep {defined() && length()} @_;

    my $unix_rpt = $self->_unix_rpt;

    my $rslt;
    if (@files) {
	my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
	my $spath = $path;

        # Something building a VMS path in pieces may try to pass a
        # directory name in filename format, so normalize it.
	$spath =~ s/\.dir\Z(?!\n)//i;

        # If the spath ends with a directory delimiter and the file is bare,
        # then just concatenate them.
	if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
	    $rslt = "$spath$file";
	} else {
           $rslt = unixify($spath);
           $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
           $rslt = vmsify($rslt) unless $unix_rpt;
	}
    }
    else {
        # Only passed a single file?
        my $xfile = (defined($file) && length($file)) ? $file : '';

        $rslt = $unix_rpt ? $xfile : vmsify($xfile);
    }
    return $self->canonpath($rslt) unless $unix_rpt;

    # In Unix report mode, do not strip off redundant path information.
    return $rslt;
}


=item curdir (override)

Returns a string representation of the current directory: '[]' or '.'

=cut

sub curdir {
    my $self = shift @_;
    return '.' if ($self->_unix_rpt);
    return '[]';
}

=item devnull (override)

Returns a string representation of the null device: '_NLA0:' or '/dev/null'

=cut

sub devnull {
    my $self = shift @_;
    return '/dev/null' if ($self->_unix_rpt);
    return "_NLA0:";
}

=item rootdir (override)

Returns a string representation of the root directory: 'SYS$DISK:[000000]'
or '/'

=cut

sub rootdir {
    my $self = shift @_;
    if ($self->_unix_rpt) {
       # Root may exist, try it first.
       my $try = '/';
       my ($dev1, $ino1) = stat('/');
       my ($dev2, $ino2) = stat('.');

       # Perl falls back to '.' if it can not determine '/'
       if (($dev1 != $dev2) || ($ino1 != $ino2)) {
           return $try;
       }
       # Fall back to UNIX format sys$disk.
       return '/sys$disk/';
    }
    return 'SYS$DISK:[000000]';
}

=item tmpdir (override)

Returns a string representation of the first writable directory
from the following list or '' if none are writable:

    /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
    sys$scratch:
    $ENV{TMPDIR}

If running under taint mode, and if $ENV{TMPDIR}
is tainted, it is not used.

=cut

sub tmpdir {
    my $self = shift @_;
    my $tmpdir = $self->_cached_tmpdir('TMPDIR');
    return $tmpdir if defined $tmpdir;
    if ($self->_unix_rpt) {
        $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
    }
    else {
        $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
    }
    $self->_cache_tmpdir($tmpdir, 'TMPDIR');
}

=item updir (override)

Returns a string representation of the parent directory: '[-]' or '..'

=cut

sub updir {
    my $self = shift @_;
    return '..' if ($self->_unix_rpt);
    return '[-]';
}

=item case_tolerant (override)

VMS file specification syntax is case-tolerant.

=cut

sub case_tolerant {
    return 1;
}

=item path (override)

Translate logical name DCL$PATH as a searchlist, rather than trying
to C<split> string value of C<$ENV{'PATH'}>.

=cut

sub path {
    my (@dirs,$dir,$i);
    while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
    return @dirs;
}

=item file_name_is_absolute (override)

Checks for VMS directory spec as well as Unix separators.

=cut

sub file_name_is_absolute {
    my ($self,$file) = @_;
    # If it's a logical name, expand it.
    $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
    return scalar($file =~ m!^/!s             ||
		  $file =~ m![<\[][^.\-\]>]!  ||
		  $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
}

=item splitpath (override)

   ($volume,$directories,$file) = File::Spec->splitpath( $path );
   ($volume,$directories,$file) = File::Spec->splitpath( $path,
                                                         $no_file );

Passing a true value for C<$no_file> indicates that the path being
split only contains directory components, even on systems where you
can usually (when not supporting a foreign syntax) tell the difference
between directories and files at a glance.

=cut

sub splitpath {
    my($self,$path, $nofile) = @_;
    my($dev,$dir,$file)      = ('','','');
    my $vmsify_path = vmsify($path);

    if ( $nofile ) {
        #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
        #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
        if( $vmsify_path =~ /(.*)\](.+)/ ){
            $vmsify_path = $1.'.'.$2.']';
        }
        $vmsify_path =~ /(.+:)?(.*)/s;
        $dir = defined $2 ? $2 : ''; # dir can be '0'
        return ($1 || '',$dir,$file);
    }
    else {
        $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
        return ($1 || '',$2 || '',$3);
    }
}

=item splitdir (override)

Split a directory specification into the components.

=cut

sub splitdir {
    my($self,$dirspec) = @_;
    my @dirs = ();
    return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );

    $dirspec =~ s/(?<!\^)</[/;                  # < and >	==> [ and ]
    $dirspec =~ s/(?<!\^)>/]/;
    $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g;	# ][.		==> .][
    $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g;	# [000000.][	==> [
    $dirspec =~ s/(?<!\^)\[000000\./\[/g;	# [000000.	==> [
    $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g;	# .][000000]	==> ]
    $dirspec =~ s/(?<!\^)\.\]\[/\./g;		# foo.][bar	==> foo.bar
    while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
						# That loop does the following
						# with any amount of dashes:
						# .--.		==> .-.-.
						# [--.		==> [-.-.
						# .--]		==> .-.-]
						# [--]		==> [-.-]
    $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
    $dirspec =~ s/^(\[|<)\./$1/;
    @dirs = split /(?<!\^)\./, vmspath($dirspec);
    $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
    @dirs;
}


=item catpath (override)

Construct a complete filespec.

=cut

sub catpath {
    my($self,$dev,$dir,$file) = @_;
    
    # We look for a volume in $dev, then in $dir, but not both
    my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
    $dev = $dir_volume unless length $dev;
    $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
    
    if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
    else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
    if (length($dev) or length($dir)) {
        $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
        $dir = vmspath($dir);
    }
    $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
    "$dev$dir$file";
}

=item abs2rel (override)

Attempt to convert an absolute file specification to a relative specification.

=cut

sub abs2rel {
    my $self = shift;
    my($path,$base) = @_;

    $base = Cwd::getcwd() unless defined $base and length $base;

    # If there is no device or directory syntax on $base, make sure it
    # is treated as a directory.
    $base = vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};

    for ($path, $base) { $_ = $self->rel2abs($_) }

    # Are we even starting $path on the same (node::)device as $base?  Note that
    # logical paths or nodename differences may be on the "same device" 
    # but the comparison that ignores device differences so as to concatenate 
    # [---] up directory specs is not even a good idea in cases where there is 
    # a logical path difference between $path and $base nodename and/or device.
    # Hence we fall back to returning the absolute $path spec
    # if there is a case blind device (or node) difference of any sort
    # and we do not even try to call $parse() or consult %ENV for $trnlnm()
    # (this module needs to run on non VMS platforms after all).
    
    my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
    my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
    return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume);

    # Now, remove all leading components that are the same
    my @pathchunks = $self->splitdir( $path_directories );
    my $pathchunks = @pathchunks;
    unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
    my @basechunks = $self->splitdir( $base_directories );
    my $basechunks = @basechunks;
    unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';

    while ( @pathchunks && 
            @basechunks && 
            lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
          ) {
        shift @pathchunks ;
        shift @basechunks ;
    }

    # @basechunks now contains the directories to climb out of,
    # @pathchunks now has the directories to descend in to.
    if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
      $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
    }
    else {
      $path_directories = join '.', @pathchunks;
    }
    $path_directories = '['.$path_directories.']';
    return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
}


=item rel2abs (override)

Return an absolute file specification from a relative one.

=cut

sub rel2abs {
    my $self = shift ;
    my ($path,$base ) = @_;
    return undef unless defined $path;
    if ($path =~ m/\//) {
       $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
                  ? vmspath($path)             # whether it's a directory
                  : vmsify($path) );
    }
    $base = vmspath($base) if defined $base && $base =~ m/\//;

    # Clean up and split up $path
    if ( ! $self->file_name_is_absolute( $path ) ) {
        # Figure out the effective $base and clean it up.
        if ( !defined( $base ) || $base eq '' ) {
            $base = Cwd::getcwd();
        }
        elsif ( ! $self->file_name_is_absolute( $base ) ) {
            $base = $self->rel2abs( $base ) ;
        }
        else {
            $base = $self->canonpath( $base ) ;
        }

        # Split up paths
        my ( $path_directories, $path_file ) =
            ($self->splitpath( $path ))[1,2] ;

        my ( $base_volume, $base_directories ) =
            $self->splitpath( $base ) ;

        $path_directories = '' if $path_directories eq '[]' ||
                                  $path_directories eq '<>';
        my $sep = '' ;
        $sep = '.'
            if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
                 $path_directories =~ m{^[^.\[<]}s
            ) ;
        $base_directories = "$base_directories$sep$path_directories";
        $base_directories =~ s{\.?[\]>][\[<]\.?}{.};

        $path = $self->catpath( $base_volume, $base_directories, $path_file );
   }

    return $self->canonpath( $path ) ;
}


=back

=head1 COPYRIGHT

Copyright (c) 2004-14 by the Perl 5 Porters.  All rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
implementation of these methods, not the semantics.

An explanation of VMS file specs can be found at
L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.

=cut

1;