Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

implement canonpath(:parent) for Win32, rm os-dependent '...' -> '../..'

this removes support for '...' double-parent on Symbian and NetWare,
both of which are no longer being updated by the OS owners.
  • Loading branch information...
commit 9ece8b45e4bbecb22d5954a6b011479c7b26655f 1 parent 25e2f6b
@labster labster authored
Showing with 18 additions and 25 deletions.
  1. +18 −25 src/core/IO/Spec/Win32.pm
View
43 src/core/IO/Spec/Win32.pm
@@ -7,13 +7,16 @@ my class IO::Spec::Win32 is IO::Spec::Unix {
my $UNCpath = regex { [<$slash> ** 2] <$notslash>+ <$slash> [<$notslash>+ | $] }
my $volume_rx = regex { <$driveletter> | <$UNCpath> }
- method canonpath ($path) { $path.chars ?? self!canon-cat($path) !! '' }
+ method canonpath ($path, :$parent) {
+ $path.chars ?? self!canon-cat($path, :$parent) !! '';
+ }
method catdir(*@dirs) {
return "" unless @dirs;
return self!canon-cat( "\\", |@dirs ) if @dirs[0] eq "";
self!canon-cat(|@dirs);
}
+
method splitdir($dir) { $dir.split($slash) }
method catfile(|c) { self.catdir(|c) }
method devnull { 'nul' }
@@ -163,17 +166,15 @@ my class IO::Spec::Win32 is IO::Spec::Unix {
}
- method !canon-cat ( $first is copy, *@rest ) {
+ method !canon-cat ( $first, *@rest, :$parent --> Str) {
- my $volumematch =
- $first ~~ /^ ([ <$driveletter> <$slash>?
- | <$UNCpath>
- | [<$slash> ** 2] <$notslash>+
- | <$slash> ]?)
- (.*)
- /;
- my $volume = ~$volumematch[0];
- $first = ~$volumematch[1];
+ $first ~~ /^ ([ <$driveletter> <$slash>?
+ | <$UNCpath>
+ | [<$slash> ** 2] <$notslash>+
+ | <$slash> ]?)
+ (.*)
+ /;
+ my Str ($volume, $path) = ~$0, ~$1;
$volume.=subst(:g, '/', '\\');
if $volume ~~ /^<$driveletter>/ {
@@ -183,23 +184,15 @@ my class IO::Spec::Win32 is IO::Spec::Unix {
$volume ~= '\\';
}
- my $path = join "\\", $first, @rest.flat;
-
- $path ~~ s:g/ <$slash>+ /\\/; #:: xx/yy --> xx\yy & xx\\yy --> xx\yy
-
- $path ~~ s:g/[ ^ | '\\'] '.' '\\.'* [ '\\' | $ ]/\\/; #:: xx/././yy --> xx/yy
-
- if $*OS eq "symbian"|"NetWare" {
- # ... -> ../.. -- unknown if .... or higher is supported
- $path ~~ s:g/ <?after ^ | '\\'> '...' <?before '\\' | $ > /..\\../; #::
+ $path = join "\\", $path, @rest.flat;
+ $path ~~ s:g/ <$slash>+ /\\/; # /xx\\yy --> \xx\yy
+ $path ~~ s:g/[ ^ | '\\'] '.' '\\.'* [ '\\' | $ ]/\\/; # xx/././yy --> xx/yy
+ if $parent {
+ while $path ~~ s:g { [^ | <?after '\\'>] <!before '..\\'> <-[\\]>+ '\\..' ['\\' | $ ] } = '' { };
}
-
$path ~~ s/^ '\\'+ //; # \xx --> xx NOTE: this is *not* root
$path ~~ s/ '\\'+ $//; # xx\ --> xx
-
-
- if ( $volume ~~ / '\\' $ / ) {
- # <vol>\.. --> <vol>\
+ if $volume ~~ / '\\' $ / { # <vol>\.. --> <vol>\
$path ~~ s/ ^ '..' '\\..'* [ '\\' | $ ] //;
}
Please sign in to comment.
Something went wrong with that request. Please try again.