From b13e0f7042f38814ed28166e6d11ad97b488089c Mon Sep 17 00:00:00 2001
From: erg <erg@ergbook.local>
Date: Tue, 25 Mar 2008 19:50:39 -0500
Subject: [PATCH] redo path handling
---
core/io/files/files-tests.factor | 51 +++++++++
core/io/files/files.factor | 152 ++++++++++++++++---------
extra/io/unix/files/files-tests.factor | 6 +
3 files changed, 155 insertions(+), 54 deletions(-)
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index 4cda463983..e3765fead0 100755
--- a/core/io/files/files-tests.factor
+++ b/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
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 21cc7c8f0a..8595f227bf 100755
--- a/core/io/files/files.factor
+++ b/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 )
{
diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor
index f5366d32ae..98de09e8f1 100755
--- a/extra/io/unix/files/files-tests.factor
+++ b/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