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 =item eliminate_macros
  26
  27 Expands MM[KS]/Make macros in a text string, using the contents of
  28 identically named elements of C<%$self>, and returns the result
  29 as a file specification in Unix syntax.
  30
  31 =cut
  32
  33 sub eliminate_macros {
  34     my($self,$path) = @_;
  35     return '' unless $path;
  36     $self = {} unless ref $self;
  37     my($npath) = unixify($path);
  38     my($complex) = 0;
  39     my($head,$macro,$tail);
  40
  41     # perform m##g in scalar context so it acts as an iterator
  42     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) {
  43         if ($self->{$2}) {
  44             ($head,$macro,$tail) = ($1,$2,$3);
  45             if (ref $self->{$macro}) {
  46                 if (ref $self->{$macro} eq 'ARRAY') {
  47                     $macro = join ' ', @{$self->{$macro}};
  48                 }
  49                 else {
  50                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
  51                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
  52                     $macro = "\cB$macro\cB";
  53                     $complex = 1;
  54                 }
  55             }
  56             else { ($macro = unixify($self->{$macro})) =~ s#/$##; }
  57             $npath = "$head$macro$tail";
  58         }
  59     }
  60     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; }
  61     $npath;
  62 }
  63
  64 =item fixpath
  65
  66 Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
  67 in any directory specification, in order to avoid juxtaposing two
  68 VMS-syntax directories when MM[SK] is run.  Also expands expressions which
  69 are all macro, so that we can tell how long the expansion is, and avoid
  70 overrunning DCL's command buffer when MM[KS] is running.
  71
  72 If optional second argument has a TRUE value, then the return string is
  73 a VMS-syntax directory specification, if it is FALSE, the return string
  74 is a VMS-syntax file specification, and if it is not specified, fixpath()
  75 checks to see whether it matches the name of a directory in the current
  76 default directory, and returns a directory or file specification accordingly.
  77
  78 =cut
  79
  80 sub fixpath {
  81     my($self,$path,$force_path) = @_;
  82     return '' unless $path;
  83     $self = bless {} unless ref $self;
  84     my($fixedpath,$prefix,$name);
  85
  86     if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) {
  87         if ($force_path or $path =~ /(?:DIR\)|\])$/) {
  88             $fixedpath = vmspath($self->eliminate_macros($path));
  89         }
  90         else {
  91             $fixedpath = vmsify($self->eliminate_macros($path));
  92         }
  93     }
  94     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
  95         my($vmspre) = $self->eliminate_macros("\$($prefix)");
  96         # is it a dir or just a name?
  97         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : '';
  98         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
  99         $fixedpath = vmspath($fixedpath) if $force_path;
 100     }
 101     else {
 102         $fixedpath = $path;
 103         $fixedpath = vmspath($fixedpath) if $force_path;
 104     }
 105     # No hints, so we try to guess
 106     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
 107         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
 108     }
 109     # Trim off root dirname if it's had other dirs inserted in front of it.
 110     $fixedpath =~ s/\.000000([\]>])/$1/;
 111     $fixedpath;
 112 }
 113
 114
 115 =head2 Methods always loaded
 116
 117 =over
 118
 119 =item catdir
 120
 121 Concatenates a list of file specifications, and returns the result as a
 122 VMS-syntax directory specification.
 123
 124 =cut
 125
 126 sub catdir {
 127     my ($self,@dirs) = @_;
 128     my $dir = pop @dirs;
 129     @dirs = grep($_,@dirs);
 130     my $rslt;
 131     if (@dirs) {
 132         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
 133         my ($spath,$sdir) = ($path,$dir);
 134         $spath =~ s/.dir$//; $sdir =~ s/.dir$//;
 135         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
 136         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
 137     }
 138     else {
 139         if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
 140         else                          { $rslt = vmspath($dir); }
 141     }
 142     return $rslt;
 143 }
 144
 145 =item catfile
 146
 147 Concatenates a list of file specifications, and returns the result as a
 148 VMS-syntax directory specification.
 149
 150 =cut
 151
 152 sub catfile {
 153     my ($self,@files) = @_;
 154     my $file = pop @files;
 155     @files = grep($_,@files);
 156     my $rslt;
 157     if (@files) {
 158         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
 159         my $spath = $path;
 160         $spath =~ s/.dir$//;
 161         if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) {
 162             $rslt = "$spath$file";
 163         }
 164         else {
 165             $rslt = $self->eliminate_macros($spath);
 166             $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
 167         }
 168     }
 169     else { $rslt = vmsify($file); }
 170     return $rslt;
 171 }
 172
 173 =item curdir (override)
 174
 175 Returns a string representation of the current directory: '[]'
 176
 177 =cut
 178
 179 sub curdir {
 180     return '[]';
 181 }
 182
 183 =item devnull (override)
 184
 185 Returns a string representation of the null device: '_NLA0:'
 186
 187 =cut
 188
 189 sub devnull {
 190     return "_NLA0:";
 191 }
 192
 193 =item rootdir (override)
 194
 195 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 196
 197 =cut
 198
 199 sub rootdir {
 200     return 'SYS$DISK:[000000]';
 201 }
 202
 203 =item tmpdir (override)
 204
 205 Returns a string representation of the first writable directory
 206 from the following list or '' if none are writable:
 207
 208     /sys$scratch
 209     $ENV{TMPDIR}
 210
 211 =cut
 212
 213 my $tmpdir;
 214 sub tmpdir {
 215     return $tmpdir if defined $tmpdir;
 216     foreach ('/sys$scratch', $ENV{TMPDIR}) {
 217         next unless defined && -d && -w _;
 218         $tmpdir = $_;
 219         last;
 220     }
 221     $tmpdir = '' unless defined $tmpdir;
 222     return $tmpdir;
 223 }
 224
 225 =item updir (override)
 226
 227 Returns a string representation of the parent directory: '[-]'
 228
 229 =cut
 230
 231 sub updir {
 232     return '[-]';
 233 }
 234
 235 =item path (override)
 236
 237 Translate logical name DCL$PATH as a searchlist, rather than trying
 238 to C<split> string value of C<$ENV{'PATH'}>.
 239
 240 =cut
 241
 242 sub path {
 243     my (@dirs,$dir,$i);
 244     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 245     return @dirs;
 246 }
 247
 248 =item file_name_is_absolute (override)
 249
 250 Checks for VMS directory spec as well as Unix separators.
 251
 252 =cut
 253
 254 sub file_name_is_absolute {
 255     my ($self,$file) = @_;
 256     # If it's a logical name, expand it.
 257     $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file};
 258     return scalar($file =~ m!^/!              ||
 259                   $file =~ m![<\[][^.\-\]>]!  ||
 260                   $file =~ /:[^<\[]/);
 261 }
 262
 263 =back
 264
 265 =head1 SEE ALSO
 266
 267 L<File::Spec>
 268
 269 =cut
 270
 271 1;