"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/File/Spec/VMS.pm" (7 Mar 2020, 16326 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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