From: Charles Bailey Date: Mon, 13 Mar 2000 02:22:24 +0000 (+0000) Subject: Update File::Spec::VMS and tests X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fd7385b97d6c0b537b272f194ad6f88a70d3dd39;p=p5sagit%2Fp5-mst-13.2.git Update File::Spec::VMS and tests Since reduce_ricochet has been removed from File::Spec, revert changes to VMS::Filespec::vmsify made to accomodate it. p4raw-id: //depot/vmsperl@5689 --- diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index aecaada..28c1050 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -128,26 +128,27 @@ sub fixpath { =item canonpath (override) -Removes redundant portions of file specifications according to VMS syntax +Removes redundant portions of file specifications according to VMS syntax. =cut sub canonpath { - my($self,$path,$reduce_ricochet) = @_; + my($self,$path) = @_; if ($path =~ m|/|) { # Fake Unix my $pathify = $path =~ m|/\z|; - $path = $self->SUPER::canonpath($path,$reduce_ricochet); + $path = $self->SUPER::canonpath($path); if ($pathify) { return vmspath($path); } else { return vmsify($path); } } else { - $path =~ s-\]\[--g; $path =~ s/> foo.bar - $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo - if ($reduce_ricochet) { - $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/g; - $path =~ s/([\[<\.])([^\[<\.]+)\.-\.?/$1/g; - } + $path =~ s-\]\[--g; $path =~ s/> foo.bar + $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo + 1 while $path =~ s{-\.-}{--}; # -.- ==> -- + $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar] + $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s + $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo + $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode return $path; } } @@ -172,15 +173,16 @@ sub catdir { $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/s; $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - # Special case for VMS absolute directory specs: these will have had device - # prepended during trip through Unix syntax in eliminate_macros(), since - # Unix syntax has no way to express "absolute from the top of this device's - # directory tree". - if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } } else { - if ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + if (not defined $dir or not length $dir) { $rslt = ''; } + elsif ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; } + else { $rslt = vmspath($dir); } } return $rslt; } @@ -209,7 +211,7 @@ sub catfile { $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); } } - else { $rslt = vmsify($file); } + else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } return $rslt; } @@ -249,7 +251,7 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: - /sys$scratch + sys$scratch $ENV{TMPDIR} =cut @@ -257,7 +259,7 @@ from the following list or '' if none are writable: my $tmpdir; sub tmpdir { return $tmpdir if defined $tmpdir; - foreach ('/sys$scratch', $ENV{TMPDIR}) { + foreach ('sys$scratch', $ENV{TMPDIR}) { next unless defined && -d && -w _; $tmpdir = $_; last; @@ -337,6 +339,7 @@ Split dirspec using VMS syntax. sub splitdir { my($self,$dirspec) = @_; $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; + $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal my(@dirs) = split('\.', vmspath($dirspec)); $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\z//s; @dirs; @@ -351,127 +354,25 @@ Construct a complete filespec using VMS syntax sub catpath { my($self,$dev,$dir,$file) = @_; - if ($dev =~ m|^/+([^/]+)|) { $dev =~ "$1:"; } + if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; } - $dir = vmspath($dir); - "$dev$dir$file"; -} - -=item splitpath - - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); - -Splits a VMS path in to volume, directory, and filename portions. -Ignores $no_file, if present, since VMS paths indicate the 'fileness' of a -file. - -The results can be passed to L to get back a path equivalent to -(usually identical to) the original path. - -=cut - -sub splitpath { - my $self = shift ; - my ($path, $nofile) = @_; - - my ($volume,$directory,$file) ; - - if ( $path =~ m{/} ) { - $path =~ - m{^ ( (?: /[^/]* )? ) - ( (?: .*/(?:[^/]+\.dir)? )? ) - (.*) - }xs; - $volume = $1; - $directory = $2; - $file = $3; + if (length($dev) or length($dir)) { + $dir = "[$dir]" unless $dir =~ /[\[<\/]/; + $dir = vmspath($dir); } - else { - $path =~ - m{^ ( (?: (?: (?: [\w\$-]+ (?: "[^"]*")?:: )? [\w\$-]+: )? ) ) - ( (?:\[.*\])? ) - (.*) - }xs; - $volume = $1; - $directory = $2; - $file = $3; - } - - $directory = $1 - if $directory =~ /^\[(.*)\]\z/s ; - - return ($volume,$directory,$file); + "$dev$dir$file"; } +=item abs2rel (override) -=item splitdir - -The opposite of L. - - @dirs = File::Spec->splitdir( $directories ); - -$directories must be only the directory portion of the path. - -'[' and ']' delimiters are optional. An empty string argument is -equivalent to '[]': both return an array with no elements. +Use VMS syntax when converting filespecs. =cut -sub splitdir { - my $self = shift ; - my $directories = $_[0] ; - - return File::Spec::Unix::splitdir( $self, @_ ) - if ( $directories =~ m{/} ) ; - - $directories =~ s/^\[(.*)\]\z/$1/s ; - - # - # split() likes to forget about trailing null fields, so here we - # check to be sure that there will not be any before handling the - # simple case. - # - if ( $directories !~ m{\.\z} ) { - return split( m{\.}, $directories ); - } - else { - # - # since there was a trailing separator, add a file name to the end, - # then do the split, then replace it with ''. - # - my( @directories )= split( m{\.}, "${directories}dummy" ) ; - $directories[ $#directories ]= '' ; - return @directories ; - } -} - - -sub catpath { - my $self = shift; - - return File::Spec::Unix::catpath( $self, @_ ) - if ( join( '', @_ ) =~ m{/} ) ; - - my ($volume,$directory,$file) = @_; - - $volume .= ':' - if $volume =~ /[^:]\z/ ; - - $directory = "[$directory" - if $directory =~ /^[^\[]/s ; - - $directory .= ']' - if $directory =~ /[^\]]\z/ ; - - return "$volume$directory$file" ; -} - - sub abs2rel { my $self = shift; - return File::Spec::Unix::abs2rel( $self, @_ ) + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) if ( join( '', @_ ) =~ m{/} ) ; my($path,$base) = @_; @@ -527,13 +428,19 @@ sub abs2rel { # @pathchunks now has the directories to descend in to. $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ; $path_directories =~ s{\.\z}{} ; - return $self->catpath( '', $path_directories, $path_file ) ; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; } +=item rel2abs (override) + +Use VMS syntax when converting filespecs. + +=cut + sub rel2abs($;$;) { my $self = shift ; - return File::Spec::Unix::rel2abs( $self, @_ ) + return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) if ( join( '', @_ ) =~ m{/} ) ; my ($path,$base ) = @_; @@ -557,12 +464,15 @@ sub rel2abs($;$;) { my ( $base_volume, $base_directories, undef ) = $self->splitpath( $base ) ; + $path_directories = '' if $path_directories eq '[]' || + $path_directories eq '<>'; my $sep = '' ; $sep = '.' - if ( $base_directories =~ m{[^.]\z} && - $path_directories =~ m{^[^.]}s + if ( $base_directories =~ m{[^.\]>]\z} && + $path_directories =~ m{^[^.\[<]}s ) ; - $base_directories = "$base_directories$sep$path_directories" ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; $path = $self->catpath( $base_volume, $base_directories, $path_file ); } diff --git a/t/lib/filespec.t b/t/lib/filespec.t index 0e4c131..3d2952c 100755 --- a/t/lib/filespec.t +++ b/t/lib/filespec.t @@ -181,24 +181,24 @@ BEGIN { [ "Win32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work\\..' ], [ "VMS->splitpath('file')", ',,file' ], -[ "VMS->splitpath('[d1.d2.d3]')", ',d1.d2.d3,' ], -[ "VMS->splitpath('[.d1.d2.d3]')", ',.d1.d2.d3,' ], -[ "VMS->splitpath('[d1.d2.d3]file')", ',d1.d2.d3,file' ], -[ "VMS->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], -[ "VMS->splitpath('/d1/d2/d3/file')", '/d1,/d2/d3/,file' ], -[ "VMS->splitpath('[.d1.d2.d3]file')", ',.d1.d2.d3,file' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,d1.d2.d3,' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,d1.d2.d3,file' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,d1.d2.d3,' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,d1.d2.d3,file' ], +[ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], +[ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], +[ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], +[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], +[ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], [ "VMS->catpath('','','file')", 'file' ], [ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], [ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], [ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], [ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('','d1/d2/d3','file')", 'd1/d2/d3/file' ], -[ "VMS->catpath('v','d1/d2/d3','file')", 'd1/d2/d3/file' ], +[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], +[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], [ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], [ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], [ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ], @@ -206,8 +206,7 @@ BEGIN { [ "VMS->canonpath('')", '' ], [ "VMS->canonpath('volume:[d1]file')", 'volume:[d1]file' ], -[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d1.-.d2.d3.d4.-]' ], -[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]',1)", 'volume:[d2.d3]' ], +[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d2.d3]' ], [ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", 'volume:[d1]d2.dir;1' ], [ "VMS->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], @@ -220,17 +219,15 @@ BEGIN { [ "VMS->splitdir('.-.d2.d3')", ',-,d2,d3' ], [ "VMS->splitdir('[.-.d2.d3]')", ',-,d2,d3' ], -#[ "VMS->catdir('')", '[]' ], +[ "VMS->catdir('')", '' ], [ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], [ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], [ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], [ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], [ "VMS->catdir('','-','','d3')", '[-.d3]' ], -#[ "VMS->catdir('[]','<->','[]','[d3]')", '[-.d3]' ], [ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], [ "VMS->catdir('[.name]')", '[.name]' ], [ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], -#[ "VMS->catdir('a:[.name]','b:[.name]')", '[.name.name]'], [ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", '' ], [ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], @@ -239,19 +236,16 @@ BEGIN { [ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], [ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ], [ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ], -[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[-.-.-.t4.t5.t6]' ], -#[ "VMS->abs2rel('[]','[t1.t2.t3]')", '[-.-.-]' ], -#[ "VMS->abs2rel('[..]','[t1.t2.t3]')", '[-.-.-]' ], -#[ "VMS->abs2rel('[.]','[t1.t2.t3]')", '[-.-.-]' ], -#[ "VMS->abs2rel('[..]','[t1.t2.t3]')", '[-.-.-]' ], -#[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -#[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[-.-.-.b]' ], +[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ], +[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---.000000]' ], +[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], +[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[---.b]' ], [ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", '[t1.t2.t3.t4]' ], [ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", '[t1.t2.t3.t4.t5]' ], [ "VMS->rel2abs('[]','[t1.t2.t3]')", '[t1.t2.t3]' ], -[ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2.t3.-]' ], -[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t3.-.t4]' ], +[ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2]' ], +[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t4]' ], [ "VMS->rel2abs('[t1]','[t1.t2.t3]')", '[t1]' ], [ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 31c476a..779396b 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -86,7 +86,7 @@ some:[where.over]the.rainbow unixify /some/where/over/the.rainbow /some/where/over/the.rainbow vmsify some:[where.over]the.rainbow some/where/over/the.rainbow vmsify [.some.where.over]the.rainbow ../some/where/over/the.rainbow vmsify [-.some.where.over]the.rainbow -some/../../where/over/the.rainbow vmsify [.some.--.where.over]the.rainbow +some/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow .../some/where/over/the.rainbow vmsify [...some.where.over]the.rainbow some/.../where/over/the.rainbow vmsify [.some...where.over]the.rainbow /some/.../where/over/the.rainbow vmsify some:[...where.over]the.rainbow @@ -139,7 +139,7 @@ path vmspath [.path] / vmspath sys$disk:[000000] # Redundant characters in Unix paths -//some/where//over/../the.rainbow vmsify some:[where.over.-]the.rainbow +//some/where//over/../the.rainbow vmsify some:[where]the.rainbow /some/where//over/./the.rainbow vmsify some:[where.over]the.rainbow ..//../ vmspath [--] ./././ vmspath [] diff --git a/vms/vms.c b/vms/vms.c index e465bfc..f7edca7 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -103,7 +103,7 @@ int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) { - char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; + char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure; unsigned long int retsts, attr = LNM$M_CASE_BLIND; unsigned char acmode; @@ -138,6 +138,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, } lnmdsc.dsc$w_length = cp1 - lnm; lnmdsc.dsc$a_pointer = uplnm; + uplnm[lnmdsc.dsc$w_length] = '\0'; secure = flags & PERL__TRNENV_SECURE; acmode = secure ? PSL$C_EXEC : PSL$C_USER; if (!tabvec || !*tabvec) tabvec = env_tables; @@ -207,6 +208,19 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst); if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; } if (retsts == SS$_NOLOGNAM) continue; + /* PPFs have a prefix */ + if ( +#if INTSIZE == 4 + *((int *)uplnm) == *((int *)"SYS$") && +#endif + eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 && + ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) || + (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) || + (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) || + (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) { + memcpy(eqv,eqv+4,eqvlen-4); + eqvlen -= 4; + } break; } } @@ -2160,12 +2174,16 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { else if (!infront && *cp2 == '.') { if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; } else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ - else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */ - if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; + else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { + if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ else if (*(cp1-2) == '[') *(cp1-1) = '-'; - else { -/* if (*(cp1-1) != '.') *(cp1++) = '.'; */ - *(cp1++) = '-'; + else { /* back up over previous directory name */ + cp1--; + while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--; + if (*(cp1-1) == '[') { + memcpy(cp1,"000000.",7); + cp1 += 7; + } } cp2 += 2; if (cp2 == dirend) break;