contrib/perl5/lib/File/Spec/VMS.pm

   1
   2 package File::Spec::VMS;
   3
   4 use Carp qw( &carp );
   5 use Config;
   6 require Exporter;
   7 use VMS::Filespec;
   8 use File::Basename;
   9
  10 use File::Spec;
  11 use vars qw($Revision);
  12 $Revision = '5.3901 (6-Mar-1997)';
  13
  14 @ISA = qw(File::Spec::Unix);
  15
  16 Exporter::import('File::Spec', '$Verbose');
  17
  18 =head1 NAME
  19
  20 File::Spec::VMS - methods for VMS file specs
  21
  22 =head1 SYNOPSIS
  23
  24  use File::Spec::VMS; # Done internally by File::Spec if needed
  25
  26 =head1 DESCRIPTION
  27
  28 See File::Spec::Unix for a documentation of the methods provided
  29 there. This package overrides the implementation of these methods, not
  30 the semantics.
  31
  32 =head2 Methods always loaded
  33
  34 =over
  35
  36 =item catdir
  37
  38 Concatenates a list of file specifications, and returns the result as a
  39 VMS-syntax directory specification.
  40
  41 =cut
  42
  43 sub catdir {
  44     my($self,@dirs) = @_;
  45     my($dir) = pop @dirs;
  46     @dirs = grep($_,@dirs);
  47     my($rslt);
  48     if (@dirs) {
  49       my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
  50       my($spath,$sdir) = ($path,$dir);
  51       $spath =~ s/.dir$//; $sdir =~ s/.dir$//;
  52       $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
  53       $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
  54     }
  55     else {
  56       if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
  57       else                          { $rslt = vmspath($dir); }
  58     }
  59     print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
  60     $rslt;
  61 }
  62
  63 =item catfile
  64
  65 Concatenates a list of file specifications, and returns the result as a
  66 VMS-syntax directory specification.
  67
  68 =cut
  69
  70 sub catfile {
  71     my($self,@files) = @_;
  72     my($file) = pop @files;
  73     @files = grep($_,@files);
  74     my($rslt);
  75     if (@files) {
  76       my($path) = (@files == 1 ? $files[0] : $self->catdir(@files));
  77       my($spath) = $path;
  78       $spath =~ s/.dir$//;
  79       if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; }
  80       else {
  81           $rslt = $self->eliminate_macros($spath);
  82           $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
  83       }
  84     }
  85     else { $rslt = vmsify($file); }
  86     print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
  87     $rslt;
  88 }
  89
  90 =item curdir (override)
  91
  92 Returns a string representing of the current directory.
  93
  94 =cut
  95
  96 sub curdir {
  97     return '[]';
  98 }
  99
 100 =item rootdir (override)
 101
 102 Returns a string representing of the root directory.
 103
 104 =cut
 105
 106 sub rootdir {
 107     return '';
 108 }
 109
 110 =item updir (override)
 111
 112 Returns a string representing of the parent directory.
 113
 114 =cut
 115
 116 sub updir {
 117     return '[-]';
 118 }
 119
 120 =item path (override)
 121
 122 Translate logical name DCL$PATH as a searchlist, rather than trying
 123 to C<split> string value of C<$ENV{'PATH'}>.
 124
 125 =cut
 126
 127 sub path {
 128     my(@dirs,$dir,$i);
 129     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 130     @dirs;
 131 }
 132
 133 =item file_name_is_absolute (override)
 134
 135 Checks for VMS directory spec as well as Unix separators.
 136
 137 =cut
 138
 139 sub file_name_is_absolute {
 140     my($self,$file) = @_;
 141     # If it's a logical name, expand it.
 142     $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file};
 143     $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/;
 144 }
 145
 146 1;
 147 __END__
 148