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