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