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