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