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) = @_;
 137
 138     if ($path =~ m|/|) { # Fake Unix
 139       my $pathify = $path =~ m|/\z|;
 140       $path = $self->SUPER::canonpath($path);
 141       if ($pathify) { return vmspath($path); }
 142       else          { return vmsify($path);  }
 143     }
 144     else {
 145 >>>> ORIGINAL VMS.pm#13
 146       $path =~ s-\]\[--g;  $path =~ s/><//g;         # foo.][bar       ==> foo.bar
 147       $path =~ s/([\[<])000000\./$1/;                # [000000.foo     ==> foo
 148       if ($reduce_ricochet) {
 149         $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/g;
 150         $path =~ s/([\[<\.])([^\[<\.]+)\.-\.?/$1/g;
 151       }
 152       $path =~ s-\]\[--g;  $path =~ s/><//g;            # foo.][bar       ==> foo.bar
 153       $path =~ s/([\[<])000000\./$1/;                   # [000000.foo     ==> foo
 154       1 while $path =~ s{-\.-}{--};                     # -.-             ==> --
 155       $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/;            # bar.foo.-]      ==> bar]
 156       $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s
 157       $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g;    # bar.-.foo       ==> foo
 158       $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode
 159       return $path;
 160     }
 161 }
 162
 163 =item catdir
 164
 165 Concatenates a list of file specifications, and returns the result as a
 166 VMS-syntax directory specification.  No check is made for "impossible"
 167 cases (e.g. elements other than the first being absolute filespecs).
 168
 169 =cut
 170
 171 sub catdir {
 172     my ($self,@dirs) = @_;
 173     my $dir = pop @dirs;
 174     @dirs = grep($_,@dirs);
 175     my $rslt;
 176     if (@dirs) {
 177         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
 178         my ($spath,$sdir) = ($path,$dir);
 179         $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//;
 180         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/s;
 181         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
 182
 183         # Special case for VMS absolute directory specs: these will have had device
 184         # prepended during trip through Unix syntax in eliminate_macros(), since
 185         # Unix syntax has no way to express "absolute from the top of this device's
 186         # directory tree".
 187         if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
 188     }
 189     else {
 190         if    (not defined $dir or not length $dir) { $rslt = ''; }
 191         elsif ($dir =~ /^\$\([^\)]+\)\z/s)          { $rslt = $dir; }
 192         else                                        { $rslt = vmspath($dir); }
 193     }
 194     return $rslt;
 195 }
 196
 197 =item catfile
 198
 199 Concatenates a list of file specifications, and returns the result as a
 200 VMS-syntax file specification.
 201
 202 =cut
 203
 204 sub catfile {
 205     my ($self,@files) = @_;
 206     my $file = pop @files;
 207     @files = grep($_,@files);
 208     my $rslt;
 209     if (@files) {
 210         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
 211         my $spath = $path;
 212         $spath =~ s/\.dir\z//;
 213         if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) {
 214             $rslt = "$spath$file";
 215         }
 216         else {
 217             $rslt = $self->eliminate_macros($spath);
 218             $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
 219         }
 220     }
 221     else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
 222     return $rslt;
 223 }
 224
 225
 226 =item curdir (override)
 227
 228 Returns a string representation of the current directory: '[]'
 229
 230 =cut
 231
 232 sub curdir {
 233     return '[]';
 234 }
 235
 236 =item devnull (override)
 237
 238 Returns a string representation of the null device: '_NLA0:'
 239
 240 =cut
 241
 242 sub devnull {
 243     return "_NLA0:";
 244 }
 245
 246 =item rootdir (override)
 247
 248 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 249
 250 =cut
 251
 252 sub rootdir {
 253     return 'SYS$DISK:[000000]';
 254 }
 255
 256 =item tmpdir (override)
 257
 258 Returns a string representation of the first writable directory
 259 from the following list or '' if none are writable:
 260
 261     sys$scratch
 262     $ENV{TMPDIR}
 263
 264 =cut
 265
 266 my $tmpdir;
 267 sub tmpdir {
 268     return $tmpdir if defined $tmpdir;
 269     foreach ('sys$scratch', $ENV{TMPDIR}) {
 270         next unless defined && -d && -w _;
 271         $tmpdir = $_;
 272         last;
 273     }
 274     $tmpdir = '' unless defined $tmpdir;
 275     return $tmpdir;
 276 }
 277
 278 =item updir (override)
 279
 280 Returns a string representation of the parent directory: '[-]'
 281
 282 =cut
 283
 284 sub updir {
 285     return '[-]';
 286 }
 287
 288 =item case_tolerant (override)
 289
 290 VMS file specification syntax is case-tolerant.
 291
 292 =cut
 293
 294 sub case_tolerant {
 295     return 1;
 296 }
 297
 298 =item path (override)
 299
 300 Translate logical name DCL$PATH as a searchlist, rather than trying
 301 to C<split> string value of C<$ENV{'PATH'}>.
 302
 303 =cut
 304
 305 sub path {
 306     my (@dirs,$dir,$i);
 307     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 308     return @dirs;
 309 }
 310
 311 =item file_name_is_absolute (override)
 312
 313 Checks for VMS directory spec as well as Unix separators.
 314
 315 =cut
 316
 317 sub file_name_is_absolute {
 318     my ($self,$file) = @_;
 319     # If it's a logical name, expand it.
 320     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file};
 321     return scalar($file =~ m!^/!s             ||
 322                   $file =~ m![<\[][^.\-\]>]!  ||
 323                   $file =~ /:[^<\[]/);
 324 }
 325
 326 =item splitpath (override)
 327
 328 Splits using VMS syntax.
 329
 330 =cut
 331
 332 sub splitpath {
 333     my($self,$path) = @_;
 334     my($dev,$dir,$file) = ('','','');
 335
 336     vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
 337     return ($1 || '',$2 || '',$3);
 338 }
 339
 340 =item splitdir (override)
 341
 342 Split dirspec using VMS syntax.
 343
 344 =cut
 345
 346 sub splitdir {
 347     my($self,$dirspec) = @_;
 348     $dirspec =~ s/\]\[//g;  $dirspec =~ s/\-\-/-.-/g;
 349     $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
 350     my(@dirs) = split('\.', vmspath($dirspec));
 351     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\z//s;
 352     @dirs;
 353 }
 354
 355
 356 =item catpath (override)
 357
 358 Construct a complete filespec using VMS syntax
 359
 360 =cut
 361
 362 sub catpath {
 363     my($self,$dev,$dir,$file) = @_;
 364     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
 365     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; }
 366     if (length($dev) or length($dir)) {
 367       $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
 368       $dir = vmspath($dir);
 369     }
 370     "$dev$dir$file";
 371 }
 372
 373 =item abs2rel (override)
 374
 375 Use VMS syntax when converting filespecs.
 376
 377 =cut
 378
 379 sub abs2rel {
 380     my $self = shift;
 381
 382     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
 383         if ( join( '', @_ ) =~ m{/} ) ;
 384
 385     my($path,$base) = @_;
 386
 387     # Note: we use '/' to glue things together here, then let canonpath()
 388     # clean them up at the end.
 389
 390     # Clean up $path
 391     if ( ! $self->file_name_is_absolute( $path ) ) {
 392         $path = $self->rel2abs( $path ) ;
 393     }
 394     else {
 395         $path = $self->canonpath( $path ) ;
 396     }
 397
 398     # Figure out the effective $base and clean it up.
 399     if ( !defined( $base ) || $base eq '' ) {
 400         $base = cwd() ;
 401     }
 402     elsif ( ! $self->file_name_is_absolute( $base ) ) {
 403         $base = $self->rel2abs( $base ) ;
 404     }
 405     else {
 406         $base = $self->canonpath( $base ) ;
 407     }
 408
 409     # Split up paths
 410     my ( undef, $path_directories, $path_file ) =
 411         $self->splitpath( $path, 1 ) ;
 412
 413     $path_directories = $1
 414         if $path_directories =~ /^\[(.*)\]\z/s ;
 415
 416     my ( undef, $base_directories, undef ) =
 417         $self->splitpath( $base, 1 ) ;
 418
 419     $base_directories = $1
 420         if $base_directories =~ /^\[(.*)\]\z/s ;
 421
 422     # Now, remove all leading components that are the same
 423     my @pathchunks = $self->splitdir( $path_directories );
 424     my @basechunks = $self->splitdir( $base_directories );
 425
 426     while ( @pathchunks &&
 427             @basechunks &&
 428             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 429           ) {
 430         shift @pathchunks ;
 431         shift @basechunks ;
 432     }
 433
 434     # @basechunks now contains the directories to climb out of,
 435     # @pathchunks now has the directories to descend in to.
 436     $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
 437     $path_directories =~ s{\.\z}{} ;
 438     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
 439 }
 440
 441
 442 =item rel2abs (override)
 443
 444 Use VMS syntax when converting filespecs.
 445
 446 =cut
 447
 448 sub rel2abs($;$;) {
 449     my $self = shift ;
 450     return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))
 451         if ( join( '', @_ ) =~ m{/} ) ;
 452
 453     my ($path,$base ) = @_;
 454     # Clean up and split up $path
 455     if ( ! $self->file_name_is_absolute( $path ) ) {
 456         # Figure out the effective $base and clean it up.
 457         if ( !defined( $base ) || $base eq '' ) {
 458             $base = cwd() ;
 459         }
 460         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 461             $base = $self->rel2abs( $base ) ;
 462         }
 463         else {
 464             $base = $self->canonpath( $base ) ;
 465         }
 466
 467         # Split up paths
 468         my ( undef, $path_directories, $path_file ) =
 469             $self->splitpath( $path ) ;
 470
 471         my ( $base_volume, $base_directories, undef ) =
 472             $self->splitpath( $base ) ;
 473
 474         $path_directories = '' if $path_directories eq '[]' ||
 475                                   $path_directories eq '<>';
 476         my $sep = '' ;
 477         $sep = '.'
 478             if ( $base_directories =~ m{[^.\]>]\z} &&
 479                  $path_directories =~ m{^[^.\[<]}s
 480             ) ;
 481         $base_directories = "$base_directories$sep$path_directories";
 482         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
 483
 484         $path = $self->catpath( $base_volume, $base_directories, $path_file );
 485    }
 486
 487     return $self->canonpath( $path ) ;
 488 }
 489
 490
 491 =back
 492
 493 =head1 SEE ALSO
 494
 495 L<File::Spec>
 496
 497 =cut
 498
 499 1;