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