redo path handling

core/io/files/files-tests.factor

@@ -9,6 +9,9 @@ io.files.unique sequences strings accessors ;
 [ "passwd" ] [ "/etc/passwd" file-name ] unit-test
 [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
 [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
+[ "" ] [ "" file-name ] unit-test
+[ "/" ] [ "/" file-name ] unit-test
+[ "///" ] [ "///" file-name ] unit-test
 
 [ ] [
     { "Hello world." }
@@ -144,3 +147,51 @@ io.files.unique sequences strings accessors ;
         ] keep file-info size>>
     ] with-unique-file
 ] 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
+[ "/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
+[ "/lib" ] [ "/" "../lib" append-path ] unit-test
+[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
+
+[ "" ] [ "" "." append-path ] unit-test
+[ "" ".." append-path ] must-fail
+
+[ "/" ] [ "/" "./." append-path ] unit-test
+[ "/" ] [ "/" "././" append-path ] unit-test
+[ "/" ] [ "/" "../.." append-path ] unit-test
+[ "/" ] [ "/" "../../" append-path ] unit-test
+[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
+[ "/lib/" ] [ "/" "../../lib/" 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
+
+[ "" "../lib/" append-path ] must-fail
+[ "lib" ] [ "" "lib" append-path ] unit-test
+[ "lib" ] [ "" "./lib" append-path ] unit-test
+
+[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
+[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
+
+[ "foo/" ] [ "foo/bar/." parent-directory ] unit-test
+[ "foo/" ] [ "foo/bar/./" parent-directory ] unit-test
+[ "foo/" ] [ "foo/bar/baz/.." parent-directory ] unit-test
+[ "foo/" ] [ "foo/bar/baz/../" parent-directory ] unit-test
+
+[ "." 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
+
+[ "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

core/io/files/files.factor

@@ -3,7 +3,7 @@
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
 system combinators splitting sbufs continuations io.encodings
-io.encodings.binary ;
+io.encodings.binary init ;
 IN: io.files
 
 HOOK: (file-reader) io-backend ( path -- stream )
@@ -21,7 +21,26 @@ HOOK: (file-appender) io-backend ( path -- stream )
 : <file-appender> ( path encoding -- stream )
     swap (file-appender) swap <encoder> ;
 
-HOOK: rename-file io-backend ( from to -- )
+: file-lines ( path encoding -- seq )
+    <file-reader> lines ;
+
+: with-file-reader ( path encoding quot -- )
+    >r <file-reader> r> with-stream ; inline
+
+: file-contents ( path encoding -- str )
+    <file-reader> contents ;
+
+: with-file-writer ( path encoding quot -- )
+    >r <file-writer> r> with-stream ; inline
+
+: set-file-lines ( seq path encoding -- )
+    [ [ print ] each ] with-file-writer ;
+
+: set-file-contents ( str path encoding -- )
+    [ write ] with-file-writer ;
+
+: with-file-appender ( path encoding quot -- )
+    >r <file-appender> r> with-stream ; inline
 
 ! Pathnames
 : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
@@ -32,42 +51,84 @@ HOOK: rename-file io-backend ( from to -- )
 : left-trim-separators ( str -- newstr )
     [ path-separator? ] left-trim ;
 
-: append-path ( str1 str2 -- str )
-    >r right-trim-separators "/" r>
-    left-trim-separators 3append ;
-
-: prepend-path ( str1 str2 -- str )
-    swap append-path ; inline
-
 : last-path-separator ( path -- n ? )
     [ length 1- ] keep [ path-separator? ] find-last* ;
 
 HOOK: root-directory? io-backend ( path -- ? )
 
-M: object root-directory? ( path -- ? ) path-separator? ;
-
-: special-directory? ( name -- ? ) { "." ".." } member? ;
+M: object root-directory? ( path -- ? )
+    dup empty? [ drop f ] [ [ path-separator? ] all? ] if ;
 
 ERROR: no-parent-directory path ;
 
 : parent-directory ( path -- parent )
-    right-trim-separators {
-        { [ dup empty? ] [ drop "/" ] }
-        { [ dup root-directory? ] [ ] }
-        { [ dup [ path-separator? ] contains? not ] [ drop "." ] }
+    dup root-directory? [
+        right-trim-separators
+        dup last-path-separator [
+            1+ cut
+            {
+                { "." [ 1 head* parent-directory ] }
+                { ".." [
+                    2 head* parent-directory parent-directory
+                ] }
+                [ drop ]
+            } case
+        ] [ no-parent-directory ] if
+    ] unless ;
+
+<PRIVATE
+
+: head-path-separator? ( path1 ? -- ?' )
+    [
+        dup empty? [ drop t ] [ first path-separator? ] if
+    ] [
+        drop f
+    ] if ;
+
+: head.? ( path -- ? ) "." ?head head-path-separator? ;
+
+: head..? ( path -- ? ) ".." ?head head-path-separator? ;
+
+: append-path-empty ( path1 path2 -- path' )
+    {
+        { [ dup head.? ] [
+            1 tail left-trim-separators append-path-empty
+        ] }
+        { [ dup head..? ] [ drop no-parent-directory ] }
+        { [ t ] [ nip ] }
+    } cond ;
+
+PRIVATE>
+
+: absolute-path? ( path -- ? )
+    dup empty? [ drop f ] [ first path-separator? ] if ;
+
+: append-path ( str1 str2 -- str )
+    {
+        { [ over empty? ] [ append-path-empty ] }
+        { [ dup empty? ] [ drop ] }
+        { [ dup absolute-path? ] [ nip ] }
+        { [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
+        { [ dup head..? ] [
+            2 tail left-trim-separators
+            >r parent-directory r> append-path
+        ] }
         { [ t ] [
-            dup last-path-separator drop 1+ cut
-            special-directory? [ no-parent-directory ] when
+            >r right-trim-separators "/" r>
+            left-trim-separators 3append
         ] }
     } cond ;
 
-: file-name ( path -- string )
-    right-trim-separators {
-        { [ dup empty? ] [ drop "/" ] }
-        { [ dup last-path-separator ] [ 1+ tail ] }
-        { [ t ] [ drop ] }
-    } cond ;
+: prepend-path ( str1 str2 -- str )
+    swap append-path ; inline
 
+: file-name ( path -- string )
+    dup root-directory? [
+        right-trim-separators
+        dup last-path-separator [ 1+ tail ] [ drop ] if
+    ] unless ;
+
+! File info
 TUPLE: file-info type size permissions modified ;
 
 HOOK: file-info io-backend ( path -- info )
@@ -94,8 +155,12 @@ HOOK: cd io-backend ( path -- )
 
 HOOK: cwd io-backend ( -- path )
 
+SYMBOL: current-directory
+
+[ cwd current-directory set-global ] "current-directory" add-init-hook
+
 : with-directory ( path quot -- )
-    cwd [ cd ] curry rot cd [ ] cleanup ; inline
+    current-directory swap with-variable ; inline
 
 ! Creating directories
 HOOK: make-directory io-backend ( path -- )
@@ -118,7 +183,7 @@ HOOK: make-directory io-backend ( path -- )
         dup string?
         [ tuck append-path directory? 2array ] [ nip ] if
     ] with map
-    [ first special-directory? not ] subset ;
+    [ first { "." ".." } member? not ] subset ;
 
 : directory ( path -- seq )
     normalize-directory dup (directory) fixup-directory ;
@@ -199,34 +264,6 @@ DEFER: copy-tree-into
 : resource-exists? ( path -- ? )
     ?resource-path exists? ;
 
-! Pathname presentations
-TUPLE: pathname string ;
-
-C: <pathname> pathname
-
-M: pathname <=> [ pathname-string ] compare ;
-
-: file-lines ( path encoding -- seq )
-    <file-reader> lines ;
-
-: with-file-reader ( path encoding quot -- )
-    >r <file-reader> r> with-stream ; inline
-
-: file-contents ( path encoding -- str )
-    <file-reader> contents ;
-
-: with-file-writer ( path encoding quot -- )
-    >r <file-writer> r> with-stream ; inline
-
-: set-file-lines ( seq path encoding -- )
-    [ [ print ] each ] with-file-writer ;
-
-: set-file-contents ( str path encoding -- )
-    [ write ] with-file-writer ;
-
-: with-file-appender ( path encoding quot -- )
-    >r <file-appender> r> with-stream ; inline
-
 : temp-directory ( -- path )
     "temp" resource-path
     dup exists? not
@@ -235,6 +272,13 @@ M: pathname <=> [ pathname-string ] compare ;
 
 : temp-file ( name -- path ) temp-directory prepend-path ;
 
+! Pathname presentations
+TUPLE: pathname string ;
+
+C: <pathname> pathname
+
+M: pathname <=> [ pathname-string ] compare ;
+
 ! Home directory
 : home ( -- dir )
     {

extra/io/unix/files/files-tests.factor

@@ -6,3 +6,9 @@ IN: io.unix.files.tests
 [ "/" ] [ "/etc/" parent-directory ] unit-test
 [ "/" ] [ "/etc" parent-directory ] unit-test
 [ "/" ] [ "/" parent-directory ] unit-test
+[ "asdf" parent-directory ] must-fail
+
+[ f ] [ "" root-directory? ] unit-test
+[ t ] [ "/" root-directory? ] unit-test
+[ t ] [ "//" root-directory? ] unit-test
+[ t ] [ "///////" root-directory? ] unit-test