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