dist/PathTools/lib/File/Spec/VMS.pm

   1 package File::Spec::VMS;
   2
   3 use strict;
   4 require File::Spec::Unix;
   5
   6 our $VERSION = '3.69';
   7 $VERSION =~ tr/_//d;
   8
   9 our @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 The default behavior is to allow either VMS or Unix syntax on input and to
  29 return VMS syntax on output unless Unix syntax has been explicitly requested
  30 via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
  31
  32 =over 4
  33
  34 =cut
  35
  36 # Need to look up the feature settings.  The preferred way is to use the
  37 # VMS::Feature module, but that may not be available to dual life modules.
  38
  39 my $use_feature;
  40 BEGIN {
  41     if (eval { local $SIG{__DIE__};
  42                local @INC = @INC;
  43                pop @INC if $INC[-1] eq '.';
  44                require VMS::Feature; }) {
  45         $use_feature = 1;
  46     }
  47 }
  48
  49 # Need to look up the UNIX report mode.  This may become a dynamic mode
  50 # in the future.
  51 sub _unix_rpt {
  52     my $unix_rpt;
  53     if ($use_feature) {
  54         $unix_rpt = VMS::Feature::current("filename_unix_report");
  55     } else {
  56         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
  57         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
  58     }
  59     return $unix_rpt;
  60 }
  61
  62 =item canonpath (override)
  63
  64 Removes redundant portions of file specifications and returns results
  65 in native syntax unless Unix filename reporting has been enabled.
  66
  67 =cut
  68
  69
  70 sub canonpath {
  71     my($self,$path) = @_;
  72
  73     return undef unless defined $path;
  74
  75     my $unix_rpt = $self->_unix_rpt;
  76
  77     if ($path =~ m|/|) {
  78       my $pathify = $path =~ m|/\Z(?!\n)|;
  79       $path = $self->SUPER::canonpath($path);
  80
  81       return $path if $unix_rpt;
  82       $path = $pathify ? vmspath($path) : vmsify($path);
  83     }
  84
  85     $path =~ s/(?<!\^)</[/;                     # < and >       ==> [ and ]
  86     $path =~ s/(?<!\^)>/]/;
  87     $path =~ s/(?<!\^)\]\[\./\.\]\[/g;          # ][.           ==> .][
  88     $path =~ s/(?<!\^)\[000000\.\]\[/\[/g;      # [000000.][    ==> [
  89     $path =~ s/(?<!\^)\[000000\./\[/g;          # [000000.      ==> [
  90     $path =~ s/(?<!\^)\.\]\[000000\]/\]/g;      # .][000000]    ==> ]
  91     $path =~ s/(?<!\^)\.\]\[/\./g;              # foo.][bar     ==> foo.bar
  92     1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
  93                                                 # That loop does the following
  94                                                 # with any amount of dashes:
  95                                                 # .-.-.         ==> .--.
  96                                                 # [-.-.         ==> [--.
  97                                                 # .-.-]         ==> .--]
  98                                                 # [-.-]         ==> [--]
  99     1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/);
 100                                                 # That loop does the following
 101                                                 # with any amount (minimum 2)
 102                                                 # of dashes:
 103                                                 # .foo.--.      ==> .-.
 104                                                 # .foo.--]      ==> .-]
 105                                                 # [foo.--.      ==> [-.
 106                                                 # [foo.--]      ==> [-]
 107                                                 #
 108                                                 # And then, the remaining cases
 109     $path =~ s/(?<!\^)\[\.-/[-/;                # [.-           ==> [-
 110     $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g;     # .foo.-.       ==> .
 111     $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g;     # [foo.-.       ==> [
 112     $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g;     # .foo.-]       ==> ]
 113                                                 # [foo.-]       ==> [000000]
 114     $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g;
 115                                                 # []            ==>
 116     $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
 117     return $unix_rpt ? unixify($path) : $path;
 118 }
 119
 120 =item catdir (override)
 121
 122 Concatenates a list of file specifications, and returns the result as a
 123 native directory specification unless the Unix filename reporting feature
 124 has been enabled.  No check is made for "impossible" cases (e.g. elements
 125 other than the first being absolute filespecs).
 126
 127 =cut
 128
 129 sub catdir {
 130     my $self = shift;
 131     my $dir = pop;
 132
 133     my $unix_rpt = $self->_unix_rpt;
 134
 135     my @dirs = grep {defined() && length()} @_;
 136
 137     my $rslt;
 138     if (@dirs) {
 139         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
 140         my ($spath,$sdir) = ($path,$dir);
 141         $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
 142
 143         if ($unix_rpt) {
 144             $spath = unixify($spath) unless $spath =~ m#/#;
 145             $sdir= unixify($sdir) unless $sdir =~ m#/#;
 146             return $self->SUPER::catdir($spath, $sdir)
 147         }
 148
 149         $rslt = vmspath( unixify($spath) . '/' . unixify($sdir));
 150
 151         # Special case for VMS absolute directory specs: these will have
 152         # had device prepended during trip through Unix syntax in
 153         # eliminate_macros(), since Unix syntax has no way to express
 154         # "absolute from the top of this device's directory tree".
 155         if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
 156
 157     } else {
 158         # Single directory. Return an empty string on null input; otherwise
 159         # just return a canonical path.
 160
 161         if    (not defined $dir or not length $dir) {
 162             $rslt = '';
 163         } else {
 164             $rslt = $unix_rpt ? $dir : vmspath($dir);
 165         }
 166     }
 167     return $self->canonpath($rslt);
 168 }
 169
 170 =item catfile (override)
 171
 172 Concatenates a list of directory specifications with a filename specification
 173 to build a path.
 174
 175 =cut
 176
 177 sub catfile {
 178     my $self = shift;
 179     my $tfile = pop();
 180     my $file = $self->canonpath($tfile);
 181     my @files = grep {defined() && length()} @_;
 182
 183     my $unix_rpt = $self->_unix_rpt;
 184
 185     my $rslt;
 186     if (@files) {
 187         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
 188         my $spath = $path;
 189
 190         # Something building a VMS path in pieces may try to pass a
 191         # directory name in filename format, so normalize it.
 192         $spath =~ s/\.dir\Z(?!\n)//i;
 193
 194         # If the spath ends with a directory delimiter and the file is bare,
 195         # then just concatenate them.
 196         if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
 197             $rslt = "$spath$file";
 198         } else {
 199            $rslt = unixify($spath);
 200            $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
 201            $rslt = vmsify($rslt) unless $unix_rpt;
 202         }
 203     }
 204     else {
 205         # Only passed a single file?
 206         my $xfile = (defined($file) && length($file)) ? $file : '';
 207
 208         $rslt = $unix_rpt ? $xfile : vmsify($xfile);
 209     }
 210     return $self->canonpath($rslt) unless $unix_rpt;
 211
 212     # In Unix report mode, do not strip off redundant path information.
 213     return $rslt;
 214 }
 215
 216
 217 =item curdir (override)
 218
 219 Returns a string representation of the current directory: '[]' or '.'
 220
 221 =cut
 222
 223 sub curdir {
 224     my $self = shift @_;
 225     return '.' if ($self->_unix_rpt);
 226     return '[]';
 227 }
 228
 229 =item devnull (override)
 230
 231 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
 232
 233 =cut
 234
 235 sub devnull {
 236     my $self = shift @_;
 237     return '/dev/null' if ($self->_unix_rpt);
 238     return "_NLA0:";
 239 }
 240
 241 =item rootdir (override)
 242
 243 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 244 or '/'
 245
 246 =cut
 247
 248 sub rootdir {
 249     my $self = shift @_;
 250     if ($self->_unix_rpt) {
 251        # Root may exist, try it first.
 252        my $try = '/';
 253        my ($dev1, $ino1) = stat('/');
 254        my ($dev2, $ino2) = stat('.');
 255
 256        # Perl falls back to '.' if it can not determine '/'
 257        if (($dev1 != $dev2) || ($ino1 != $ino2)) {
 258            return $try;
 259        }
 260        # Fall back to UNIX format sys$disk.
 261        return '/sys$disk/';
 262     }
 263     return 'SYS$DISK:[000000]';
 264 }
 265
 266 =item tmpdir (override)
 267
 268 Returns a string representation of the first writable directory
 269 from the following list or '' if none are writable:
 270
 271     /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
 272     sys$scratch:
 273     $ENV{TMPDIR}
 274
 275 If running under taint mode, and if $ENV{TMPDIR}
 276 is tainted, it is not used.
 277
 278 =cut
 279
 280 sub tmpdir {
 281     my $self = shift @_;
 282     my $tmpdir = $self->_cached_tmpdir('TMPDIR');
 283     return $tmpdir if defined $tmpdir;
 284     if ($self->_unix_rpt) {
 285         $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
 286     }
 287     else {
 288         $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
 289     }
 290     $self->_cache_tmpdir($tmpdir, 'TMPDIR');
 291 }
 292
 293 =item updir (override)
 294
 295 Returns a string representation of the parent directory: '[-]' or '..'
 296
 297 =cut
 298
 299 sub updir {
 300     my $self = shift @_;
 301     return '..' if ($self->_unix_rpt);
 302     return '[-]';
 303 }
 304
 305 =item case_tolerant (override)
 306
 307 VMS file specification syntax is case-tolerant.
 308
 309 =cut
 310
 311 sub case_tolerant {
 312     return 1;
 313 }
 314
 315 =item path (override)
 316
 317 Translate logical name DCL$PATH as a searchlist, rather than trying
 318 to C<split> string value of C<$ENV{'PATH'}>.
 319
 320 =cut
 321
 322 sub path {
 323     my (@dirs,$dir,$i);
 324     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 325     return @dirs;
 326 }
 327
 328 =item file_name_is_absolute (override)
 329
 330 Checks for VMS directory spec as well as Unix separators.
 331
 332 =cut
 333
 334 sub file_name_is_absolute {
 335     my ($self,$file) = @_;
 336     # If it's a logical name, expand it.
 337     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
 338     return scalar($file =~ m!^/!s             ||
 339                   $file =~ m![<\[][^.\-\]>]!  ||
 340                   $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
 341 }
 342
 343 =item splitpath (override)
 344
 345    ($volume,$directories,$file) = File::Spec->splitpath( $path );
 346    ($volume,$directories,$file) = File::Spec->splitpath( $path,
 347                                                          $no_file );
 348
 349 Passing a true value for C<$no_file> indicates that the path being
 350 split only contains directory components, even on systems where you
 351 can usually (when not supporting a foreign syntax) tell the difference
 352 between directories and files at a glance.
 353
 354 =cut
 355
 356 sub splitpath {
 357     my($self,$path, $nofile) = @_;
 358     my($dev,$dir,$file)      = ('','','');
 359     my $vmsify_path = vmsify($path);
 360
 361     if ( $nofile ) {
 362         #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
 363         #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
 364         if( $vmsify_path =~ /(.*)\](.+)/ ){
 365             $vmsify_path = $1.'.'.$2.']';
 366         }
 367         $vmsify_path =~ /(.+:)?(.*)/s;
 368         $dir = defined $2 ? $2 : ''; # dir can be '0'
 369         return ($1 || '',$dir,$file);
 370     }
 371     else {
 372         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
 373         return ($1 || '',$2 || '',$3);
 374     }
 375 }
 376
 377 =item splitdir (override)
 378
 379 Split a directory specification into the components.
 380
 381 =cut
 382
 383 sub splitdir {
 384     my($self,$dirspec) = @_;
 385     my @dirs = ();
 386     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
 387
 388     $dirspec =~ s/(?<!\^)</[/;                  # < and >       ==> [ and ]
 389     $dirspec =~ s/(?<!\^)>/]/;
 390     $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g;       # ][.           ==> .][
 391     $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g;   # [000000.][    ==> [
 392     $dirspec =~ s/(?<!\^)\[000000\./\[/g;       # [000000.      ==> [
 393     $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g;   # .][000000]    ==> ]
 394     $dirspec =~ s/(?<!\^)\.\]\[/\./g;           # foo.][bar     ==> foo.bar
 395     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
 396                                                 # That loop does the following
 397                                                 # with any amount of dashes:
 398                                                 # .--.          ==> .-.-.
 399                                                 # [--.          ==> [-.-.
 400                                                 # .--]          ==> .-.-]
 401                                                 # [--]          ==> [-.-]
 402     $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
 403     $dirspec =~ s/^(\[|<)\./$1/;
 404     @dirs = split /(?<!\^)\./, vmspath($dirspec);
 405     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
 406     @dirs;
 407 }
 408
 409
 410 =item catpath (override)
 411
 412 Construct a complete filespec.
 413
 414 =cut
 415
 416 sub catpath {
 417     my($self,$dev,$dir,$file) = @_;
 418
 419     # We look for a volume in $dev, then in $dir, but not both
 420     my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
 421     $dev = $dir_volume unless length $dev;
 422     $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
 423
 424     if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
 425     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
 426     if (length($dev) or length($dir)) {
 427         $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
 428         $dir = vmspath($dir);
 429     }
 430     $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
 431     "$dev$dir$file";
 432 }
 433
 434 =item abs2rel (override)
 435
 436 Attempt to convert an absolute file specification to a relative specification.
 437
 438 =cut
 439
 440 sub abs2rel {
 441     my $self = shift;
 442     my($path,$base) = @_;
 443
 444     $base = $self->_cwd() unless defined $base and length $base;
 445
 446     # If there is no device or directory syntax on $base, make sure it
 447     # is treated as a directory.
 448     $base = vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};
 449
 450     for ($path, $base) { $_ = $self->rel2abs($_) }
 451
 452     # Are we even starting $path on the same (node::)device as $base?  Note that
 453     # logical paths or nodename differences may be on the "same device"
 454     # but the comparison that ignores device differences so as to concatenate
 455     # [---] up directory specs is not even a good idea in cases where there is
 456     # a logical path difference between $path and $base nodename and/or device.
 457     # Hence we fall back to returning the absolute $path spec
 458     # if there is a case blind device (or node) difference of any sort
 459     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
 460     # (this module needs to run on non VMS platforms after all).
 461
 462     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
 463     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
 464     return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume);
 465
 466     # Now, remove all leading components that are the same
 467     my @pathchunks = $self->splitdir( $path_directories );
 468     my $pathchunks = @pathchunks;
 469     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
 470     my @basechunks = $self->splitdir( $base_directories );
 471     my $basechunks = @basechunks;
 472     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
 473
 474     while ( @pathchunks &&
 475             @basechunks &&
 476             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 477           ) {
 478         shift @pathchunks ;
 479         shift @basechunks ;
 480     }
 481
 482     # @basechunks now contains the directories to climb out of,
 483     # @pathchunks now has the directories to descend in to.
 484     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
 485       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
 486     }
 487     else {
 488       $path_directories = join '.', @pathchunks;
 489     }
 490     $path_directories = '['.$path_directories.']';
 491     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
 492 }
 493
 494
 495 =item rel2abs (override)
 496
 497 Return an absolute file specification from a relative one.
 498
 499 =cut
 500
 501 sub rel2abs {
 502     my $self = shift ;
 503     my ($path,$base ) = @_;
 504     return undef unless defined $path;
 505     if ($path =~ m/\//) {
 506        $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
 507                   ? vmspath($path)             # whether it's a directory
 508                   : vmsify($path) );
 509     }
 510     $base = vmspath($base) if defined $base && $base =~ m/\//;
 511
 512     # Clean up and split up $path
 513     if ( ! $self->file_name_is_absolute( $path ) ) {
 514         # Figure out the effective $base and clean it up.
 515         if ( !defined( $base ) || $base eq '' ) {
 516             $base = $self->_cwd;
 517         }
 518         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 519             $base = $self->rel2abs( $base ) ;
 520         }
 521         else {
 522             $base = $self->canonpath( $base ) ;
 523         }
 524
 525         # Split up paths
 526         my ( $path_directories, $path_file ) =
 527             ($self->splitpath( $path ))[1,2] ;
 528
 529         my ( $base_volume, $base_directories ) =
 530             $self->splitpath( $base ) ;
 531
 532         $path_directories = '' if $path_directories eq '[]' ||
 533                                   $path_directories eq '<>';
 534         my $sep = '' ;
 535         $sep = '.'
 536             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
 537                  $path_directories =~ m{^[^.\[<]}s
 538             ) ;
 539         $base_directories = "$base_directories$sep$path_directories";
 540         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
 541
 542         $path = $self->catpath( $base_volume, $base_directories, $path_file );
 543    }
 544
 545     return $self->canonpath( $path ) ;
 546 }
 547
 548
 549 =back
 550
 551 =head1 COPYRIGHT
 552
 553 Copyright (c) 2004-14 by the Perl 5 Porters.  All rights reserved.
 554
 555 This program is free software; you can redistribute it and/or modify
 556 it under the same terms as Perl itself.
 557
 558 =head1 SEE ALSO
 559
 560 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
 561 implementation of these methods, not the semantics.
 562
 563 An explanation of VMS file specs can be found at
 564 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
 565
 566 =cut
 567
 568 1;