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