1176491Smarcelpackage File::Spec::VMS; 2176491Smarcel 3176491Smarceluse strict; 4176491Smarceluse Cwd (); 5176491Smarcelrequire File::Spec::Unix; 6176491Smarcel 7176491Smarcelour $VERSION = '3.88'; 8176491Smarcel$VERSION =~ tr/_//d; 9176491Smarcel 10176491Smarcelour @ISA = qw(File::Spec::Unix); 11176491Smarcel 12176491Smarceluse File::Basename; 13176491Smarceluse VMS::Filespec; 14176491Smarcel 15176491Smarcel=head1 NAME 16176491Smarcel 17176491SmarcelFile::Spec::VMS - methods for VMS file specs 18176491Smarcel 19176491Smarcel=head1 SYNOPSIS 20176491Smarcel 21176491Smarcel require File::Spec::VMS; # Done internally by File::Spec if needed 22176491Smarcel 23176491Smarcel=head1 DESCRIPTION 24176491Smarcel 25176491SmarcelSee File::Spec::Unix for a documentation of the methods provided 26176491Smarcelthere. This package overrides the implementation of these methods, not 27176491Smarcelthe semantics. 28176491Smarcel 29176491SmarcelThe default behavior is to allow either VMS or Unix syntax on input and to 30176491Smarcelreturn VMS syntax on output unless Unix syntax has been explicitly requested 31176491Smarcelvia the C<DECC$FILENAME_UNIX_REPORT> CRTL feature. 32176491Smarcel 33176491Smarcel=over 4 34176491Smarcel 35176491Smarcel=cut 36176491Smarcel 37176491Smarcel# Need to look up the feature settings. The preferred way is to use the 38176491Smarcel# VMS::Feature module, but that may not be available to dual life modules. 39176491Smarcel 40176491Smarcelmy $use_feature; 41176491SmarcelBEGIN { 42176491Smarcel if (eval { local $SIG{__DIE__}; 43176491Smarcel local @INC = @INC; 44176491Smarcel pop @INC if $INC[-1] eq '.'; 45176491Smarcel require VMS::Feature; }) { 46176491Smarcel $use_feature = 1; 47176491Smarcel } 48176491Smarcel} 49176491Smarcel 50178030Sgrehan# Need to look up the UNIX report mode. This may become a dynamic mode 51176491Smarcel# in the future. 52176491Smarcelsub _unix_rpt { 53176491Smarcel my $unix_rpt; 54176491Smarcel if ($use_feature) { 55176491Smarcel $unix_rpt = VMS::Feature::current("filename_unix_report"); 56176491Smarcel } else { 57176491Smarcel my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; 58176491Smarcel $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 59176491Smarcel } 60176491Smarcel return $unix_rpt; 61176491Smarcel} 62176491Smarcel 63176491Smarcel=item canonpath (override) 64176491Smarcel 65176491SmarcelRemoves redundant portions of file specifications and returns results 66176491Smarcelin native syntax unless Unix filename reporting has been enabled. 67176491Smarcel 68176491Smarcel=cut 69176491Smarcel 70176491Smarcel 71176491Smarcelsub canonpath { 72176491Smarcel my($self,$path) = @_; 73176491Smarcel 74176491Smarcel return undef unless defined $path; 75176491Smarcel 76176491Smarcel my $unix_rpt = $self->_unix_rpt; 77176491Smarcel 78176491Smarcel if ($path =~ m|/|) { 79176491Smarcel my $pathify = $path =~ m|/\Z(?!\n)|; 80176491Smarcel $path = $self->SUPER::canonpath($path); 81176491Smarcel 82176491Smarcel return $path if $unix_rpt; 83176491Smarcel $path = $pathify ? vmspath($path) : vmsify($path); 84176491Smarcel } 85176491Smarcel 86176491Smarcel $path =~ s/(?<!\^)</[/; # < and > ==> [ and ] 87176491Smarcel $path =~ s/(?<!\^)>/]/; 88176491Smarcel $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ 89176491Smarcel $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ 90176491Smarcel $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ 91176491Smarcel $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] 92176491Smarcel $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar 93176491Smarcel 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/); 94176491Smarcel # That loop does the following 95176491Smarcel # with any amount of dashes: 96176491Smarcel # .-.-. ==> .--. 97176491Smarcel # [-.-. ==> [--. 98176491Smarcel # .-.-] ==> .--] 99176491Smarcel # [-.-] ==> [--] 100176491Smarcel 1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/); 101176491Smarcel # That loop does the following 102176491Smarcel # with any amount (minimum 2) 103176491Smarcel # of dashes: 104176491Smarcel # .foo.--. ==> .-. 105176491Smarcel # .foo.--] ==> .-] 106176491Smarcel # [foo.--. ==> [-. 107176491Smarcel # [foo.--] ==> [-] 108176491Smarcel # 109176491Smarcel # And then, the remaining cases 110176491Smarcel $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [- 111176491Smarcel $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g; # .foo.-. ==> . 112176491Smarcel $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g; # [foo.-. ==> [ 113176491Smarcel $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g; # .foo.-] ==> ] 114176491Smarcel # [foo.-] ==> [000000] 115176491Smarcel $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g; 116176491Smarcel # [] ==> 117176491Smarcel $path =~ s/(?<!\^)\[\]// unless $path eq '[]'; 118176491Smarcel return $unix_rpt ? unixify($path) : $path; 119176491Smarcel} 120176491Smarcel 121176491Smarcel=item catdir (override) 122176491Smarcel 123176491SmarcelConcatenates a list of file specifications, and returns the result as a 124176491Smarcelnative directory specification unless the Unix filename reporting feature 125176491Smarcelhas been enabled. No check is made for "impossible" cases (e.g. elements 126176491Smarcelother than the first being absolute filespecs). 127176491Smarcel 128176491Smarcel=cut 129176491Smarcel 130176491Smarcelsub catdir { 131176491Smarcel my $self = shift; 132176491Smarcel my $dir = pop; 133176491Smarcel 134176491Smarcel my $unix_rpt = $self->_unix_rpt; 135176491Smarcel 136176491Smarcel my @dirs = grep {defined() && length()} @_; 137176491Smarcel 138176491Smarcel my $rslt; 139176491Smarcel if (@dirs) { 140176491Smarcel my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); 141176491Smarcel my ($spath,$sdir) = ($path,$dir); 142176491Smarcel $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; 143176491Smarcel 144176491Smarcel if ($unix_rpt) { 145176491Smarcel $spath = unixify($spath) unless $spath =~ m#/#; 146176491Smarcel $sdir= unixify($sdir) unless $sdir =~ m#/#; 147176491Smarcel return $self->SUPER::catdir($spath, $sdir) 148176491Smarcel } 149176491Smarcel 150176491Smarcel $rslt = vmspath( unixify($spath) . '/' . unixify($sdir)); 151176491Smarcel 152176491Smarcel # Special case for VMS absolute directory specs: these will have 153176491Smarcel # had device prepended during trip through Unix syntax in 154176491Smarcel # eliminate_macros(), since Unix syntax has no way to express 155176491Smarcel # "absolute from the top of this device's directory tree". 156176491Smarcel if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } 157176491Smarcel 158176491Smarcel } else { 159176491Smarcel # Single directory. Return an empty string on null input; otherwise 160176491Smarcel # just return a canonical path. 161176491Smarcel 162176491Smarcel if (not defined $dir or not length $dir) { 163176491Smarcel $rslt = ''; 164176491Smarcel } else { 165176491Smarcel $rslt = $unix_rpt ? $dir : vmspath($dir); 166176491Smarcel } 167176491Smarcel } 168176491Smarcel return $self->canonpath($rslt); 169176491Smarcel} 170176491Smarcel 171176491Smarcel=item catfile (override) 172176491Smarcel 173176491SmarcelConcatenates a list of directory specifications with a filename specification 174176491Smarcelto build a path. 175176491Smarcel 176176491Smarcel=cut 177176491Smarcel 178176491Smarcelsub catfile { 179176491Smarcel my $self = shift; 180176491Smarcel my $tfile = pop(); 181176491Smarcel my $file = $self->canonpath($tfile); 182176491Smarcel my @files = grep {defined() && length()} @_; 183176491Smarcel 184176491Smarcel my $unix_rpt = $self->_unix_rpt; 185176491Smarcel 186176491Smarcel my $rslt; 187176491Smarcel if (@files) { 188176491Smarcel my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); 189176491Smarcel my $spath = $path; 190176491Smarcel 191176491Smarcel # Something building a VMS path in pieces may try to pass a 192176491Smarcel # directory name in filename format, so normalize it. 193176491Smarcel $spath =~ s/\.dir\Z(?!\n)//i; 194176491Smarcel 195176491Smarcel # If the spath ends with a directory delimiter and the file is bare, 196176491Smarcel # then just concatenate them. 197176491Smarcel if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { 198176491Smarcel $rslt = "$spath$file"; 199176491Smarcel } else { 200176491Smarcel $rslt = unixify($spath); 201176491Smarcel $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file); 202176491Smarcel $rslt = vmsify($rslt) unless $unix_rpt; 203176491Smarcel } 204176491Smarcel } 205176491Smarcel else { 206176491Smarcel # Only passed a single file? 207176491Smarcel my $xfile = (defined($file) && length($file)) ? $file : ''; 208176491Smarcel 209176491Smarcel $rslt = $unix_rpt ? $xfile : vmsify($xfile); 210176491Smarcel } 211176491Smarcel return $self->canonpath($rslt) unless $unix_rpt; 212176491Smarcel 213176491Smarcel # In Unix report mode, do not strip off redundant path information. 214176491Smarcel return $rslt; 215176491Smarcel} 216176491Smarcel 217176491Smarcel 218176491Smarcel=item curdir (override) 219176491Smarcel 220176491SmarcelReturns a string representation of the current directory: '[]' or '.' 221176491Smarcel 222176491Smarcel=cut 223176491Smarcel 224176491Smarcelsub curdir { 225176491Smarcel my $self = shift @_; 226176491Smarcel return '.' if ($self->_unix_rpt); 227176491Smarcel return '[]'; 228176491Smarcel} 229176491Smarcel 230176491Smarcel=item devnull (override) 231176491Smarcel 232176491SmarcelReturns a string representation of the null device: '_NLA0:' or '/dev/null' 233176491Smarcel 234176491Smarcel=cut 235176491Smarcel 236176491Smarcelsub devnull { 237176491Smarcel my $self = shift @_; 238176491Smarcel return '/dev/null' if ($self->_unix_rpt); 239176491Smarcel return "_NLA0:"; 240} 241 242=item rootdir (override) 243 244Returns a string representation of the root directory: 'SYS$DISK:[000000]' 245or '/' 246 247=cut 248 249sub rootdir { 250 my $self = shift @_; 251 if ($self->_unix_rpt) { 252 # Root may exist, try it first. 253 my $try = '/'; 254 my ($dev1, $ino1) = stat('/'); 255 my ($dev2, $ino2) = stat('.'); 256 257 # Perl falls back to '.' if it can not determine '/' 258 if (($dev1 != $dev2) || ($ino1 != $ino2)) { 259 return $try; 260 } 261 # Fall back to UNIX format sys$disk. 262 return '/sys$disk/'; 263 } 264 return 'SYS$DISK:[000000]'; 265} 266 267=item tmpdir (override) 268 269Returns a string representation of the first writable directory 270from the following list or '' if none are writable: 271 272 /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled. 273 sys$scratch: 274 $ENV{TMPDIR} 275 276If running under taint mode, and if $ENV{TMPDIR} 277is tainted, it is not used. 278 279=cut 280 281sub tmpdir { 282 my $self = shift @_; 283 my $tmpdir = $self->_cached_tmpdir('TMPDIR'); 284 return $tmpdir if defined $tmpdir; 285 if ($self->_unix_rpt) { 286 $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); 287 } 288 else { 289 $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); 290 } 291 $self->_cache_tmpdir($tmpdir, 'TMPDIR'); 292} 293 294=item updir (override) 295 296Returns a string representation of the parent directory: '[-]' or '..' 297 298=cut 299 300sub updir { 301 my $self = shift @_; 302 return '..' if ($self->_unix_rpt); 303 return '[-]'; 304} 305 306=item case_tolerant (override) 307 308VMS file specification syntax is case-tolerant. 309 310=cut 311 312sub case_tolerant { 313 return 1; 314} 315 316=item path (override) 317 318Translate logical name DCL$PATH as a searchlist, rather than trying 319to C<split> string value of C<$ENV{'PATH'}>. 320 321=cut 322 323sub path { 324 my (@dirs,$dir,$i); 325 while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } 326 return @dirs; 327} 328 329=item file_name_is_absolute (override) 330 331Checks for VMS directory spec as well as Unix separators. 332 333=cut 334 335sub file_name_is_absolute { 336 my ($self,$file) = @_; 337 # If it's a logical name, expand it. 338 $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; 339 return scalar($file =~ m!^/!s || 340 $file =~ m![<\[][^.\-\]>]! || 341 $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/); 342} 343 344=item splitpath (override) 345 346 ($volume,$directories,$file) = File::Spec->splitpath( $path ); 347 ($volume,$directories,$file) = File::Spec->splitpath( $path, 348 $no_file ); 349 350Passing a true value for C<$no_file> indicates that the path being 351split only contains directory components, even on systems where you 352can usually (when not supporting a foreign syntax) tell the difference 353between directories and files at a glance. 354 355=cut 356 357sub splitpath { 358 my($self,$path, $nofile) = @_; 359 my($dev,$dir,$file) = ('','',''); 360 my $vmsify_path = vmsify($path); 361 362 if ( $nofile ) { 363 #vmsify('d1/d2/d3') returns '[.d1.d2]d3' 364 #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' 365 if( $vmsify_path =~ /(.*)\](.+)/ ){ 366 $vmsify_path = $1.'.'.$2.']'; 367 } 368 $vmsify_path =~ /(.+:)?(.*)/s; 369 $dir = defined $2 ? $2 : ''; # dir can be '0' 370 return ($1 || '',$dir,$file); 371 } 372 else { 373 $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; 374 return ($1 || '',$2 || '',$3); 375 } 376} 377 378=item splitdir (override) 379 380Split a directory specification into the components. 381 382=cut 383 384sub splitdir { 385 my($self,$dirspec) = @_; 386 my @dirs = (); 387 return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); 388 389 $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ] 390 $dirspec =~ s/(?<!\^)>/]/; 391 $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ 392 $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ 393 $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ 394 $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] 395 $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar 396 while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} 397 # That loop does the following 398 # with any amount of dashes: 399 # .--. ==> .-.-. 400 # [--. ==> [-.-. 401 # .--] ==> .-.-] 402 # [--] ==> [-.-] 403 $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal 404 $dirspec =~ s/^(\[|<)\./$1/; 405 @dirs = split /(?<!\^)\./, vmspath($dirspec); 406 $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; 407 @dirs; 408} 409 410 411=item catpath (override) 412 413Construct a complete filespec. 414 415=cut 416 417sub catpath { 418 my($self,$dev,$dir,$file) = @_; 419 420 # We look for a volume in $dev, then in $dir, but not both 421 my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); 422 $dev = $dir_volume unless length $dev; 423 $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; 424 425 if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; } 426 else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } 427 if (length($dev) or length($dir)) { 428 $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/; 429 $dir = vmspath($dir); 430 } 431 $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>'); 432 "$dev$dir$file"; 433} 434 435=item abs2rel (override) 436 437Attempt to convert an absolute file specification to a relative specification. 438 439=cut 440 441sub abs2rel { 442 my $self = shift; 443 my($path,$base) = @_; 444 445 $base = Cwd::getcwd() unless defined $base and length $base; 446 447 # If there is no device or directory syntax on $base, make sure it 448 # is treated as a directory. 449 $base = vmspath($base) unless $base =~ m{(?<!\^)[\[<:]}; 450 451 for ($path, $base) { $_ = $self->rel2abs($_) } 452 453 # Are we even starting $path on the same (node::)device as $base? Note that 454 # logical paths or nodename differences may be on the "same device" 455 # but the comparison that ignores device differences so as to concatenate 456 # [---] up directory specs is not even a good idea in cases where there is 457 # a logical path difference between $path and $base nodename and/or device. 458 # Hence we fall back to returning the absolute $path spec 459 # if there is a case blind device (or node) difference of any sort 460 # and we do not even try to call $parse() or consult %ENV for $trnlnm() 461 # (this module needs to run on non VMS platforms after all). 462 463 my ($path_volume, $path_directories, $path_file) = $self->splitpath($path); 464 my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); 465 return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume); 466 467 # Now, remove all leading components that are the same 468 my @pathchunks = $self->splitdir( $path_directories ); 469 my $pathchunks = @pathchunks; 470 unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; 471 my @basechunks = $self->splitdir( $base_directories ); 472 my $basechunks = @basechunks; 473 unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; 474 475 while ( @pathchunks && 476 @basechunks && 477 lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 478 ) { 479 shift @pathchunks ; 480 shift @basechunks ; 481 } 482 483 # @basechunks now contains the directories to climb out of, 484 # @pathchunks now has the directories to descend in to. 485 if ((@basechunks > 0) || ($basechunks != $pathchunks)) { 486 $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; 487 } 488 else { 489 $path_directories = join '.', @pathchunks; 490 } 491 $path_directories = '['.$path_directories.']'; 492 return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; 493} 494 495 496=item rel2abs (override) 497 498Return an absolute file specification from a relative one. 499 500=cut 501 502sub rel2abs { 503 my $self = shift ; 504 my ($path,$base ) = @_; 505 return undef unless defined $path; 506 if ($path =~ m/\//) { 507 $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about 508 ? vmspath($path) # whether it's a directory 509 : vmsify($path) ); 510 } 511 $base = vmspath($base) if defined $base && $base =~ m/\//; 512 513 # Clean up and split up $path 514 if ( ! $self->file_name_is_absolute( $path ) ) { 515 # Figure out the effective $base and clean it up. 516 if ( !defined( $base ) || $base eq '' ) { 517 $base = Cwd::getcwd(); 518 } 519 elsif ( ! $self->file_name_is_absolute( $base ) ) { 520 $base = $self->rel2abs( $base ) ; 521 } 522 else { 523 $base = $self->canonpath( $base ) ; 524 } 525 526 # Split up paths 527 my ( $path_directories, $path_file ) = 528 ($self->splitpath( $path ))[1,2] ; 529 530 my ( $base_volume, $base_directories ) = 531 $self->splitpath( $base ) ; 532 533 $path_directories = '' if $path_directories eq '[]' || 534 $path_directories eq '<>'; 535 my $sep = '' ; 536 $sep = '.' 537 if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && 538 $path_directories =~ m{^[^.\[<]}s 539 ) ; 540 $base_directories = "$base_directories$sep$path_directories"; 541 $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; 542 543 $path = $self->catpath( $base_volume, $base_directories, $path_file ); 544 } 545 546 return $self->canonpath( $path ) ; 547} 548 549 550=back 551 552=head1 COPYRIGHT 553 554Copyright (c) 2004-14 by the Perl 5 Porters. All rights reserved. 555 556This program is free software; you can redistribute it and/or modify 557it under the same terms as Perl itself. 558 559=head1 SEE ALSO 560 561See L<File::Spec> and L<File::Spec::Unix>. This package overrides the 562implementation of these methods, not the semantics. 563 564An explanation of VMS file specs can be found at 565L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>. 566 567=cut 568 5691; 570