[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/File/Spec/ -> VMS.pm (source)

   1  package File::Spec::VMS;
   2  
   3  use strict;
   4  use vars qw(@ISA $VERSION);
   5  require File::Spec::Unix;
   6  
   7  $VERSION = '3.2501';
   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;


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1