diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 8e32c100e0..984598688d 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -55,8 +55,9 @@ ARTICLE: "directories" "Directories" "Home directory:" { $subsection home } "Directory listing:" -{ $subsection directory } -{ $subsection directory* } +{ $subsection directory-entries } +{ $subsection directory-files } +{ $subsection with-directory-files } "Creating directories:" { $subsection make-directory } { $subsection make-directories } @@ -304,23 +305,22 @@ HELP: directory? { $values { "file-info" file-info } { "?" "a boolean" } } { $description "Tests if " { $snippet "file-info" } " is a directory." } ; -HELP: (directory) +HELP: (directory-entries) { $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } -{ $notes "This is a low-level word, and user code should call " { $link directory } " instead." } ; +{ $notes "This is a low-level word, and user code should call one of the related words instead." } ; -HELP: directory -{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } +HELP: directory-entries +{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } } { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; -HELP: directory* -{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } } -{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } -{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ; +HELP: directory-files +{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } } +{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; -! HELP: file-modified -! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } -! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; +HELP: with-directory-files +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } @@ -329,10 +329,6 @@ HELP: resource-path HELP: pathname { $class-description "Class of path name objects. Path name objects can be created by calling " { $link } "." } ; -HELP: normalize-directory -{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } -{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ; - HELP: normalize-path { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 0723096519..3104fcdb55 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -151,18 +151,24 @@ USE: debugger.threads "delete-tree-test" temp-file delete-tree ] unit-test -[ { { "kernel" t } } ] [ +[ { "kernel" } ] [ "core" resource-path [ - "." directory [ first "kernel" = ] filter + "." directory-files [ "kernel" = ] filter ] with-directory ] unit-test -[ { { "kernel" t } } ] [ +[ { "kernel" } ] [ "resource:core" [ - "." directory [ first "kernel" = ] filter + "." directory-files [ "kernel" = ] filter ] with-directory ] unit-test +[ { "kernel" } ] [ + "resource:core" [ + [ "kernel" = ] filter + ] with-directory-files +] unit-test + [ ] [ "copy-tree-test/a/b/c" temp-file make-directories ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6b84073d34..8796834bc7 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -235,19 +235,22 @@ HOOK: make-directory io-backend ( path -- ) ] } cond drop ; -! Directory listings -: fixup-directory ( path seq -- newseq ) - [ - dup string? - [ tuck append-path file-info directory? 2array ] [ nip ] if - ] with map - [ first { "." ".." } member? not ] filter ; +TUPLE: directory-entry name type ; -: directory ( path -- seq ) - normalize-directory dup (directory) fixup-directory ; +HOOK: >directory-entry os ( byte-array -- directory-entry ) -: directory* ( path -- seq ) - dup directory [ first2 >r append-path r> 2array ] with map ; +HOOK: (directory-entries) os ( path -- seq ) + +: directory-entries ( path -- seq ) + normalize-path + (directory-entries) + [ name>> { "." ".." } member? not ] filter ; + +: directory-files ( path -- seq ) + directory-entries [ name>> ] map ; + +: with-directory-files ( path quot -- ) + [ "" directory-files ] prepose with-directory ; inline ! Touching files HOOK: touch-file io-backend ( path -- ) @@ -259,12 +262,10 @@ HOOK: delete-directory io-backend ( path -- ) : delete-tree ( path -- ) dup link-info type>> +directory+ = [ - dup directory over [ - [ first delete-tree ] each - ] with-directory delete-directory - ] [ - delete-file - ] if ; + [ [ [ delete-tree ] each ] with-directory-files ] + [ delete-directory ] + bi + ] [ delete-file ] if ; : to-directory ( from to -- from to' ) over file-name append-path ; @@ -303,9 +304,9 @@ DEFER: copy-tree-into { { +symbolic-link+ [ copy-link ] } { +directory+ [ - >r dup directory r> rot [ - [ >r first r> copy-tree-into ] curry each - ] with-directory + swap [ + [ swap copy-tree-into ] with each + ] with-directory-files ] } [ drop copy-file ] } case ;