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