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