lib/File/Spec/VMS.pm

   1 package File::Spec::VMS;
   2
   3 use strict;
   4 use vars qw(@ISA);
   5 require File::Spec::Unix;
   6 @ISA = qw(File::Spec::Unix);
   7
   8 use File::Basename;
   9 use VMS::Filespec;
  10
  11 =head1 NAME
  12
  13 File::Spec::VMS - methods for VMS file specs
  14
  15 =head1 SYNOPSIS
  16
  17  require File::Spec::VMS; # Done internally by File::Spec if needed
  18
  19 =head1 DESCRIPTION
  20
  21 See File::Spec::Unix for a documentation of the methods provided
  22 there. This package overrides the implementation of these methods, not
  23 the semantics.
  24
  25 =cut
  26
  27 sub eliminate_macros {
  28     my($self,$path) = @_;
  29     return '' unless $path;
  30     $self = {} unless ref $self;
  31     my($npath) = unixify($path);
  32     my($complex) = 0;
  33     my($head,$macro,$tail);
  34
  35     # perform m##g in scalar context so it acts as an iterator
  36     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) {
  37         if ($self->{$2}) {
  38             ($head,$macro,$tail) = ($1,$2,$3);
  39             if (ref $self->{$macro}) {
  40                 if (ref $self->{$macro} eq 'ARRAY') {
  41                     $macro = join ' ', @{$self->{$macro}};
  42                 }
  43                 else {
  44                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
  45                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
  46                     $macro = "\cB$macro\cB";
  47                     $complex = 1;
  48                 }
  49             }
  50             else { ($macro = unixify($self->{$macro})) =~ s#/$##; }
  51             $npath = "$head$macro$tail";
  52         }
  53     }
  54     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; }
  55     $npath;
  56 }
  57
  58 sub fixpath {
  59     my($self,$path,$force_path) = @_;
  60     return '' unless $path;
  61     $self = bless {} unless ref $self;
  62     my($fixedpath,$prefix,$name);
  63
  64     if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) {
  65         if ($force_path or $path =~ /(?:DIR\)|\])$/) {
  66             $fixedpath = vmspath($self->eliminate_macros($path));
  67         }
  68         else {
  69             $fixedpath = vmsify($self->eliminate_macros($path));
  70         }
  71     }
  72     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
  73         my($vmspre) = $self->eliminate_macros("\$($prefix)");
  74         # is it a dir or just a name?
  75         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : '';
  76         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
  77         $fixedpath = vmspath($fixedpath) if $force_path;
  78     }
  79     else {
  80         $fixedpath = $path;
  81         $fixedpath = vmspath($fixedpath) if $force_path;
  82     }
  83     # No hints, so we try to guess
  84     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
  85         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
  86     }
  87     # Trim off root dirname if it's had other dirs inserted in front of it.
  88     $fixedpath =~ s/\.000000([\]>])/$1/;
  89     $fixedpath;
  90 }
  91
  92
  93 =head2 Methods always loaded
  94
  95 =over
  96
  97 =item catdir
  98
  99 Concatenates a list of file specifications, and returns the result as a
 100 VMS-syntax directory specification.
 101
 102 =cut
 103
 104 sub catdir {
 105     my ($self,@dirs) = @_;
 106     my $dir = pop @dirs;
 107     @dirs = grep($_,@dirs);
 108     my $rslt;
 109     if (@dirs) {
 110         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
 111         my ($spath,$sdir) = ($path,$dir);
 112         $spath =~ s/.dir$//; $sdir =~ s/.dir$//;
 113         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
 114         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
 115     }
 116     else {
 117         if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
 118         else                          { $rslt = vmspath($dir); }
 119     }
 120     return $rslt;
 121 }
 122
 123 =item catfile
 124
 125 Concatenates a list of file specifications, and returns the result as a
 126 VMS-syntax directory specification.
 127
 128 =cut
 129
 130 sub catfile {
 131     my ($self,@files) = @_;
 132     my $file = pop @files;
 133     @files = grep($_,@files);
 134     my $rslt;
 135     if (@files) {
 136         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
 137         my $spath = $path;
 138         $spath =~ s/.dir$//;
 139         if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) {
 140             $rslt = "$spath$file";
 141         }
 142         else {
 143             $rslt = $self->eliminate_macros($spath);
 144             $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
 145         }
 146     }
 147     else { $rslt = vmsify($file); }
 148     return $rslt;
 149 }
 150
 151 =item curdir (override)
 152
 153 Returns a string representation of the current directory: '[]'
 154
 155 =cut
 156
 157 sub curdir {
 158     return '[]';
 159 }
 160
 161 =item devnull (override)
 162
 163 Returns a string representation of the null device: '_NLA0:'
 164
 165 =cut
 166
 167 sub devnull {
 168     return "_NLA0:";
 169 }
 170
 171 =item rootdir (override)
 172
 173 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 174
 175 =cut
 176
 177 sub rootdir {
 178     return 'SYS$DISK:[000000]';
 179 }
 180
 181 =item tmpdir (override)
 182
 183 Returns a string representation of the first writable directory
 184 from the following list or '' if none are writable:
 185
 186     /sys$scratch
 187     $ENV{TMPDIR}
 188
 189 =cut
 190
 191 my $tmpdir;
 192 sub tmpdir {
 193     return $tmpdir if defined $tmpdir;
 194     foreach ('/sys$scratch', $ENV{TMPDIR}) {
 195         next unless defined && -d && -w _;
 196         $tmpdir = $_;
 197         last;
 198     }
 199     $tmpdir = '' unless defined $tmpdir;
 200     return $tmpdir;
 201 }
 202
 203 =item updir (override)
 204
 205 Returns a string representation of the parent directory: '[-]'
 206
 207 =cut
 208
 209 sub updir {
 210     return '[-]';
 211 }
 212
 213 =item path (override)
 214
 215 Translate logical name DCL$PATH as a searchlist, rather than trying
 216 to C<split> string value of C<$ENV{'PATH'}>.
 217
 218 =cut
 219
 220 sub path {
 221     my (@dirs,$dir,$i);
 222     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 223     return @dirs;
 224 }
 225
 226 =item file_name_is_absolute (override)
 227
 228 Checks for VMS directory spec as well as Unix separators.
 229
 230 =cut
 231
 232 sub file_name_is_absolute {
 233     my ($self,$file) = @_;
 234     # If it's a logical name, expand it.
 235     $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file};
 236     return scalar($file =~ m!^/!              ||
 237                   $file =~ m![<\[][^.\-\]>]!  ||
 238                   $file =~ /:[^<\[]/);
 239 }
 240
 241 =back
 242
 243 =head1 SEE ALSO
 244
 245 L<File::Spec>
 246
 247 =cut
 248
 249 1;