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 ) : ( path encoding -- stream ) swap (file-appender) swap ; -HOOK: rename-file io-backend ( from to -- ) +: file-lines ( path encoding -- seq ) + lines ; + +: with-file-reader ( path encoding quot -- ) + >r r> with-stream ; inline + +: file-contents ( path encoding -- str ) + contents ; + +: with-file-writer ( path encoding quot -- ) + >r 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 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 ; + + + +: 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 - -M: pathname <=> [ pathname-string ] compare ; - -: file-lines ( path encoding -- seq ) - lines ; - -: with-file-reader ( path encoding quot -- ) - >r r> with-stream ; inline - -: file-contents ( path encoding -- str ) - contents ; - -: with-file-writer ( path encoding quot -- ) - >r 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 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 + +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