lib/File/Spec/VMS.pm

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