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