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     # Trim off root dirname if it's had other dirs inserted in front of it.
 112     $fixedpath =~ s/\.000000([\]>])/$1/;
 113     $fixedpath;
 114 }
 115
 116 =back
 117
 118 =head2 Methods always loaded
 119
 120 =over
 121
 122 =item catdir
 123
 124 Concatenates a list of file specifications, and returns the result as a
 125 VMS-syntax directory specification.
 126
 127 =cut
 128
 129 sub catdir {
 130     my ($self,@dirs) = @_;
 131     my $dir = pop @dirs;
 132     @dirs = grep($_,@dirs);
 133     my $rslt;
 134     if (@dirs) {
 135         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
 136         my ($spath,$sdir) = ($path,$dir);
 137         $spath =~ s/.dir$//; $sdir =~ s/.dir$//;
 138         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
 139         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
 140     }
 141     else {
 142         if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
 143         else                          { $rslt = vmspath($dir); }
 144     }
 145     return $rslt;
 146 }
 147
 148 =item catfile
 149
 150 Concatenates a list of file specifications, and returns the result as a
 151 VMS-syntax directory specification.
 152
 153 =cut
 154
 155 sub catfile {
 156     my ($self,@files) = @_;
 157     my $file = pop @files;
 158     @files = grep($_,@files);
 159     my $rslt;
 160     if (@files) {
 161         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
 162         my $spath = $path;
 163         $spath =~ s/.dir$//;
 164         if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) {
 165             $rslt = "$spath$file";
 166         }
 167         else {
 168             $rslt = $self->eliminate_macros($spath);
 169             $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
 170         }
 171     }
 172     else { $rslt = vmsify($file); }
 173     return $rslt;
 174 }
 175
 176 =item curdir (override)
 177
 178 Returns a string representation of the current directory: '[]'
 179
 180 =cut
 181
 182 sub curdir {
 183     return '[]';
 184 }
 185
 186 =item devnull (override)
 187
 188 Returns a string representation of the null device: '_NLA0:'
 189
 190 =cut
 191
 192 sub devnull {
 193     return "_NLA0:";
 194 }
 195
 196 =item rootdir (override)
 197
 198 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 199
 200 =cut
 201
 202 sub rootdir {
 203     return 'SYS$DISK:[000000]';
 204 }
 205
 206 =item tmpdir (override)
 207
 208 Returns a string representation of the first writable directory
 209 from the following list or '' if none are writable:
 210
 211     /sys$scratch
 212     $ENV{TMPDIR}
 213
 214 =cut
 215
 216 my $tmpdir;
 217 sub tmpdir {
 218     return $tmpdir if defined $tmpdir;
 219     foreach ('/sys$scratch', $ENV{TMPDIR}) {
 220         next unless defined && -d && -w _;
 221         $tmpdir = $_;
 222         last;
 223     }
 224     $tmpdir = '' unless defined $tmpdir;
 225     return $tmpdir;
 226 }
 227
 228 =item updir (override)
 229
 230 Returns a string representation of the parent directory: '[-]'
 231
 232 =cut
 233
 234 sub updir {
 235     return '[-]';
 236 }
 237
 238 =item path (override)
 239
 240 Translate logical name DCL$PATH as a searchlist, rather than trying
 241 to C<split> string value of C<$ENV{'PATH'}>.
 242
 243 =cut
 244
 245 sub path {
 246     my (@dirs,$dir,$i);
 247     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 248     return @dirs;
 249 }
 250
 251 =item file_name_is_absolute (override)
 252
 253 Checks for VMS directory spec as well as Unix separators.
 254
 255 =cut
 256
 257 sub file_name_is_absolute {
 258     my ($self,$file) = @_;
 259     # If it's a logical name, expand it.
 260     $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file};
 261     return scalar($file =~ m!^/!              ||
 262                   $file =~ m![<\[][^.\-\]>]!  ||
 263                   $file =~ /:[^<\[]/);
 264 }
 265
 266 =item splitpath
 267
 268     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 269     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 270
 271 Splits a VMS path in to volume, directory, and filename portions.
 272 Ignores $no_file, if present, since VMS paths indicate the 'fileness' of a
 273 file.
 274
 275 The results can be passed to L</catpath()> to get back a path equivalent to
 276 (usually identical to) the original path.
 277
 278 =cut
 279
 280 sub splitpath {
 281     my $self = shift ;
 282     my ($path, $nofile) = @_;
 283
 284     my ($volume,$directory,$file) ;
 285
 286     if ( $path =~ m{/} ) {
 287         $path =~
 288             m{^ ( (?: /[^/]* )? )
 289                 ( (?: .*/(?:[^/]+.dir)? )? )
 290                 (.*)
 291              }x;
 292         $volume    = $1;
 293         $directory = $2;
 294         $file      = $3;
 295     }
 296     else {
 297         $path =~
 298             m{^ ( (?: (?: (?: [\w\$-]+ (?: "[^"]*")?:: )? [\w\$-]+: )? ) )
 299                 ( (?:\[.*\])? )
 300                 (.*)
 301              }x;
 302         $volume    = $1;
 303         $directory = $2;
 304         $file      = $3;
 305     }
 306
 307     $directory = $1
 308         if $directory =~ /^\[(.*)\]$/ ;
 309
 310     return ($volume,$directory,$file);
 311 }
 312
 313
 314 =item splitdir
 315
 316 The opposite of L</catdir()>.
 317
 318     @dirs = File::Spec->splitdir( $directories );
 319
 320 $directories must be only the directory portion of the path.
 321
 322 '[' and ']' delimiters are optional. An empty string argument is
 323 equivalent to '[]': both return an array with no elements.
 324
 325 =cut
 326
 327 sub splitdir {
 328     my $self = shift ;
 329     my $directories = $_[0] ;
 330
 331     return File::Spec::Unix::splitdir( $self, @_ )
 332         if ( $directories =~ m{/} ) ;
 333
 334     $directories =~ s/^\[(.*)\]$/$1/ ;
 335
 336     #
 337     # split() likes to forget about trailing null fields, so here we
 338     # check to be sure that there will not be any before handling the
 339     # simple case.
 340     #
 341     if ( $directories !~ m{\.$} ) {
 342         return split( m{\.}, $directories );
 343     }
 344     else {
 345         #
 346         # since there was a trailing separator, add a file name to the end,
 347         # then do the split, then replace it with ''.
 348         #
 349         my( @directories )= split( m{\.}, "${directories}dummy" ) ;
 350         $directories[ $#directories ]= '' ;
 351         return @directories ;
 352     }
 353 }
 354
 355
 356 sub catpath {
 357     my $self = shift;
 358
 359     return File::Spec::Unix::catpath( $self, @_ )
 360         if ( join( '', @_ ) =~ m{/} ) ;
 361
 362     my ($volume,$directory,$file) = @_;
 363
 364     $volume .= ':'
 365         if $volume =~ /[^:]$/ ;
 366
 367     $directory = "[$directory"
 368         if $directory =~ /^[^\[]/ ;
 369
 370     $directory .= ']'
 371         if $directory =~ /[^\]]$/ ;
 372
 373     return "$volume$directory$file" ;
 374 }
 375
 376
 377 sub abs2rel {
 378     my $self = shift;
 379
 380     return File::Spec::Unix::abs2rel( $self, @_ )
 381         if ( join( '', @_ ) =~ m{/} ) ;
 382
 383     my($path,$base) = @_;
 384
 385     # Note: we use '/' to glue things together here, then let canonpath()
 386     # clean them up at the end.
 387
 388     # Clean up $path
 389     if ( ! $self->file_name_is_absolute( $path ) ) {
 390         $path = $self->rel2abs( $path ) ;
 391     }
 392     else {
 393         $path = $self->canonpath( $path ) ;
 394     }
 395
 396     # Figure out the effective $base and clean it up.
 397     if ( ! $self->file_name_is_absolute( $base ) ) {
 398         $base = $self->rel2abs( $base ) ;
 399     }
 400     elsif ( !defined( $base ) || $base eq '' ) {
 401         $base = cwd() ;
 402     }
 403     else {
 404         $base = $self->canonpath( $base ) ;
 405     }
 406
 407     # Split up paths
 408     my ( undef, $path_directories, $path_file ) =
 409         $self->splitpath( $path, 1 ) ;
 410
 411     $path_directories = $1
 412         if $path_directories =~ /^\[(.*)\]$/ ;
 413
 414     my ( undef, $base_directories, undef ) =
 415         $self->splitpath( $base, 1 ) ;
 416
 417     $base_directories = $1
 418         if $base_directories =~ /^\[(.*)\]$/ ;
 419
 420     # Now, remove all leading components that are the same
 421     my @pathchunks = $self->splitdir( $path_directories );
 422     my @basechunks = $self->splitdir( $base_directories );
 423
 424     while ( @pathchunks &&
 425             @basechunks &&
 426             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 427           ) {
 428         shift @pathchunks ;
 429         shift @basechunks ;
 430     }
 431
 432     # @basechunks now contains the directories to climb out of,
 433     # @pathchunks now has the directories to descend in to.
 434     $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
 435     $path_directories =~ s{\.$}{} ;
 436     return $self->catpath( '', $path_directories, $path_file ) ;
 437 }
 438
 439
 440 sub rel2abs($;$;) {
 441     my $self = shift ;
 442     return File::Spec::Unix::rel2abs( $self, @_ )
 443         if ( join( '', @_ ) =~ m{/} ) ;
 444
 445     my ($path,$base ) = @_;
 446     # Clean up and split up $path
 447     if ( ! $self->file_name_is_absolute( $path ) ) {
 448         # Figure out the effective $base and clean it up.
 449         if ( !defined( $base ) || $base eq '' ) {
 450             $base = cwd() ;
 451         }
 452         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 453             $base = $self->rel2abs( $base ) ;
 454         }
 455         else {
 456             $base = $self->canonpath( $base ) ;
 457         }
 458
 459         # Split up paths
 460         my ( undef, $path_directories, $path_file ) =
 461             $self->splitpath( $path ) ;
 462
 463         my ( $base_volume, $base_directories, undef ) =
 464             $self->splitpath( $base ) ;
 465
 466         my $sep = '' ;
 467         $sep = '.'
 468             if ( $base_directories =~ m{[^.]$} &&
 469                  $path_directories =~ m{^[^.]}
 470             ) ;
 471         $base_directories = "$base_directories$sep$path_directories" ;
 472
 473         $path = $self->catpath( $base_volume, $base_directories, $path_file );
 474    }
 475
 476     return $self->canonpath( $path ) ;
 477 }
 478
 479
 480 =back
 481
 482 =head1 SEE ALSO
 483
 484 L<File::Spec>
 485
 486 =cut
 487
 488 1;