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

   1 package File::Spec::VMS;
   2
   3 use strict;
   4 use Cwd ();
   5 require File::Spec::Unix;
   6
   7 our $VERSION = '3.69';
   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;