return "/dev/nul";
}
+sub case_tolerant {
+ return 1;
+}
+
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m{^([a-z]:)?[\\/]}i);
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.
}
# 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 ) ;
}
}
# 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 ) ;
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;
}
=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
$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; }
=item catfile
Concatenates a list of file specifications, and returns the result as a
-VMS-syntax directory specification.
+VMS-syntax file specification.
=cut
return $rslt;
}
+
=item curdir (override)
Returns a string representation of the current directory: '[]'
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
$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 );
return $tmpdir;
}
+sub case_tolerant {
+ return 1;
+}
+
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m{^([a-z]:)?[\\/]}i);
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff