io.pathnames: fix separator when appending paths in windows

Includes updated tests

diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor
index 8f90de142e9ccc1f8aac4d32c68c19442f6c0dfc..3a3989043fd327f9fe02d0f492ef5492028afcda 100644 (file)
--- a/core/io/pathnames/pathnames-tests.factor
+++ b/core/io/pathnames/pathnames-tests.factor
@@ -10,45 +10,95 @@ namespaces sequences system tools.test ;
 { "freetype6.dll" } [ "resource:freetype6.dll" file-name ] unit-test
 { "freetype6.dll" } [ "resource:/freetype6.dll" file-name ] unit-test
 
-{ "/usr/lib" } [ "/usr" "lib" append-path ] unit-test
-{ "/usr/lib" } [ "/usr/" "lib" append-path ] unit-test
-{ "/usr/lib" } [ "/usr" "./lib" append-path ] unit-test
-{ "/usr/lib/" } [ "/usr" "./lib/" append-path ] unit-test
-{ "/lib" } [ "/usr" "../lib" append-path ] unit-test
-{ "/lib/" } [ "/usr" "../lib/" append-path ] unit-test
+os windows?
+    [
+        { "C:\\usr\\lib" } [ "C:\\usr" "lib" append-path ] unit-test
+        { "C:\\usr\\lib" } [ "C:\\usr\\" "lib" append-path ] unit-test
+        { "C:\\usr\\lib" } [ "C:\\usr" ".\\lib" append-path ] unit-test
+        { "C:\\usr\\lib\\" } [ "C:\\usr" ".\\lib\\" append-path ] unit-test
+        { "C:\\lib" } [ "C:\\usr" "..\\lib" append-path ] unit-test
+        { "C:\\lib\\" } [ "C:\\usr" "..\\lib\\" append-path ] unit-test
+    ]
+    [
+        { "/usr/lib" } [ "/usr" "lib" append-path ] unit-test
+        { "/usr/lib" } [ "/usr/" "lib" append-path ] unit-test
+        { "/usr/lib" } [ "/usr" "./lib" append-path ] unit-test
+        { "/usr/lib/" } [ "/usr" "./lib/" append-path ] unit-test
+        { "/lib" } [ "/usr" "../lib" append-path ] unit-test
+        { "/lib/" } [ "/usr" "../lib/" append-path ] unit-test
+    ]
+    if
 
 { "" } [ "" "." append-path ] unit-test
 [ "" ".." append-path ] must-fail
 
-{ "/" } [ "/" "./." append-path ] unit-test
-{ "/" } [ "/" "././" append-path ] unit-test
-{ "/a/b/lib" } [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
-{ "/a/b/lib/" } [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test
+os windows?
+    [
+        { "C:\\" } [ "C:\\" ".\\." append-path ] unit-test
+        { "C:\\" } [ "C:\\" ".\\.\\" append-path ] unit-test
+        { "C:\\a\\b\\lib" } [ "C:\\a\\b\\c\\d\\e\\f\\" "..\\..\\..\\..\\lib" append-path ] unit-test
+        { "C:\\a\\b\\lib\\" } [ "C:\\a\\b\\c\\d\\e\\f\\" "..\\..\\..\\..\\lib\\" append-path ] unit-test
+    ]
+    [
+        { "/" } [ "/" "./." append-path ] unit-test
+        { "/" } [ "/" "././" append-path ] unit-test
+        { "/a/b/lib" } [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
+        { "/a/b/lib/" } [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test
+    ]
+    if
 
 [ "" "../lib/" append-path ] must-fail
 { "lib" } [ "" "lib" append-path ] unit-test
 { "lib" } [ "" "./lib" append-path ] unit-test
 
-[ "foo/bar/." parent-directory ] must-fail
-[ "foo/bar/./" parent-directory ] must-fail
-[ "foo/bar/baz/.." parent-directory ] must-fail
-[ "foo/bar/baz/../" parent-directory ] must-fail
-
-[ "." parent-directory ] must-fail
-[ "./" parent-directory ] must-fail
-[ ".." parent-directory ] must-fail
-[ "../" parent-directory ] must-fail
-[ "../../" parent-directory ] must-fail
-[ "foo/.." parent-directory ] must-fail
-[ "foo/../" parent-directory ] must-fail
-[ "" parent-directory ] must-fail
-{ "." } [ "boot.x86.64.image" parent-directory ] unit-test
+os windows?
+    [
+        [ "    \\bar\\." parent-directory ] must-fail
+        [ "    \\bar\\.\\" parent-directory ] must-fail
+        [ "    \\bar\\baz\\.." parent-directory ] must-fail
+        [ "    \\bar\\baz\\..\\" parent-directory ] must-fail
+        [ "." parent-directory ] must-fail
+        [ ".\\" parent-directory ] must-fail
+        [ ".." parent-directory ] must-fail
+        [ "..\\" parent-directory ] must-fail
+        [ "..\\..\\" parent-directory ] must-fail
+        [ "    \\.." parent-directory ] must-fail
+        [ "    \\..\\" parent-directory ] must-fail
+        [ "" parent-directory ] must-fail
+    ]
+    [
+        [ "    /bar/." parent-directory ] must-fail
+        [ "    /bar/./" parent-directory ] must-fail
+        [ "    /bar/baz/.." parent-directory ] must-fail
+        [ "    /bar/baz/../" parent-directory ] must-fail
+        [ "." parent-directory ] must-fail
+        [ "./" parent-directory ] must-fail
+        [ ".." parent-directory ] must-fail
+        [ "../" parent-directory ] must-fail
+        [ "../../" parent-directory ] must-fail
+        [ "    /.." parent-directory ] must-fail
+        [ "    /../" parent-directory ] must-fail
+        [ "" parent-directory ] must-fail
+    ]
+    if
 
-{ "bar/foo" } [ "bar/baz" "..///foo" append-path ] unit-test
-{ "bar/baz/foo" } [ "bar/baz" ".///foo" append-path ] unit-test
-{ "bar/foo" } [ "bar/baz" "./..//foo" append-path ] unit-test
-{ "bar/foo" } [ "bar/baz" "./../././././././///foo" append-path ] unit-test
+{ "." } [ "boot.x86.64.image" parent-directory ] unit-test
 
+os windows?
+    [
+        { "bar\\    " } [ "bar\\baz" "..\\\\\\    " append-path ] unit-test
+        { "bar\\baz\\    " } [ "bar\\baz" ".\\\\\\    " append-path ] unit-test
+        { "bar\\    " } [ "bar\\baz" ".\\..\\\\    " append-path ] unit-test
+        { "bar\\    " } [ "bar\\baz" ".\\..\\.\\.\\.\\.\\.\\.\\\\\\\\    " append-path ] unit-test
+    ]
+    [
+        { "bar/    " } [ "bar/baz" "..///    " append-path ] unit-test
+        { "bar/baz/    " } [ "bar/baz" ".///    " append-path ] unit-test
+        { "bar/    " } [ "bar/baz" "./..//    " append-path ] unit-test
+        { "bar/    " } [ "bar/baz" "./../././././././///    " append-path ] unit-test
+    ]
+    if
+    
 { t } [ "resource:core" absolute-path? ] unit-test
 { f } [ "" absolute-path? ] unit-test
 
@@ -61,8 +111,8 @@ H{
     { current-directory "." }
     { "resource-path" ".." }
 } [
-    [ "../core/bootstrap/stage2.factor" ]
-    [ "resource:core/bootstrap/stage2.factor" absolute-path ]
+    [ "..\\core\\bootstrap\\stage2.factor" ]
+    [ "resource:core\\bootstrap\\stage2.factor" absolute-path ]
     unit-test
 ] with-variables
 
@@ -157,4 +207,4 @@ os windows? [
     { "/" } [ "/Users/foo/bar////././." root-path ] unit-test
     { "/" } [ "/Users/foo/bar////.//../../../../../../////./." root-path ] unit-test
     { "/" } [ "/Users/////" root-path ] unit-test
-] if
\ No newline at end of file
+] if

diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor
index b54b207bca2ed5098c94d4336a84426766525f0a..97601d077cdbf314a5f89fb480281cd5bda0b35b 100644 (file)
--- a/core/io/pathnames/pathnames.factor
+++ b/core/io/pathnames/pathnames.factor
@@ -89,7 +89,7 @@ PRIVATE>
 
 : append-relative-path ( path1 path2 -- path )
     [ trim-tail-separators ]
-    [ trim-head-separators ] bi* "/" glue ;
+    [ trim-head-separators ] bi* path-separator glue ;
 
 : append-path ( path1 path2 -- path )
     {