| 1 | package File::Spec::VMS;
|
|---|
| 2 |
|
|---|
| 3 | use strict;
|
|---|
| 4 | use vars qw(@ISA $VERSION);
|
|---|
| 5 | require File::Spec::Unix;
|
|---|
| 6 |
|
|---|
| 7 | $VERSION = '1.4';
|
|---|
| 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 | if ($path =~ m|/|) { # Fake Unix
|
|---|
| 40 | my $pathify = $path =~ m|/\Z(?!\n)|;
|
|---|
| 41 | $path = $self->SUPER::canonpath($path);
|
|---|
| 42 | if ($pathify) { return vmspath($path); }
|
|---|
| 43 | else { return vmsify($path); }
|
|---|
| 44 | }
|
|---|
| 45 | else {
|
|---|
| 46 | $path =~ tr/<>/[]/; # < and > ==> [ and ]
|
|---|
| 47 | $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
|
|---|
| 48 | $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
|
|---|
| 49 | $path =~ s/\[000000\./\[/g; # [000000. ==> [
|
|---|
| 50 | $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
|
|---|
| 51 | $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
|
|---|
| 52 | 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
|
|---|
| 53 | # That loop does the following
|
|---|
| 54 | # with any amount of dashes:
|
|---|
| 55 | # .-.-. ==> .--.
|
|---|
| 56 | # [-.-. ==> [--.
|
|---|
| 57 | # .-.-] ==> .--]
|
|---|
| 58 | # [-.-] ==> [--]
|
|---|
| 59 | 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
|
|---|
| 60 | # That loop does the following
|
|---|
| 61 | # with any amount (minimum 2)
|
|---|
| 62 | # of dashes:
|
|---|
| 63 | # .foo.--. ==> .-.
|
|---|
| 64 | # .foo.--] ==> .-]
|
|---|
| 65 | # [foo.--. ==> [-.
|
|---|
| 66 | # [foo.--] ==> [-]
|
|---|
| 67 | #
|
|---|
| 68 | # And then, the remaining cases
|
|---|
| 69 | $path =~ s/\[\.-/[-/; # [.- ==> [-
|
|---|
| 70 | $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
|
|---|
| 71 | $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
|
|---|
| 72 | $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
|
|---|
| 73 | $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
|
|---|
| 74 | $path =~ s/\[\]//; # [] ==>
|
|---|
| 75 | return $path;
|
|---|
| 76 | }
|
|---|
| 77 | }
|
|---|
| 78 |
|
|---|
| 79 | =item catdir (override)
|
|---|
| 80 |
|
|---|
| 81 | Concatenates a list of file specifications, and returns the result as a
|
|---|
| 82 | VMS-syntax directory specification. No check is made for "impossible"
|
|---|
| 83 | cases (e.g. elements other than the first being absolute filespecs).
|
|---|
| 84 |
|
|---|
| 85 | =cut
|
|---|
| 86 |
|
|---|
| 87 | sub catdir {
|
|---|
| 88 | my ($self,@dirs) = @_;
|
|---|
| 89 | my $dir = pop @dirs;
|
|---|
| 90 | @dirs = grep($_,@dirs);
|
|---|
| 91 | my $rslt;
|
|---|
| 92 | if (@dirs) {
|
|---|
| 93 | my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
|
|---|
| 94 | my ($spath,$sdir) = ($path,$dir);
|
|---|
| 95 | $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
|
|---|
| 96 | $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
|
|---|
| 97 | $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
|
|---|
| 98 |
|
|---|
| 99 | # Special case for VMS absolute directory specs: these will have had device
|
|---|
| 100 | # prepended during trip through Unix syntax in eliminate_macros(), since
|
|---|
| 101 | # Unix syntax has no way to express "absolute from the top of this device's
|
|---|
| 102 | # directory tree".
|
|---|
| 103 | if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
|
|---|
| 104 | }
|
|---|
| 105 | else {
|
|---|
| 106 | if (not defined $dir or not length $dir) { $rslt = ''; }
|
|---|
| 107 | elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }
|
|---|
| 108 | else { $rslt = vmspath($dir); }
|
|---|
| 109 | }
|
|---|
| 110 | return $self->canonpath($rslt);
|
|---|
| 111 | }
|
|---|
| 112 |
|
|---|
| 113 | =item catfile (override)
|
|---|
| 114 |
|
|---|
| 115 | Concatenates a list of file specifications, and returns the result as a
|
|---|
| 116 | VMS-syntax file specification.
|
|---|
| 117 |
|
|---|
| 118 | =cut
|
|---|
| 119 |
|
|---|
| 120 | sub catfile {
|
|---|
| 121 | my ($self,@files) = @_;
|
|---|
| 122 | my $file = $self->canonpath(pop @files);
|
|---|
| 123 | @files = grep($_,@files);
|
|---|
| 124 | my $rslt;
|
|---|
| 125 | if (@files) {
|
|---|
| 126 | my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
|
|---|
| 127 | my $spath = $path;
|
|---|
| 128 | $spath =~ s/\.dir\Z(?!\n)//;
|
|---|
| 129 | if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
|
|---|
| 130 | $rslt = "$spath$file";
|
|---|
| 131 | }
|
|---|
| 132 | else {
|
|---|
| 133 | $rslt = $self->eliminate_macros($spath);
|
|---|
| 134 | $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
|
|---|
| 135 | }
|
|---|
| 136 | }
|
|---|
| 137 | else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
|
|---|
| 138 | return $self->canonpath($rslt);
|
|---|
| 139 | }
|
|---|
| 140 |
|
|---|
| 141 |
|
|---|
| 142 | =item curdir (override)
|
|---|
| 143 |
|
|---|
| 144 | Returns a string representation of the current directory: '[]'
|
|---|
| 145 |
|
|---|
| 146 | =cut
|
|---|
| 147 |
|
|---|
| 148 | sub curdir {
|
|---|
| 149 | return '[]';
|
|---|
| 150 | }
|
|---|
| 151 |
|
|---|
| 152 | =item devnull (override)
|
|---|
| 153 |
|
|---|
| 154 | Returns a string representation of the null device: '_NLA0:'
|
|---|
| 155 |
|
|---|
| 156 | =cut
|
|---|
| 157 |
|
|---|
| 158 | sub devnull {
|
|---|
| 159 | return "_NLA0:";
|
|---|
| 160 | }
|
|---|
| 161 |
|
|---|
| 162 | =item rootdir (override)
|
|---|
| 163 |
|
|---|
| 164 | Returns a string representation of the root directory: 'SYS$DISK:[000000]'
|
|---|
| 165 |
|
|---|
| 166 | =cut
|
|---|
| 167 |
|
|---|
| 168 | sub rootdir {
|
|---|
| 169 | return 'SYS$DISK:[000000]';
|
|---|
| 170 | }
|
|---|
| 171 |
|
|---|
| 172 | =item tmpdir (override)
|
|---|
| 173 |
|
|---|
| 174 | Returns a string representation of the first writable directory
|
|---|
| 175 | from the following list or '' if none are writable:
|
|---|
| 176 |
|
|---|
| 177 | sys$scratch:
|
|---|
| 178 | $ENV{TMPDIR}
|
|---|
| 179 |
|
|---|
| 180 | Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
|
|---|
| 181 | is tainted, it is not used.
|
|---|
| 182 |
|
|---|
| 183 | =cut
|
|---|
| 184 |
|
|---|
| 185 | my $tmpdir;
|
|---|
| 186 | sub tmpdir {
|
|---|
| 187 | return $tmpdir if defined $tmpdir;
|
|---|
| 188 | $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
|
|---|
| 189 | }
|
|---|
| 190 |
|
|---|
| 191 | =item updir (override)
|
|---|
| 192 |
|
|---|
| 193 | Returns a string representation of the parent directory: '[-]'
|
|---|
| 194 |
|
|---|
| 195 | =cut
|
|---|
| 196 |
|
|---|
| 197 | sub updir {
|
|---|
| 198 | return '[-]';
|
|---|
| 199 | }
|
|---|
| 200 |
|
|---|
| 201 | =item case_tolerant (override)
|
|---|
| 202 |
|
|---|
| 203 | VMS file specification syntax is case-tolerant.
|
|---|
| 204 |
|
|---|
| 205 | =cut
|
|---|
| 206 |
|
|---|
| 207 | sub case_tolerant {
|
|---|
| 208 | return 1;
|
|---|
| 209 | }
|
|---|
| 210 |
|
|---|
| 211 | =item path (override)
|
|---|
| 212 |
|
|---|
| 213 | Translate logical name DCL$PATH as a searchlist, rather than trying
|
|---|
| 214 | to C<split> string value of C<$ENV{'PATH'}>.
|
|---|
| 215 |
|
|---|
| 216 | =cut
|
|---|
| 217 |
|
|---|
| 218 | sub path {
|
|---|
| 219 | my (@dirs,$dir,$i);
|
|---|
| 220 | while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
|
|---|
| 221 | return @dirs;
|
|---|
| 222 | }
|
|---|
| 223 |
|
|---|
| 224 | =item file_name_is_absolute (override)
|
|---|
| 225 |
|
|---|
| 226 | Checks for VMS directory spec as well as Unix separators.
|
|---|
| 227 |
|
|---|
| 228 | =cut
|
|---|
| 229 |
|
|---|
| 230 | sub file_name_is_absolute {
|
|---|
| 231 | my ($self,$file) = @_;
|
|---|
| 232 | # If it's a logical name, expand it.
|
|---|
| 233 | $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
|
|---|
| 234 | return scalar($file =~ m!^/!s ||
|
|---|
| 235 | $file =~ m![<\[][^.\-\]>]! ||
|
|---|
| 236 | $file =~ /:[^<\[]/);
|
|---|
| 237 | }
|
|---|
| 238 |
|
|---|
| 239 | =item splitpath (override)
|
|---|
| 240 |
|
|---|
| 241 | Splits using VMS syntax.
|
|---|
| 242 |
|
|---|
| 243 | =cut
|
|---|
| 244 |
|
|---|
| 245 | sub splitpath {
|
|---|
| 246 | my($self,$path) = @_;
|
|---|
| 247 | my($dev,$dir,$file) = ('','','');
|
|---|
| 248 |
|
|---|
| 249 | vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
|
|---|
| 250 | return ($1 || '',$2 || '',$3);
|
|---|
| 251 | }
|
|---|
| 252 |
|
|---|
| 253 | =item splitdir (override)
|
|---|
| 254 |
|
|---|
| 255 | Split dirspec using VMS syntax.
|
|---|
| 256 |
|
|---|
| 257 | =cut
|
|---|
| 258 |
|
|---|
| 259 | sub splitdir {
|
|---|
| 260 | my($self,$dirspec) = @_;
|
|---|
| 261 | $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
|
|---|
| 262 | $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
|
|---|
| 263 | $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
|
|---|
| 264 | $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
|
|---|
| 265 | $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
|
|---|
| 266 | $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
|
|---|
| 267 | while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
|
|---|
| 268 | # That loop does the following
|
|---|
| 269 | # with any amount of dashes:
|
|---|
| 270 | # .--. ==> .-.-.
|
|---|
| 271 | # [--. ==> [-.-.
|
|---|
| 272 | # .--] ==> .-.-]
|
|---|
| 273 | # [--] ==> [-.-]
|
|---|
| 274 | $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
|
|---|
| 275 | my(@dirs) = split('\.', vmspath($dirspec));
|
|---|
| 276 | $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
|
|---|
| 277 | @dirs;
|
|---|
| 278 | }
|
|---|
| 279 |
|
|---|
| 280 |
|
|---|
| 281 | =item catpath (override)
|
|---|
| 282 |
|
|---|
| 283 | Construct a complete filespec using VMS syntax
|
|---|
| 284 |
|
|---|
| 285 | =cut
|
|---|
| 286 |
|
|---|
| 287 | sub catpath {
|
|---|
| 288 | my($self,$dev,$dir,$file) = @_;
|
|---|
| 289 |
|
|---|
| 290 | # We look for a volume in $dev, then in $dir, but not both
|
|---|
| 291 | my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
|
|---|
| 292 | $dev = $dir_volume unless length $dev;
|
|---|
| 293 | $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
|
|---|
| 294 |
|
|---|
| 295 | if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
|
|---|
| 296 | else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
|
|---|
| 297 | if (length($dev) or length($dir)) {
|
|---|
| 298 | $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
|
|---|
| 299 | $dir = vmspath($dir);
|
|---|
| 300 | }
|
|---|
| 301 | "$dev$dir$file";
|
|---|
| 302 | }
|
|---|
| 303 |
|
|---|
| 304 | =item abs2rel (override)
|
|---|
| 305 |
|
|---|
| 306 | Use VMS syntax when converting filespecs.
|
|---|
| 307 |
|
|---|
| 308 | =cut
|
|---|
| 309 |
|
|---|
| 310 | sub abs2rel {
|
|---|
| 311 | my $self = shift;
|
|---|
| 312 | return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
|
|---|
| 313 | if grep m{/}, @_;
|
|---|
| 314 |
|
|---|
| 315 | my($path,$base) = @_;
|
|---|
| 316 | $base = $self->_cwd() unless defined $base and length $base;
|
|---|
| 317 |
|
|---|
| 318 | for ($path, $base) { $_ = $self->canonpath($_) }
|
|---|
| 319 |
|
|---|
| 320 | # Are we even starting $path on the same (node::)device as $base? Note that
|
|---|
| 321 | # logical paths or nodename differences may be on the "same device"
|
|---|
| 322 | # but the comparison that ignores device differences so as to concatenate
|
|---|
| 323 | # [---] up directory specs is not even a good idea in cases where there is
|
|---|
| 324 | # a logical path difference between $path and $base nodename and/or device.
|
|---|
| 325 | # Hence we fall back to returning the absolute $path spec
|
|---|
| 326 | # if there is a case blind device (or node) difference of any sort
|
|---|
| 327 | # and we do not even try to call $parse() or consult %ENV for $trnlnm()
|
|---|
| 328 | # (this module needs to run on non VMS platforms after all).
|
|---|
| 329 |
|
|---|
| 330 | my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
|
|---|
| 331 | my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
|
|---|
| 332 | return $path unless lc($path_volume) eq lc($base_volume);
|
|---|
| 333 |
|
|---|
| 334 | for ($path, $base) { $_ = $self->rel2abs($_) }
|
|---|
| 335 |
|
|---|
| 336 | # Now, remove all leading components that are the same
|
|---|
| 337 | my @pathchunks = $self->splitdir( $path_directories );
|
|---|
| 338 | unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
|
|---|
| 339 | my @basechunks = $self->splitdir( $base_directories );
|
|---|
| 340 | unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
|
|---|
| 341 |
|
|---|
| 342 | while ( @pathchunks &&
|
|---|
| 343 | @basechunks &&
|
|---|
| 344 | lc( $pathchunks[0] ) eq lc( $basechunks[0] )
|
|---|
| 345 | ) {
|
|---|
| 346 | shift @pathchunks ;
|
|---|
| 347 | shift @basechunks ;
|
|---|
| 348 | }
|
|---|
| 349 |
|
|---|
| 350 | # @basechunks now contains the directories to climb out of,
|
|---|
| 351 | # @pathchunks now has the directories to descend in to.
|
|---|
| 352 | $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
|
|---|
| 353 | return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
|
|---|
| 354 | }
|
|---|
| 355 |
|
|---|
| 356 |
|
|---|
| 357 | =item rel2abs (override)
|
|---|
| 358 |
|
|---|
| 359 | Use VMS syntax when converting filespecs.
|
|---|
| 360 |
|
|---|
| 361 | =cut
|
|---|
| 362 |
|
|---|
| 363 | sub rel2abs {
|
|---|
| 364 | my $self = shift ;
|
|---|
| 365 | my ($path,$base ) = @_;
|
|---|
| 366 | return undef unless defined $path;
|
|---|
| 367 | if ($path =~ m/\//) {
|
|---|
| 368 | $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
|
|---|
| 369 | ? vmspath($path) # whether it's a directory
|
|---|
| 370 | : vmsify($path) );
|
|---|
| 371 | }
|
|---|
| 372 | $base = vmspath($base) if defined $base && $base =~ m/\//;
|
|---|
| 373 | # Clean up and split up $path
|
|---|
| 374 | if ( ! $self->file_name_is_absolute( $path ) ) {
|
|---|
| 375 | # Figure out the effective $base and clean it up.
|
|---|
| 376 | if ( !defined( $base ) || $base eq '' ) {
|
|---|
| 377 | $base = $self->_cwd;
|
|---|
| 378 | }
|
|---|
| 379 | elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
|---|
| 380 | $base = $self->rel2abs( $base ) ;
|
|---|
| 381 | }
|
|---|
| 382 | else {
|
|---|
| 383 | $base = $self->canonpath( $base ) ;
|
|---|
| 384 | }
|
|---|
| 385 |
|
|---|
| 386 | # Split up paths
|
|---|
| 387 | my ( $path_directories, $path_file ) =
|
|---|
| 388 | ($self->splitpath( $path ))[1,2] ;
|
|---|
| 389 |
|
|---|
| 390 | my ( $base_volume, $base_directories ) =
|
|---|
| 391 | $self->splitpath( $base ) ;
|
|---|
| 392 |
|
|---|
| 393 | $path_directories = '' if $path_directories eq '[]' ||
|
|---|
| 394 | $path_directories eq '<>';
|
|---|
| 395 | my $sep = '' ;
|
|---|
| 396 | $sep = '.'
|
|---|
| 397 | if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
|
|---|
| 398 | $path_directories =~ m{^[^.\[<]}s
|
|---|
| 399 | ) ;
|
|---|
| 400 | $base_directories = "$base_directories$sep$path_directories";
|
|---|
| 401 | $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
|
|---|
| 402 |
|
|---|
| 403 | $path = $self->catpath( $base_volume, $base_directories, $path_file );
|
|---|
| 404 | }
|
|---|
| 405 |
|
|---|
| 406 | return $self->canonpath( $path ) ;
|
|---|
| 407 | }
|
|---|
| 408 |
|
|---|
| 409 |
|
|---|
| 410 | # eliminate_macros() and fixpath() are MakeMaker-specific methods
|
|---|
| 411 | # which are used inside catfile() and catdir(). MakeMaker has its own
|
|---|
| 412 | # copies as of 6.06_03 which are the canonical ones. We leave these
|
|---|
| 413 | # here, in peace, so that File::Spec continues to work with MakeMakers
|
|---|
| 414 | # prior to 6.06_03.
|
|---|
| 415 | #
|
|---|
| 416 | # Please consider these two methods deprecated. Do not patch them,
|
|---|
| 417 | # patch the ones in ExtUtils::MM_VMS instead.
|
|---|
| 418 | sub eliminate_macros {
|
|---|
| 419 | my($self,$path) = @_;
|
|---|
| 420 | return '' unless $path;
|
|---|
| 421 | $self = {} unless ref $self;
|
|---|
| 422 |
|
|---|
| 423 | if ($path =~ /\s/) {
|
|---|
| 424 | return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
|
|---|
| 425 | }
|
|---|
| 426 |
|
|---|
| 427 | my($npath) = unixify($path);
|
|---|
| 428 | my($complex) = 0;
|
|---|
| 429 | my($head,$macro,$tail);
|
|---|
| 430 |
|
|---|
| 431 | # perform m##g in scalar context so it acts as an iterator
|
|---|
| 432 | while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
|
|---|
| 433 | if ($self->{$2}) {
|
|---|
| 434 | ($head,$macro,$tail) = ($1,$2,$3);
|
|---|
| 435 | if (ref $self->{$macro}) {
|
|---|
| 436 | if (ref $self->{$macro} eq 'ARRAY') {
|
|---|
| 437 | $macro = join ' ', @{$self->{$macro}};
|
|---|
| 438 | }
|
|---|
| 439 | else {
|
|---|
| 440 | print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
|
|---|
| 441 | "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
|
|---|
| 442 | $macro = "\cB$macro\cB";
|
|---|
| 443 | $complex = 1;
|
|---|
| 444 | }
|
|---|
| 445 | }
|
|---|
| 446 | else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
|
|---|
| 447 | $npath = "$head$macro$tail";
|
|---|
| 448 | }
|
|---|
| 449 | }
|
|---|
| 450 | if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
|
|---|
| 451 | $npath;
|
|---|
| 452 | }
|
|---|
| 453 |
|
|---|
| 454 | # Deprecated. See the note above for eliminate_macros().
|
|---|
| 455 | sub fixpath {
|
|---|
| 456 | my($self,$path,$force_path) = @_;
|
|---|
| 457 | return '' unless $path;
|
|---|
| 458 | $self = bless {} unless ref $self;
|
|---|
| 459 | my($fixedpath,$prefix,$name);
|
|---|
| 460 |
|
|---|
| 461 | if ($path =~ /\s/) {
|
|---|
| 462 | return join ' ',
|
|---|
| 463 | map { $self->fixpath($_,$force_path) }
|
|---|
| 464 | split /\s+/, $path;
|
|---|
| 465 | }
|
|---|
| 466 |
|
|---|
| 467 | if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
|
|---|
| 468 | if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
|
|---|
| 469 | $fixedpath = vmspath($self->eliminate_macros($path));
|
|---|
| 470 | }
|
|---|
| 471 | else {
|
|---|
| 472 | $fixedpath = vmsify($self->eliminate_macros($path));
|
|---|
| 473 | }
|
|---|
| 474 | }
|
|---|
| 475 | elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
|
|---|
| 476 | my($vmspre) = $self->eliminate_macros("\$($prefix)");
|
|---|
| 477 | # is it a dir or just a name?
|
|---|
| 478 | $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
|
|---|
| 479 | $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
|
|---|
| 480 | $fixedpath = vmspath($fixedpath) if $force_path;
|
|---|
| 481 | }
|
|---|
| 482 | else {
|
|---|
| 483 | $fixedpath = $path;
|
|---|
| 484 | $fixedpath = vmspath($fixedpath) if $force_path;
|
|---|
| 485 | }
|
|---|
| 486 | # No hints, so we try to guess
|
|---|
| 487 | if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
|
|---|
| 488 | $fixedpath = vmspath($fixedpath) if -d $fixedpath;
|
|---|
| 489 | }
|
|---|
| 490 |
|
|---|
| 491 | # Trim off root dirname if it's had other dirs inserted in front of it.
|
|---|
| 492 | $fixedpath =~ s/\.000000([\]>])/$1/;
|
|---|
| 493 | # Special case for VMS absolute directory specs: these will have had device
|
|---|
| 494 | # prepended during trip through Unix syntax in eliminate_macros(), since
|
|---|
| 495 | # Unix syntax has no way to express "absolute from the top of this device's
|
|---|
| 496 | # directory tree".
|
|---|
| 497 | if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
|
|---|
| 498 | $fixedpath;
|
|---|
| 499 | }
|
|---|
| 500 |
|
|---|
| 501 |
|
|---|
| 502 | =back
|
|---|
| 503 |
|
|---|
| 504 | =head1 COPYRIGHT
|
|---|
| 505 |
|
|---|
| 506 | Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
|---|
| 507 |
|
|---|
| 508 | This program is free software; you can redistribute it and/or modify
|
|---|
| 509 | it under the same terms as Perl itself.
|
|---|
| 510 |
|
|---|
| 511 | =head1 SEE ALSO
|
|---|
| 512 |
|
|---|
| 513 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
|---|
| 514 | implementation of these methods, not the semantics.
|
|---|
| 515 |
|
|---|
| 516 | An explanation of VMS file specs can be found at
|
|---|
| 517 | L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
|
|---|
| 518 |
|
|---|
| 519 | =cut
|
|---|
| 520 |
|
|---|
| 521 | 1;
|
|---|
