dist/Cwd/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.35';
   8 $VERSION = eval $VERSION;
   9
  10 @ISA = qw(File::Spec::Unix);
  11
  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 The default behavior is to allow either VMS or Unix syntax on input and to
  30 return VMS syntax on output, even when Unix syntax was given on input.
  31
  32 When used with a Perl of version 5.10 or greater and a CRTL possessing the
  33 relevant capabilities, override behavior depends on the CRTL features
  34 C<DECC$FILENAME_UNIX_REPORT> and C<DECC$EFS_CHARSET>.  When the
  35 C<DECC$EFS_CHARSET> feature is enabled and the input parameters are clearly
  36 in Unix syntax, the output will be in Unix syntax.  If
  37 C<DECC$FILENAME_UNIX_REPORT> is enabled and the output syntax cannot be
  38 determined from the input syntax, the output will be in Unix syntax.
  39
  40 =over 4
  41
  42 =cut
  43
  44 # Need to look up the feature settings.  The preferred way is to use the
  45 # VMS::Feature module, but that may not be available to dual life modules.
  46
  47 my $use_feature;
  48 BEGIN {
  49     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
  50         $use_feature = 1;
  51     }
  52 }
  53
  54 # Need to look up the UNIX report mode.  This may become a dynamic mode
  55 # in the future.
  56 sub _unix_rpt {
  57     my $unix_rpt;
  58     if ($use_feature) {
  59         $unix_rpt = VMS::Feature::current("filename_unix_report");
  60     } else {
  61         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
  62         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
  63     }
  64     return $unix_rpt;
  65 }
  66
  67 # Need to look up the EFS character set mode.  This may become a dynamic
  68 # mode in the future.
  69 sub _efs {
  70     my $efs;
  71     if ($use_feature) {
  72         $efs = VMS::Feature::current("efs_charset");
  73     } else {
  74         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
  75         $efs = $env_efs =~ /^[ET1]/i;
  76     }
  77     return $efs;
  78 }
  79
  80 =item canonpath (override)
  81
  82 Removes redundant portions of file specifications according to the syntax
  83 detected.
  84
  85 =cut
  86
  87
  88 sub canonpath {
  89     my($self,$path) = @_;
  90
  91     return undef unless defined $path;
  92
  93     my $efs = $self->_efs;
  94
  95     if ($path =~ m|/|) { # Fake Unix
  96       my $pathify = $path =~ m|/\Z(?!\n)|;
  97       $path = $self->SUPER::canonpath($path);
  98
  99       # Do not convert to VMS when EFS character sets are in use
 100       return $path if $efs;
 101
 102       if ($pathify) { return vmspath($path); }
 103       else          { return vmsify($path);  }
 104     }
 105     else {
 106
 107 #FIXME - efs parsing has different rules.  Characters in a VMS filespec
 108 #        are only delimiters if not preceded by '^';
 109
 110         $path =~ tr/<>/[]/;                     # < and >       ==> [ and ]
 111         $path =~ s/\]\[\./\.\]\[/g;             # ][.           ==> .][
 112         $path =~ s/\[000000\.\]\[/\[/g;         # [000000.][    ==> [
 113         $path =~ s/\[000000\./\[/g;             # [000000.      ==> [
 114         $path =~ s/\.\]\[000000\]/\]/g;         # .][000000]    ==> ]
 115         $path =~ s/\.\]\[/\./g;                 # foo.][bar     ==> foo.bar
 116         1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
 117                                                 # That loop does the following
 118                                                 # with any amount of dashes:
 119                                                 # .-.-.         ==> .--.
 120                                                 # [-.-.         ==> [--.
 121                                                 # .-.-]         ==> .--]
 122                                                 # [-.-]         ==> [--]
 123         1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
 124                                                 # That loop does the following
 125                                                 # with any amount (minimum 2)
 126                                                 # of dashes:
 127                                                 # .foo.--.      ==> .-.
 128                                                 # .foo.--]      ==> .-]
 129                                                 # [foo.--.      ==> [-.
 130                                                 # [foo.--]      ==> [-]
 131                                                 #
 132                                                 # And then, the remaining cases
 133         $path =~ s/\[\.-/[-/;                   # [.-           ==> [-
 134         $path =~ s/\.[^\]\.]+\.-\./\./g;        # .foo.-.       ==> .
 135         $path =~ s/\[[^\]\.]+\.-\./\[/g;        # [foo.-.       ==> [
 136         $path =~ s/\.[^\]\.]+\.-\]/\]/g;        # .foo.-]       ==> ]
 137         $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-]       ==> [000000]
 138         $path =~ s/\[\]// unless $path eq '[]'; # []            ==>
 139         return $path;
 140     }
 141 }
 142
 143 =item catdir (override)
 144
 145 Concatenates a list of file specifications, and returns the result as a
 146 directory specification.  No check is made for "impossible"
 147 cases (e.g. elements other than the first being absolute filespecs).
 148
 149 =cut
 150
 151 sub catdir {
 152     my $self = shift;
 153     my $dir = pop;
 154
 155     my $efs = $self->_efs;
 156     my $unix_rpt = $self->_unix_rpt;
 157
 158
 159     my @dirs = grep {defined() && length()} @_;
 160     if ($efs) {
 161         # Legacy mode removes blank entries.
 162         # But that breaks existing generic perl code that
 163         # uses a blank path at the beginning of the array
 164         # to indicate an absolute path.
 165         # So put it back if found.
 166         if (@_) {
 167             if ($_[0] eq '') {
 168                 unshift @dirs, '';
 169             }
 170         }
 171     }
 172
 173     my $rslt;
 174     if (@dirs) {
 175         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
 176         my ($spath,$sdir) = ($path,$dir);
 177
 178         if ($efs) {
 179             # Extended character set in use, go into DWIM mode.
 180
 181             # Now we need to identify what the directory is in
 182             # of the specification in order to merge them.
 183             my $path_unix = 0;
 184             $path_unix = 1 if ($path =~ m#/#);
 185             $path_unix = 1 if ($path =~ /^\.\.?$/);
 186             my $path_vms = 0;
 187             $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
 188             $path_vms = 1 if ($path =~ /^--?$/);
 189             my $dir_unix = 0;
 190             $dir_unix = 1 if ($dir =~ m#/#);
 191             $dir_unix = 1 if ($dir =~ /^\.\.?$/);
 192             my $dir_vms = 0;
 193             $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
 194             $dir_vms = 1 if ($dir =~ /^--?$/);
 195
 196             my $unix_mode = 0;
 197             if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) {
 198                 # Ambiguous, so if in $unix_rpt mode then assume UNIX.
 199                 $unix_mode = 1 if $unix_rpt;
 200             } else {
 201                 $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt);
 202                 $unix_mode = 1 if ($path_unix || $dir_unix);
 203             }
 204
 205             if ($unix_mode) {
 206
 207                 # Fix up mixed syntax input as good as possible - GIGO
 208                 $path = unixify($path) if $path_vms;
 209                 $dir = unixify($dir) if $dir_vms;
 210
 211                 $rslt = $path;
 212                 # Append a path delimiter
 213                 $rslt .= '/' unless ($rslt =~ m#/$#);
 214
 215                 $rslt .= $dir;
 216                 return $self->SUPER::canonpath($rslt);
 217             } else {
 218
 219                 #with <> possible instead of [.
 220                 # Normalize the brackets
 221                 # Fixme - need to not switch when preceded by ^.
 222                 $path =~ s/</\[/g;
 223                 $path =~ s/>/\]/g;
 224                 $dir =~ s/</\[/g;
 225                 $dir =~ s/>/\]/g;
 226
 227                 # Fix up mixed syntax input as good as possible - GIGO
 228                 $path = vmsify($path) if $path_unix;
 229                 $dir = vmsify($dir) if $dir_unix;
 230
 231                 #Possible path values: foo: [.foo] [foo] foo, and $(foo)
 232                 #or starting with '-', or foo.dir
 233                 #If path is foo, it needs to be converted to [.foo]
 234
 235                 # Fix up a bare path name.
 236                 unless ($path_vms) {
 237                     $path =~ s/\.dir\Z(?!\n)//i;
 238                     if (($path ne '') && ($path !~ /^-/)) {
 239                         # Non blank and not prefixed with '-', add a dot
 240                         $path = '[.' . $path;
 241                     } else {
 242                         # Just start a directory.
 243                         $path = '[' . $path;
 244                     }
 245                 } else {
 246                     $path =~ s/\]$//;
 247                 }
 248
 249                 #Possible dir values: [.dir] dir and $(foo)
 250
 251                 # No punctuation may have a trailing .dir
 252                 unless ($dir_vms) {
 253                     $dir =~ s/\.dir\Z(?!\n)//i;
 254                 } else {
 255
 256                     #strip off the brackets
 257                     $dir =~ s/^\[//;
 258                     $dir =~ s/\]$//;
 259                 }
 260
 261                 #strip off the leading dot if present.
 262                 $dir =~ s/^\.//;
 263
 264                 # Now put the specifications together.
 265                 if ($dir ne '') {
 266                     # Add a separator unless this is an absolute path
 267                     $path .= '.' if ($path ne '[');
 268                     $rslt = $path . $dir . ']';
 269                 } else {
 270                     $rslt = $path . ']';
 271                 }
 272             }
 273
 274         } else {
 275             # Traditional ODS-2 mode.
 276             $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
 277
 278             $sdir = $self->eliminate_macros($sdir)
 279                 unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
 280             $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
 281
 282             # Special case for VMS absolute directory specs: these will have
 283             # had device prepended during trip through Unix syntax in
 284             # eliminate_macros(), since Unix syntax has no way to express
 285             # "absolute from the top of this device's directory tree".
 286             if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
 287         }
 288     } else {
 289         # Single directory, just make sure it is in directory format
 290         # Return an empty string on null input, and pass through macros.
 291
 292         if    (not defined $dir or not length $dir) { $rslt = ''; }
 293         elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) {
 294             $rslt = $dir;
 295         } else {
 296             my $unix_mode = 0;
 297
 298             if ($efs) {
 299                 my $dir_unix = 0;
 300                 $dir_unix = 1 if ($dir =~ m#/#);
 301                 $dir_unix = 1 if ($dir =~ /^\.\.?$/);
 302                 my $dir_vms = 0;
 303                 $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
 304                 $dir_vms = 1 if ($dir =~ /^--?$/);
 305
 306                 if ($dir_vms == $dir_unix) {
 307                     # Ambiguous, so if in $unix_rpt mode then assume UNIX.
 308                     $unix_mode = 1 if $unix_rpt;
 309                 } else {
 310                     $unix_mode = 1 if $dir_unix;
 311                 }
 312             }
 313
 314             if ($unix_mode) {
 315                 return $dir;
 316             } else {
 317                 # For VMS, force it to be in directory format
 318                 $rslt = vmspath($dir);
 319             }
 320         }
 321     }
 322     return $self->canonpath($rslt);
 323 }
 324
 325 =item catfile (override)
 326
 327 Concatenates a list of directory specifications with a filename specification
 328 to build a path.
 329
 330 =cut
 331
 332 sub catfile {
 333     my $self = shift;
 334     my $tfile = pop();
 335     my $file = $self->canonpath($tfile);
 336     my @files = grep {defined() && length()} @_;
 337
 338     my $efs = $self->_efs;
 339     my $unix_rpt = $self->_unix_rpt;
 340
 341     # Assume VMS mode
 342     my $unix_mode = 0;
 343     my $file_unix = 0;
 344     my $file_vms = 0;
 345     if ($efs) {
 346
 347         # Now we need to identify format the file is in
 348         # of the specification in order to merge them.
 349         $file_unix = 1 if ($tfile =~ m#/#);
 350         $file_unix = 1 if ($tfile =~ /^\.\.?$/);
 351         $file_vms = 1 if ($tfile =~ m#(?<!\^)[\[<\]:]#);
 352         $file_vms = 1 if ($tfile =~ /^--?$/);
 353
 354         # We may know for sure what the format is.
 355         if (($file_unix != $file_vms)) {
 356             $unix_mode = 1 if ($file_unix && $unix_rpt);
 357         }
 358     }
 359
 360     my $rslt;
 361     if (@files) {
 362         # concatenate the directories.
 363         my $path;
 364         if (@files == 1) {
 365            $path = $files[0];
 366         } else {
 367             if ($file_vms) {
 368                 # We need to make sure this is in VMS mode to avoid doing
 369                 # both a vmsify and unixfy on the same path, as that may
 370                 # lose significant data.
 371                 my $i = @files - 1;
 372                 my $tdir = $files[$i];
 373                 my $tdir_vms = 0;
 374                 my $tdir_unix = 0;
 375                 $tdir_vms = 1 if ($tdir =~ m#(?<!\^)[\[<\]:]#);
 376                 $tdir_unix = 1 if ($tdir =~ m#/#);
 377                 $tdir_unix = 1 if ($tdir =~ /^\.\.?$/);
 378
 379                 if (!$tdir_vms) {
 380                     if ($tdir_unix) {
 381                         $tdir = vmspath($tdir);
 382                     } else {
 383                         $tdir =~ s/\.dir\Z(?!\n)//i;
 384                         $tdir = '[.' . $tdir . ']';
 385                     }
 386                     $files[$i] = $tdir;
 387                 }
 388             }
 389             $path = $self->catdir(@files);
 390         }
 391         my $spath = $path;
 392
 393         # Some thing building a VMS path in pieces may try to pass a
 394         # directory name in filename format, so normalize it.
 395         $spath =~ s/\.dir\Z(?!\n)//i;
 396
 397         # if the spath ends with a directory delimiter and the file is bare,
 398         # then just concat them.
 399         if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
 400             $rslt = "$spath$file";
 401         } else {
 402             if ($efs) {
 403
 404                 # Now we need to identify what the directory is in
 405                 # of the specification in order to merge them.
 406                 my $spath_unix = 0;
 407                 $spath_unix = 1 if ($spath =~ m#/#);
 408                 $spath_unix = 1 if ($spath =~ /^\.\.?$/);
 409                 my $spath_vms = 0;
 410                 $spath_vms = 1 if ($spath =~ m#(?<!\^)[\[<\]:]#);
 411                 $spath_vms = 1 if ($spath =~ /^--?$/);
 412
 413                 # Assume VMS mode
 414                 if (($spath_unix == $spath_vms) &&
 415                     ($file_unix == $file_vms)) {
 416                      # Ambiguous, so if in $unix_rpt mode then assume UNIX.
 417                      $unix_mode = 1 if $unix_rpt;
 418                 } else {
 419                      $unix_mode = 1
 420                          if (($spath_unix || $file_unix) && $unix_rpt);
 421                 }
 422
 423                 if (!$unix_mode) {
 424                     if ($spath_vms) {
 425                         $spath = '[' . $spath . ']' if $spath =~ /^-/;
 426                         $rslt = vmspath($spath);
 427                     } else {
 428                         $rslt = '[.' . $spath . ']';
 429                     }
 430                     $file = vmsify($file) if ($file_unix);
 431                 } else {
 432                     $spath = unixify($spath) if ($spath_vms);
 433                     $rslt = $spath;
 434                     $file = unixify($file) if ($file_vms);
 435
 436                     # Unix merge may need a directory delimiter.
 437                     # A null path indicates root on Unix.
 438                     $rslt .= '/' unless ($rslt =~ m#/$#);
 439                 }
 440
 441                 $rslt .= $file;
 442                 $rslt =~ s/\]\[//;
 443
 444             } else {
 445                 # Traditional VMS Perl mode expects that this is done.
 446                 # Note for future maintainers:
 447                 # This is left here for compatibility with perl scripts
 448                 # that have come to expect this behavior, even though
 449                 # usually the Perl scripts ported to VMS have to be
 450                 # patched because of it changing Unix syntax file
 451                 # to VMS format.
 452
 453                 $rslt = $self->eliminate_macros($spath);
 454
 455
 456                 $rslt = vmsify($rslt.((defined $rslt) &&
 457                     ($rslt ne '') ? '/' : '').unixify($file));
 458             }
 459         }
 460     }
 461     else {
 462         # Only passed a single file?
 463         my $xfile = $file;
 464
 465         # Traditional VMS perl expects this conversion.
 466         $xfile = vmsify($file) unless ($efs);
 467
 468         $rslt = (defined($file) && length($file)) ? $xfile : '';
 469     }
 470     return $self->canonpath($rslt) unless $unix_rpt;
 471
 472     # In Unix report mode, do not strip off redundant path information.
 473     return $rslt;
 474 }
 475
 476
 477 =item curdir (override)
 478
 479 Returns a string representation of the current directory: '[]' or '.'
 480
 481 =cut
 482
 483 sub curdir {
 484     my $self = shift @_;
 485     return '.' if ($self->_unix_rpt);
 486     return '[]';
 487 }
 488
 489 =item devnull (override)
 490
 491 Returns a string representation of the null device: '_NLA0:' or '/dev/null'
 492
 493 =cut
 494
 495 sub devnull {
 496     my $self = shift @_;
 497     return '/dev/null' if ($self->_unix_rpt);
 498     return "_NLA0:";
 499 }
 500
 501 =item rootdir (override)
 502
 503 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 504 or '/'
 505
 506 =cut
 507
 508 sub rootdir {
 509     my $self = shift @_;
 510     if ($self->_unix_rpt) {
 511        # Root may exist, try it first.
 512        my $try = '/';
 513        my ($dev1, $ino1) = stat('/');
 514        my ($dev2, $ino2) = stat('.');
 515
 516        # Perl falls back to '.' if it can not determine '/'
 517        if (($dev1 != $dev2) || ($ino1 != $ino2)) {
 518            return $try;
 519        }
 520        # Fall back to UNIX format sys$disk.
 521        return '/sys$disk/';
 522     }
 523     return 'SYS$DISK:[000000]';
 524 }
 525
 526 =item tmpdir (override)
 527
 528 Returns a string representation of the first writable directory
 529 from the following list or '' if none are writable:
 530
 531     /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
 532     sys$scratch:
 533     $ENV{TMPDIR}
 534
 535 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
 536 is tainted, it is not used.
 537
 538 =cut
 539
 540 my $tmpdir;
 541 sub tmpdir {
 542     my $self = shift @_;
 543     return $tmpdir if defined $tmpdir;
 544     if ($self->_unix_rpt) {
 545         $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
 546         return $tmpdir;
 547     }
 548
 549     $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
 550 }
 551
 552 =item updir (override)
 553
 554 Returns a string representation of the parent directory: '[-]' or '..'
 555
 556 =cut
 557
 558 sub updir {
 559     my $self = shift @_;
 560     return '..' if ($self->_unix_rpt);
 561     return '[-]';
 562 }
 563
 564 =item case_tolerant (override)
 565
 566 VMS file specification syntax is case-tolerant.
 567
 568 =cut
 569
 570 sub case_tolerant {
 571     return 1;
 572 }
 573
 574 =item path (override)
 575
 576 Translate logical name DCL$PATH as a searchlist, rather than trying
 577 to C<split> string value of C<$ENV{'PATH'}>.
 578
 579 =cut
 580
 581 sub path {
 582     my (@dirs,$dir,$i);
 583     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 584     return @dirs;
 585 }
 586
 587 =item file_name_is_absolute (override)
 588
 589 Checks for VMS directory spec as well as Unix separators.
 590
 591 =cut
 592
 593 sub file_name_is_absolute {
 594     my ($self,$file) = @_;
 595     # If it's a logical name, expand it.
 596     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
 597     return scalar($file =~ m!^/!s             ||
 598                   $file =~ m![<\[][^.\-\]>]!  ||
 599                   $file =~ /:[^<\[]/);
 600 }
 601
 602 =item splitpath (override)
 603
 604     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 605     ($volume,$directories,$file) = File::Spec->splitpath( $path,
 606                                                           $no_file );
 607
 608 Passing a true value for C<$no_file> indicates that the path being
 609 split only contains directory components, even on systems where you
 610 can usually (when not supporting a foreign syntax) tell the difference
 611 between directories and files at a glance.
 612
 613 =cut
 614
 615 sub splitpath {
 616     my($self,$path, $nofile) = @_;
 617     my($dev,$dir,$file)      = ('','','');
 618     my $efs = $self->_efs;
 619     my $vmsify_path = vmsify($path);
 620     if ($efs) {
 621         my $path_vms = 0;
 622         $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
 623         $path_vms = 1 if ($path =~ /^--?$/);
 624         if (!$path_vms) {
 625             return $self->SUPER::splitpath($path, $nofile);
 626         }
 627         $vmsify_path = $path;
 628     }
 629
 630     if ( $nofile ) {
 631         #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
 632         #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
 633         if( $vmsify_path =~ /(.*)\](.+)/ ){
 634             $vmsify_path = $1.'.'.$2.']';
 635         }
 636         $vmsify_path =~ /(.+:)?(.*)/s;
 637         $dir = defined $2 ? $2 : ''; # dir can be '0'
 638         return ($1 || '',$dir,$file);
 639     }
 640     else {
 641         $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
 642         return ($1 || '',$2 || '',$3);
 643     }
 644 }
 645
 646 =item splitdir (override)
 647
 648 Split a directory specification into the components.
 649
 650 =cut
 651
 652 sub splitdir {
 653     my($self,$dirspec) = @_;
 654     my @dirs = ();
 655     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
 656
 657     my $efs = $self->_efs;
 658
 659     my $dir_unix = 0;
 660     $dir_unix = 1 if ($dirspec =~ m#/#);
 661     $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
 662
 663     # Unix filespecs in EFS mode handled by Unix routines.
 664     if ($efs && $dir_unix) {
 665         return $self->SUPER::splitdir($dirspec);
 666     }
 667
 668     # FIX ME, only split for VMS delimiters not prefixed with '^'.
 669
 670     $dirspec =~ tr/<>/[]/;                      # < and >       ==> [ and ]
 671     $dirspec =~ s/\]\[\./\.\]\[/g;              # ][.           ==> .][
 672     $dirspec =~ s/\[000000\.\]\[/\[/g;          # [000000.][    ==> [
 673     $dirspec =~ s/\[000000\./\[/g;              # [000000.      ==> [
 674     $dirspec =~ s/\.\]\[000000\]/\]/g;          # .][000000]    ==> ]
 675     $dirspec =~ s/\.\]\[/\./g;                  # foo.][bar     ==> foo.bar
 676     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
 677                                                 # That loop does the following
 678                                                 # with any amount of dashes:
 679                                                 # .--.          ==> .-.-.
 680                                                 # [--.          ==> [-.-.
 681                                                 # .--]          ==> .-.-]
 682                                                 # [--]          ==> [-.-]
 683     $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
 684     $dirspec =~ s/^(\[|<)\./$1/;
 685     @dirs = split /(?<!\^)\./, vmspath($dirspec);
 686     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
 687     @dirs;
 688 }
 689
 690
 691 =item catpath (override)
 692
 693 Construct a complete filespec.
 694
 695 =cut
 696
 697 sub catpath {
 698     my($self,$dev,$dir,$file) = @_;
 699
 700     my $efs = $self->_efs;
 701     my $unix_rpt = $self->_unix_rpt;
 702
 703     my $unix_mode = 0;
 704     my $dir_unix = 0;
 705     $dir_unix = 1 if ($dir =~ m#/#);
 706     $dir_unix = 1 if ($dir =~ /^\.\.?$/);
 707     my $dir_vms = 0;
 708     $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
 709     $dir_vms = 1 if ($dir =~ /^--?$/);
 710
 711     if ($efs && (length($dev) == 0)) {
 712         if ($dir_unix == $dir_vms) {
 713             $unix_mode = $unix_rpt;
 714         } else {
 715             $unix_mode = $dir_unix;
 716         }
 717     }
 718
 719     # We look for a volume in $dev, then in $dir, but not both
 720     # but only if using VMS syntax.
 721     if (!$unix_mode) {
 722         $dir = vmspath($dir) if $dir_unix;
 723         my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
 724         $dev = $dir_volume unless length $dev;
 725         $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) :
 726                                   $dir_dir;
 727     }
 728     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
 729     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
 730     if (length($dev) or length($dir)) {
 731       if ($efs) {
 732           if ($unix_mode) {
 733               $dir .= '/' unless ($dir =~ m#/$#);
 734           } else {
 735               $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
 736               $dir = "[$dir]" unless $dir =~ /^[\[<]/;
 737           }
 738       } else {
 739           $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
 740           $dir = vmspath($dir);
 741       }
 742     }
 743     $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
 744     "$dev$dir$file";
 745 }
 746
 747 =item abs2rel (override)
 748
 749 Attempt to convert a file specification to a relative specification.
 750 On a system with volumes, like VMS, this may not be possible.
 751
 752 =cut
 753
 754 sub abs2rel {
 755     my $self = shift;
 756     my($path,$base) = @_;
 757
 758     my $efs = $self->_efs;
 759     my $unix_rpt = $self->_unix_rpt;
 760
 761     # We need to identify what the directory is in
 762     # of the specification in order to process them
 763     my $path_unix = 0;
 764     $path_unix = 1 if ($path =~ m#/#);
 765     $path_unix = 1 if ($path =~ /^\.\.?$/);
 766     my $path_vms = 0;
 767     $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
 768     $path_vms = 1 if ($path =~ /^--?$/);
 769
 770     my $unix_mode = 0;
 771     if ($path_vms == $path_unix) {
 772         $unix_mode = $unix_rpt;
 773     } else {
 774         $unix_mode = $path_unix;
 775     }
 776
 777     my $base_unix = 0;
 778     my $base_vms = 0;
 779
 780     if (defined $base) {
 781         $base_unix = 1 if ($base =~ m#/#);
 782         $base_unix = 1 if ($base =~ /^\.\.?$/);
 783         $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
 784         $base_vms = 1 if ($base =~ /^--?$/);
 785
 786         if ($path_vms == $path_unix) {
 787             if ($base_vms == $base_unix) {
 788                 $unix_mode = $unix_rpt;
 789             } else {
 790                 $unix_mode = $base_unix;
 791             }
 792         } else {
 793             $unix_mode = 0 if $base_vms;
 794         }
 795     }
 796
 797     if ($efs) {
 798         if ($unix_mode) {
 799             # We are UNIX mode.
 800             $base = unixpath($base) if $base_vms;
 801             $base = unixify($path) if $path_vms;
 802
 803             # Here VMS is different, and in order to do this right
 804             # we have to take the realpath for both the path and the base
 805             # so that we can remove the common components.
 806
 807             if ($path =~ m#^/#) {
 808                 if (defined $base) {
 809
 810                     # For the shorterm, if the starting directories are
 811                     # common, remove them.
 812                     my $bq = qq($base);
 813                     $bq =~ s/\$/\\\$/;
 814                     $path =~ s/^$bq//i;
 815                 }
 816                 return $path;
 817             }
 818
 819             return File::Spec::Unix::abs2rel( $self, $path, $base );
 820
 821         } else {
 822             $base = vmspath($base) if $base_unix;
 823             $path = vmsify($path) if $path_unix;
 824         }
 825     }
 826
 827     unless (defined $base and length $base) {
 828         $base = $self->_cwd();
 829         if ($efs) {
 830             $base_unix = 1 if ($base =~ m#/#);
 831             $base_unix = 1 if ($base =~ /^\.\.?$/);
 832             $base = vmspath($base) if $base_unix;
 833         }
 834     }
 835
 836     for ($path, $base) { $_ = $self->canonpath($_) }
 837
 838     # Are we even starting $path on the same (node::)device as $base?  Note that
 839     # logical paths or nodename differences may be on the "same device"
 840     # but the comparison that ignores device differences so as to concatenate
 841     # [---] up directory specs is not even a good idea in cases where there is
 842     # a logical path difference between $path and $base nodename and/or device.
 843     # Hence we fall back to returning the absolute $path spec
 844     # if there is a case blind device (or node) difference of any sort
 845     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
 846     # (this module needs to run on non VMS platforms after all).
 847
 848     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
 849     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
 850     return $path unless lc($path_volume) eq lc($base_volume);
 851
 852     for ($path, $base) { $_ = $self->rel2abs($_) }
 853
 854     # Now, remove all leading components that are the same
 855     my @pathchunks = $self->splitdir( $path_directories );
 856     my $pathchunks = @pathchunks;
 857     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
 858     my @basechunks = $self->splitdir( $base_directories );
 859     my $basechunks = @basechunks;
 860     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
 861
 862     while ( @pathchunks &&
 863             @basechunks &&
 864             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 865           ) {
 866         shift @pathchunks ;
 867         shift @basechunks ;
 868     }
 869
 870     # @basechunks now contains the directories to climb out of,
 871     # @pathchunks now has the directories to descend in to.
 872     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
 873       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
 874     }
 875     else {
 876       $path_directories = join '.', @pathchunks;
 877     }
 878     $path_directories = '['.$path_directories.']';
 879     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
 880 }
 881
 882
 883 =item rel2abs (override)
 884
 885 Return an absolute file specification from a relative one.
 886
 887 =cut
 888
 889 sub rel2abs {
 890     my $self = shift ;
 891     my ($path,$base ) = @_;
 892     return undef unless defined $path;
 893
 894     my $efs = $self->_efs;
 895     my $unix_rpt = $self->_unix_rpt;
 896
 897     # We need to identify what the directory is in
 898     # of the specification in order to process them
 899     my $path_unix = 0;
 900     $path_unix = 1 if ($path =~ m#/#);
 901     $path_unix = 1 if ($path =~ /^\.\.?$/);
 902     my $path_vms = 0;
 903     $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
 904     $path_vms = 1 if ($path =~ /^--?$/);
 905
 906     my $unix_mode = 0;
 907     if ($path_vms == $path_unix) {
 908         $unix_mode = $unix_rpt;
 909     } else {
 910         $unix_mode = $path_unix;
 911     }
 912
 913     my $base_unix = 0;
 914     my $base_vms = 0;
 915
 916     if (defined $base) {
 917         $base_unix = 1 if ($base =~ m#/#);
 918         $base_unix = 1 if ($base =~ /^\.\.?$/);
 919         $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
 920         $base_vms = 1 if ($base =~ /^--?$/);
 921
 922         # If we could not determine the path mode, see if we can find out
 923         # from the base.
 924         if ($path_vms == $path_unix) {
 925             if ($base_vms != $base_unix) {
 926                 $unix_mode = $base_unix;
 927             }
 928         }
 929     }
 930
 931     if (!$efs) {
 932         # Legacy behavior, convert to VMS syntax.
 933         $unix_mode = 0;
 934         if (defined $base) {
 935             $base = vmspath($base) if $base =~ m/\//;
 936         }
 937
 938         if ($path =~ m/\//) {
 939             $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
 940                        ? vmspath($path)             # whether it's a directory
 941                        : vmsify($path) );
 942         }
 943    }
 944
 945     # Clean up and split up $path
 946     if ( ! $self->file_name_is_absolute( $path ) ) {
 947         # Figure out the effective $base and clean it up.
 948         if ( !defined( $base ) || $base eq '' ) {
 949             $base = $self->_cwd;
 950         }
 951         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 952             $base = $self->rel2abs( $base ) ;
 953         }
 954         else {
 955             $base = $self->canonpath( $base ) ;
 956         }
 957
 958         if ($efs) {
 959             # base may have changed, so need to look up format again.
 960             if ($unix_mode) {
 961                 $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
 962                 $base_vms = 1 if ($base =~ /^--?$/);
 963                 $base = unixpath($base) if $base_vms;
 964                 $base .= '/' unless ($base =~ m#/$#);
 965             } else {
 966                 $base_unix = 1 if ($base =~ m#/#);
 967                 $base_unix = 1 if ($base =~ /^\.\.?$/);
 968                 $base = vmspath($base) if $base_unix;
 969             }
 970         }
 971
 972         # Split up paths
 973         my ( $path_directories, $path_file ) =
 974             ($self->splitpath( $path ))[1,2] ;
 975
 976         my ( $base_volume, $base_directories ) =
 977             $self->splitpath( $base ) ;
 978
 979         $path_directories = '' if $path_directories eq '[]' ||
 980                                   $path_directories eq '<>';
 981         my $sep = '' ;
 982
 983         if ($efs) {
 984             # Merge the paths assuming that the base is absolute.
 985             $base_directories = $self->catdir('',
 986                                               $base_directories,
 987                                               $path_directories);
 988         } else {
 989             # Legacy behavior assumes VMS only paths
 990             $sep = '.'
 991                 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
 992                      $path_directories =~ m{^[^.\[<]}s
 993                 ) ;
 994             $base_directories = "$base_directories$sep$path_directories";
 995             $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
 996         }
 997
 998         $path_file = '' if ($path_file eq '.') && $unix_mode;
 999
1000         $path = $self->catpath( $base_volume, $base_directories, $path_file );
1001    }
1002
1003     return $self->canonpath( $path ) ;
1004 }
1005
1006
1007 # eliminate_macros() and fixpath() are MakeMaker-specific methods
1008 # which are used inside catfile() and catdir().  MakeMaker has its own
1009 # copies as of 6.06_03 which are the canonical ones.  We leave these
1010 # here, in peace, so that File::Spec continues to work with MakeMakers
1011 # prior to 6.06_03.
1012 #
1013 # Please consider these two methods deprecated.  Do not patch them,
1014 # patch the ones in ExtUtils::MM_VMS instead.
1015 #
1016 # Update:  MakeMaker 6.48 is still using these routines on VMS.
1017 # so they need to be kept up to date with ExtUtils::MM_VMS.
1018 #
1019 # The traditional VMS mode using ODS-2 disks depends on these routines
1020 # being here.  These routines should not be called in when the
1021 # C<DECC$EFS_CHARSET> or C<DECC$FILENAME_UNIX_REPORT> modes are enabled.
1022
1023 sub eliminate_macros {
1024     my($self,$path) = @_;
1025     return '' unless (defined $path) && ($path ne '');
1026     $self = {} unless ref $self;
1027
1028     if ($path =~ /\s/) {
1029       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1030     }
1031
1032     my $npath = unixify($path);
1033     # sometimes unixify will return a string with an off-by-one trailing null
1034     $npath =~ s{\0$}{};
1035
1036     my($complex) = 0;
1037     my($head,$macro,$tail);
1038
1039     # perform m##g in scalar context so it acts as an iterator
1040     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
1041         if (defined $self->{$2}) {
1042             ($head,$macro,$tail) = ($1,$2,$3);
1043             if (ref $self->{$macro}) {
1044                 if (ref $self->{$macro} eq 'ARRAY') {
1045                     $macro = join ' ', @{$self->{$macro}};
1046                 }
1047                 else {
1048                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
1049                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
1050                     $macro = "\cB$macro\cB";
1051                     $complex = 1;
1052                 }
1053             }
1054             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1055             $npath = "$head$macro$tail";
1056         }
1057     }
1058     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1059     $npath;
1060 }
1061
1062 # Deprecated.  See the note above for eliminate_macros().
1063
1064 # Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
1065 # in any directory specification, in order to avoid juxtaposing two
1066 # VMS-syntax directories when MM[SK] is run.  Also expands expressions which
1067 # are all macro, so that we can tell how long the expansion is, and avoid
1068 # overrunning DCL's command buffer when MM[KS] is running.
1069
1070 # fixpath() checks to see whether the result matches the name of a
1071 # directory in the current default directory and returns a directory or
1072 # file specification accordingly.  C<$is_dir> can be set to true to
1073 # force fixpath() to consider the path to be a directory or false to force
1074 # it to be a file.
1075
1076 sub fixpath {
1077     my($self,$path,$force_path) = @_;
1078     return '' unless $path;
1079     $self = bless {}, $self unless ref $self;
1080     my($fixedpath,$prefix,$name);
1081
1082     if ($path =~ /\s/) {
1083       return join ' ',
1084              map { $self->fixpath($_,$force_path) }
1085              split /\s+/, $path;
1086     }
1087
1088     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
1089         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
1090             $fixedpath = vmspath($self->eliminate_macros($path));
1091         }
1092         else {
1093             $fixedpath = vmsify($self->eliminate_macros($path));
1094         }
1095     }
1096     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1097         my($vmspre) = $self->eliminate_macros("\$($prefix)");
1098         # is it a dir or just a name?
1099         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
1100         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
1101         $fixedpath = vmspath($fixedpath) if $force_path;
1102     }
1103     else {
1104         $fixedpath = $path;
1105         $fixedpath = vmspath($fixedpath) if $force_path;
1106     }
1107     # No hints, so we try to guess
1108     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
1109         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
1110     }
1111
1112     # Trim off root dirname if it's had other dirs inserted in front of it.
1113     $fixedpath =~ s/\.000000([\]>])/$1/;
1114     # Special case for VMS absolute directory specs: these will have had device
1115     # prepended during trip through Unix syntax in eliminate_macros(), since
1116     # Unix syntax has no way to express "absolute from the top of this device's
1117     # directory tree".
1118     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1119     $fixedpath;
1120 }
1121
1122
1123 =back
1124
1125 =head1 COPYRIGHT
1126
1127 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
1128
1129 This program is free software; you can redistribute it and/or modify
1130 it under the same terms as Perl itself.
1131
1132 =head1 SEE ALSO
1133
1134 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
1135 implementation of these methods, not the semantics.
1136
1137 An explanation of VMS file specs can be found at
1138 L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
1139
1140 =cut
1141
1142 1;