diff options
| -rw-r--r-- | lib/File/Spec/OS2.pm | 4 | ||||
| -rw-r--r-- | lib/File/Spec/Unix.pm | 49 | ||||
| -rw-r--r-- | lib/File/Spec/VMS.pm | 95 | ||||
| -rw-r--r-- | lib/File/Spec/Win32.pm | 4 | ||||
| -rw-r--r-- | vms/vms.c | 14 |
5 files changed, 140 insertions, 26 deletions
diff --git a/lib/File/Spec/OS2.pm b/lib/File/Spec/OS2.pm index 985c411a79..07fc867d01 100644 --- a/lib/File/Spec/OS2.pm +++ b/lib/File/Spec/OS2.pm @@ -9,6 +9,10 @@ sub devnull { return "/dev/nul"; } +sub case_tolerant { + return 1; +} + sub file_name_is_absolute { my ($self,$file) = @_; return scalar($file =~ m{^([a-z]:)?[\\/]}i); diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index d47a60e9cc..db49bb03d9 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -149,6 +149,17 @@ sub no_upwards { return grep(!/^\.{1,2}$/, @_); } +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +is not or is significant when comparing file specifications. + +=cut + +sub case_tolerant { + return 0; +} + =item file_name_is_absolute Takes as argument a path and returns true, if it is an absolute path. @@ -341,29 +352,35 @@ sub abs2rel { } # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path); - my @basechunks = $self->splitdir( $base); - - while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { + my @pathchunks = $self->splitpath( $path ); + my @basechunks = ($self->splitpath( $base, 1 ))[0,1]; + + # Insure same device; case-insensitive since those filesystems + # which use device semantics (VMS and Win32) are case-tolerant + return undef unless lc($pathchunks[0]) eq lc($basechunks[0]); + $path = $pathchunks[0] || ''; + @pathchunks = ( $self->splitdir( $pathchunks[1] ), $pathchunks[2] ); + @basechunks = $self->splitdir( $basechunks[1] ); + + # We do case-insensitive comparisons rather than just flattening case + # so caller gets back same case as was sent in + my $lc = $self->case_tolerant; + while (@pathchunks && @basechunks && + ($lc ? lc($pathchunks[0]) eq lc($basechunks[0]) + : $pathchunks[0] eq $basechunks[0] ) ) { shift @pathchunks ; shift @basechunks ; } - $path = CORE::join( '/', @pathchunks ); - $base = CORE::join( '/', @basechunks ); - - # $base now contains the directories the resulting relative path + # @basechunks now contains the directories the resulting relative path # must ascend out of before it can descend to $path_directory. So, # replace all names with $parentDir - $base =~ s|[^/]+|..|g ; + @basechunks = ($self->updir()) x @basechunks; # Glue the two together, using a separator if necessary, and preventing an # empty result. - if ( $path ne '' && $base ne '' ) { - $path = "$base/$path" ; - } else { - $path = "$base$path" ; - } + $path = $self->catfile($path,@basechunks,@pathchunks); + $path = $self->curdir unless $path; return $self->canonpath( $path ) ; } @@ -411,7 +428,9 @@ sub rel2abs($;$;) { } # Glom them together - $path = $self->catdir( $base, $path ) ; + my($pdev,$pdir,$pfile) = $self->splitpath( $path ); + my($bdev,$bdir,$bfile) = $self->splitpath( $base ); + $path = $self->catpath( $bdev, $self->catdir( $bdir, $pdir ), $pfile ); } return $self->canonpath( $path ) ; diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index 71c38f222f..54a5f1a0d9 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -108,8 +108,14 @@ sub fixpath { if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { $fixedpath = vmspath($fixedpath) if -d $fixedpath; } + # Trim off root dirname if it's had other dirs inserted in front of it. $fixedpath =~ s/\.000000([\]>])/$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 ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } $fixedpath; } @@ -119,10 +125,35 @@ sub fixpath { =over +=item canonpath (override) + +Removes redundant portions of file specifications according to VMS syntax + +=cut + +sub canonpath { + my($self,$path,$reduce_ricochet) = @_; + + if ($path =~ m|/|) { # Fake Unix + my $pathify = $path =~ m|/$|; + $path = $self->SUPER::canonpath($path,$reduce_ricochet); + if ($pathify) { return vmspath($path); } + else { return vmsify($path); } + } + else { + $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar + $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo + $path =~ s/[\[<\.]([^\[<\.]+)\.-\.\1//g; # bar.foo.-.foo ==> bar. + if ($reduce_ricochet) { $path =~ s/[^\[\-<.]+\.\-//g; } + return $path; + } +} + =item catdir Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +VMS-syntax directory specification. No check is made for "impossible" +cases (e.g. elements other than the first being absolute filespecs). =cut @@ -137,6 +168,12 @@ sub catdir { $spath =~ s/.dir$//; $sdir =~ s/.dir$//; $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; $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 =~ /^[\[<][^.\-]/) { $rslt =~ s/^[^\[<]+//; } } else { if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } @@ -148,7 +185,7 @@ sub catdir { =item catfile Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +VMS-syntax file specification. =cut @@ -173,6 +210,7 @@ sub catfile { return $rslt; } + =item curdir (override) Returns a string representation of the current directory: '[]' @@ -235,6 +273,16 @@ sub updir { return '[-]'; } +=item case_tolerant (override) + +VMS file specification syntax is case-tolerant. + +=cut + +sub case_tolerant { + return 1; +} + =item path (override) Translate logical name DCL$PATH as a searchlist, rather than trying @@ -263,6 +311,49 @@ sub file_name_is_absolute { $file =~ /:[^<\[]/); } +=item splitpath (override) + +Splits using VMS syntax. + +=cut + +sub splitpath { + my($self,$path) = @_; + my($dev,$dir,$file) = ('','',''); + + vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/; + return ($1 || '',$2 || '',$3); +} + +=item splitdir (override) + +Split dirspec using VMS syntax. + +=cut + +sub splitdir { + my($self,$dirspec) = @_; + $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; + my(@dirs) = split('\.', vmspath($dirspec)); + $dirs[0] =~ s/^[\[<]//; $dirs[-1] =~ s/[\]>]$//; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec using VMS syntax + +=cut + +sub catpath { + my($self,$dev,$dir,$file) = @_; + if ($dev =~ m|^/+([^/]+)|) { $dev =~ "$1:"; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:$/; } + $dir = vmspath($dir); + "$dev$dir$file"; +} + =item splitpath ($volume,$directories,$file) = File::Spec->splitpath( $path ); diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index f1c6ccf8c7..6ee2f3b1d7 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -59,6 +59,10 @@ sub tmpdir { return $tmpdir; } +sub case_tolerant { + return 1; +} + sub file_name_is_absolute { my ($self,$file) = @_; return scalar($file =~ m{^([a-z]:)?[\\/]}i); @@ -2117,16 +2117,12 @@ 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')) { - if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ + else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */ + if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; else if (*(cp1-2) == '[') *(cp1-1) = '-'; - else { /* back up over previous directory name */ - cp1--; - while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--; - if (*(cp1-1) == '[') { - memcpy(cp1,"000000.",7); - cp1 += 7; - } + else { +/* if (*(cp1-1) != '.') *(cp1++) = '.'; */ + *(cp1++) = '-'; } cp2 += 2; if (cp2 == dirend) break; |