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 = '1.2';
   8
   9 @ISA = qw(File::Spec::Unix);
  10
  11 use Cwd;
  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 eliminate_macros
  32
  33 Expands MM[KS]/Make macros in a text string, using the contents of
  34 identically named elements of C<%$self>, and returns the result
  35 as a file specification in Unix syntax.
  36
  37 =cut
  38
  39 sub eliminate_macros {
  40     my($self,$path) = @_;
  41     return '' unless $path;
  42     $self = {} unless ref $self;
  43
  44     if ($path =~ /\s/) {
  45       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
  46     }
  47
  48     my($npath) = unixify($path);
  49     my($complex) = 0;
  50     my($head,$macro,$tail);
  51
  52     # perform m##g in scalar context so it acts as an iterator
  53     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
  54         if ($self->{$2}) {
  55             ($head,$macro,$tail) = ($1,$2,$3);
  56             if (ref $self->{$macro}) {
  57                 if (ref $self->{$macro} eq 'ARRAY') {
  58                     $macro = join ' ', @{$self->{$macro}};
  59                 }
  60                 else {
  61                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
  62                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
  63                     $macro = "\cB$macro\cB";
  64                     $complex = 1;
  65                 }
  66             }
  67             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
  68             $npath = "$head$macro$tail";
  69         }
  70     }
  71     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
  72     $npath;
  73 }
  74
  75 =item fixpath
  76
  77 Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
  78 in any directory specification, in order to avoid juxtaposing two
  79 VMS-syntax directories when MM[SK] is run.  Also expands expressions which
  80 are all macro, so that we can tell how long the expansion is, and avoid
  81 overrunning DCL's command buffer when MM[KS] is running.
  82
  83 If optional second argument has a TRUE value, then the return string is
  84 a VMS-syntax directory specification, if it is FALSE, the return string
  85 is a VMS-syntax file specification, and if it is not specified, fixpath()
  86 checks to see whether it matches the name of a directory in the current
  87 default directory, and returns a directory or file specification accordingly.
  88
  89 =cut
  90
  91 sub fixpath {
  92     my($self,$path,$force_path) = @_;
  93     return '' unless $path;
  94     $self = bless {} unless ref $self;
  95     my($fixedpath,$prefix,$name);
  96
  97     if ($path =~ /\s/) {
  98       return join ' ',
  99              map { $self->fixpath($_,$force_path) }
 100              split /\s+/, $path;
 101     }
 102
 103     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
 104         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
 105             $fixedpath = vmspath($self->eliminate_macros($path));
 106         }
 107         else {
 108             $fixedpath = vmsify($self->eliminate_macros($path));
 109         }
 110     }
 111     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
 112         my($vmspre) = $self->eliminate_macros("\$($prefix)");
 113         # is it a dir or just a name?
 114         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
 115         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
 116         $fixedpath = vmspath($fixedpath) if $force_path;
 117     }
 118     else {
 119         $fixedpath = $path;
 120         $fixedpath = vmspath($fixedpath) if $force_path;
 121     }
 122     # No hints, so we try to guess
 123     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
 124         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
 125     }
 126
 127     # Trim off root dirname if it's had other dirs inserted in front of it.
 128     $fixedpath =~ s/\.000000([\]>])/$1/;
 129     # Special case for VMS absolute directory specs: these will have had device
 130     # prepended during trip through Unix syntax in eliminate_macros(), since
 131     # Unix syntax has no way to express "absolute from the top of this device's
 132     # directory tree".
 133     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
 134     $fixedpath;
 135 }
 136
 137 =back
 138
 139 =head2 Methods always loaded
 140
 141 =over 4
 142
 143 =item canonpath (override)
 144
 145 Removes redundant portions of file specifications according to VMS syntax.
 146
 147 =cut
 148
 149 sub canonpath {
 150     my($self,$path) = @_;
 151
 152     if ($path =~ m|/|) { # Fake Unix
 153       my $pathify = $path =~ m|/\Z(?!\n)|;
 154       $path = $self->SUPER::canonpath($path);
 155       if ($pathify) { return vmspath($path); }
 156       else          { return vmsify($path);  }
 157     }
 158     else {
 159       $path =~ s/([\[<])000000\./$1/g;                  # [000000.foo     ==> [foo
 160       $path =~ s/([^-]+)\.(\]\[|><)?000000([\]\>])/$1$3/g;  # foo.000000] ==> foo]
 161       $path =~ s-\]\[--g;  $path =~ s/><//g;            # foo.][bar       ==> foo.bar
 162       1 while $path =~ s{([\[<-])\.-}{$1-};             # [.-.-           ==> [--
 163       $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/;            # bar.foo.-]      ==> bar]
 164       $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s
 165       $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g;    # bar.-.foo       ==> foo
 166       $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode
 167       $path =~ s/^[\[<\]>]{2}//;                        # []foo           ==> foo
 168       return $path;
 169     }
 170 }
 171
 172 =item catdir
 173
 174 Concatenates a list of file specifications, and returns the result as a
 175 VMS-syntax directory specification.  No check is made for "impossible"
 176 cases (e.g. elements other than the first being absolute filespecs).
 177
 178 =cut
 179
 180 sub catdir {
 181     my ($self,@dirs) = @_;
 182     my $dir = pop @dirs;
 183     @dirs = grep($_,@dirs);
 184     my $rslt;
 185     if (@dirs) {
 186         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
 187         my ($spath,$sdir) = ($path,$dir);
 188         $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
 189         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
 190         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
 191
 192         # Special case for VMS absolute directory specs: these will have had device
 193         # prepended during trip through Unix syntax in eliminate_macros(), since
 194         # Unix syntax has no way to express "absolute from the top of this device's
 195         # directory tree".
 196         if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
 197     }
 198     else {
 199         if    (not defined $dir or not length $dir) { $rslt = ''; }
 200         elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s)          { $rslt = $dir; }
 201         else                                        { $rslt = vmspath($dir); }
 202     }
 203     return $self->canonpath($rslt);
 204 }
 205
 206 =item catfile
 207
 208 Concatenates a list of file specifications, and returns the result as a
 209 VMS-syntax file specification.
 210
 211 =cut
 212
 213 sub catfile {
 214     my ($self,@files) = @_;
 215     my $file = $self->canonpath(pop @files);
 216     @files = grep($_,@files);
 217     my $rslt;
 218     if (@files) {
 219         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
 220         my $spath = $path;
 221         $spath =~ s/\.dir\Z(?!\n)//;
 222         if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
 223             $rslt = "$spath$file";
 224         }
 225         else {
 226             $rslt = $self->eliminate_macros($spath);
 227             $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
 228         }
 229     }
 230     else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
 231     return $self->canonpath($rslt);
 232 }
 233
 234
 235 =item curdir (override)
 236
 237 Returns a string representation of the current directory: '[]'
 238
 239 =cut
 240
 241 sub curdir {
 242     return '[]';
 243 }
 244
 245 =item devnull (override)
 246
 247 Returns a string representation of the null device: '_NLA0:'
 248
 249 =cut
 250
 251 sub devnull {
 252     return "_NLA0:";
 253 }
 254
 255 =item rootdir (override)
 256
 257 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 258
 259 =cut
 260
 261 sub rootdir {
 262     return 'SYS$DISK:[000000]';
 263 }
 264
 265 =item tmpdir (override)
 266
 267 Returns a string representation of the first writable directory
 268 from the following list or '' if none are writable:
 269
 270     sys$scratch:
 271     $ENV{TMPDIR}
 272
 273 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
 274 is tainted, it is not used.
 275
 276 =cut
 277
 278 my $tmpdir;
 279 sub tmpdir {
 280     return $tmpdir if defined $tmpdir;
 281     my @dirlist = ('sys$scratch:', $ENV{TMPDIR});
 282     {
 283         no strict 'refs';
 284         if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
 285             require Scalar::Util;
 286             pop @dirlist if Scalar::Util::tainted($ENV{TMPDIR});
 287         }
 288     }
 289     foreach (@dirlist) {
 290         next unless defined && -d && -w _;
 291         $tmpdir = $_;
 292         last;
 293     }
 294     $tmpdir = '' unless defined $tmpdir;
 295     return $tmpdir;
 296 }
 297
 298 =item updir (override)
 299
 300 Returns a string representation of the parent directory: '[-]'
 301
 302 =cut
 303
 304 sub updir {
 305     return '[-]';
 306 }
 307
 308 =item case_tolerant (override)
 309
 310 VMS file specification syntax is case-tolerant.
 311
 312 =cut
 313
 314 sub case_tolerant {
 315     return 1;
 316 }
 317
 318 =item path (override)
 319
 320 Translate logical name DCL$PATH as a searchlist, rather than trying
 321 to C<split> string value of C<$ENV{'PATH'}>.
 322
 323 =cut
 324
 325 sub path {
 326     my (@dirs,$dir,$i);
 327     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 328     return @dirs;
 329 }
 330
 331 =item file_name_is_absolute (override)
 332
 333 Checks for VMS directory spec as well as Unix separators.
 334
 335 =cut
 336
 337 sub file_name_is_absolute {
 338     my ($self,$file) = @_;
 339     # If it's a logical name, expand it.
 340     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
 341     return scalar($file =~ m!^/!s             ||
 342                   $file =~ m![<\[][^.\-\]>]!  ||
 343                   $file =~ /:[^<\[]/);
 344 }
 345
 346 =item splitpath (override)
 347
 348 Splits using VMS syntax.
 349
 350 =cut
 351
 352 sub splitpath {
 353     my($self,$path) = @_;
 354     my($dev,$dir,$file) = ('','','');
 355
 356     vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
 357     return ($1 || '',$2 || '',$3);
 358 }
 359
 360 =item splitdir (override)
 361
 362 Split dirspec using VMS syntax.
 363
 364 =cut
 365
 366 sub splitdir {
 367     my($self,$dirspec) = @_;
 368     $dirspec =~ s/\]\[//g;  $dirspec =~ s/\-\-/-.-/g;
 369     $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
 370     my(@dirs) = split('\.', vmspath($dirspec));
 371     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
 372     @dirs;
 373 }
 374
 375
 376 =item catpath (override)
 377
 378 Construct a complete filespec using VMS syntax
 379
 380 =cut
 381
 382 sub catpath {
 383     my($self,$dev,$dir,$file) = @_;
 384     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
 385     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
 386     if (length($dev) or length($dir)) {
 387       $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
 388       $dir = vmspath($dir);
 389     }
 390     "$dev$dir$file";
 391 }
 392
 393 =item abs2rel (override)
 394
 395 Use VMS syntax when converting filespecs.
 396
 397 =cut
 398
 399 sub abs2rel {
 400     my $self = shift;
 401
 402     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
 403         if ( join( '', @_ ) =~ m{/} ) ;
 404
 405     my($path,$base) = @_;
 406
 407     # Note: we use '/' to glue things together here, then let canonpath()
 408     # clean them up at the end.
 409
 410     # Clean up $path
 411     if ( ! $self->file_name_is_absolute( $path ) ) {
 412         $path = $self->rel2abs( $path ) ;
 413     }
 414     else {
 415         $path = $self->canonpath( $path ) ;
 416     }
 417
 418     # Figure out the effective $base and clean it up.
 419     if ( !defined( $base ) || $base eq '' ) {
 420         $base = cwd() ;
 421         $base = $self->canonpath( $base ) ;
 422     }
 423     elsif ( ! $self->file_name_is_absolute( $base ) ) {
 424         $base = $self->rel2abs( $base ) ;
 425     }
 426     else {
 427         $base = $self->canonpath( $base ) ;
 428     }
 429
 430     # Split up paths
 431     my ( $path_directories, $path_file ) =
 432         ($self->splitpath( $path, 1 ))[1,2] ;
 433
 434     $path_directories = $1
 435         if $path_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
 436
 437     my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
 438
 439     $base_directories = $1
 440         if $base_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
 441
 442     # Now, remove all leading components that are the same
 443     my @pathchunks = $self->splitdir( $path_directories );
 444     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
 445     my @basechunks = $self->splitdir( $base_directories );
 446     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
 447
 448     while ( @pathchunks &&
 449             @basechunks &&
 450             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 451           ) {
 452         shift @pathchunks ;
 453         shift @basechunks ;
 454     }
 455
 456     # @basechunks now contains the directories to climb out of,
 457     # @pathchunks now has the directories to descend in to.
 458     $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
 459     $path_directories =~ s{\.\Z(?!\n)}{} ;
 460     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
 461 }
 462
 463
 464 =item rel2abs (override)
 465
 466 Use VMS syntax when converting filespecs.
 467
 468 =cut
 469
 470 sub rel2abs {
 471     my $self = shift ;
 472     return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))
 473         if ( join( '', @_ ) =~ m{/} ) ;
 474
 475     my ($path,$base ) = @_;
 476     # Clean up and split up $path
 477     if ( ! $self->file_name_is_absolute( $path ) ) {
 478         # Figure out the effective $base and clean it up.
 479         if ( !defined( $base ) || $base eq '' ) {
 480             $base = cwd() ;
 481         }
 482         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 483             $base = $self->rel2abs( $base ) ;
 484         }
 485         else {
 486             $base = $self->canonpath( $base ) ;
 487         }
 488
 489         # Split up paths
 490         my ( $path_directories, $path_file ) =
 491             ($self->splitpath( $path ))[1,2] ;
 492
 493         my ( $base_volume, $base_directories ) =
 494             $self->splitpath( $base ) ;
 495
 496         $path_directories = '' if $path_directories eq '[]' ||
 497                                   $path_directories eq '<>';
 498         my $sep = '' ;
 499         $sep = '.'
 500             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
 501                  $path_directories =~ m{^[^.\[<]}s
 502             ) ;
 503         $base_directories = "$base_directories$sep$path_directories";
 504         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
 505
 506         $path = $self->catpath( $base_volume, $base_directories, $path_file );
 507    }
 508
 509     return $self->canonpath( $path ) ;
 510 }
 511
 512
 513 =back
 514
 515 =head1 SEE ALSO
 516
 517 L<File::Spec>
 518
 519 =cut
 520
 521 1;