diff --git a/basis/io/files/links/unix/unix-tests.factor b/basis/io/files/links/unix/unix-tests.factor index b1d2c5b8fa..dd5eb5c8d9 100644 --- a/basis/io/files/links/unix/unix-tests.factor +++ b/basis/io/files/links/unix/unix-tests.factor @@ -9,24 +9,30 @@ IN: io.files.links.unix.tests [ t ] [ [ - 5 "lol" make-test-links - "lol1" follow-links - current-directory get "lol5" append-path = - ] with-unique-directory + current-temporary-directory get [ + 5 "lol" make-test-links + "lol1" follow-links + current-temporary-directory get "lol5" append-path = + ] with-directory + ] cleanup-unique-directory ] unit-test [ [ - 100 "laf" make-test-links "laf1" follow-links + current-temporary-directory get [ + 100 "laf" make-test-links "laf1" follow-links + ] with-directory ] with-unique-directory ] [ too-many-symlinks? ] must-fail-with [ t ] [ 110 symlink-depth [ [ - 100 "laf" make-test-links - "laf1" follow-links - current-directory get "laf100" append-path = - ] with-unique-directory + current-temporary-directory get [ + 100 "laf" make-test-links + "laf1" follow-links + current-temporary-directory get "laf100" append-path = + ] with-directory + ] cleanup-unique-directory ] with-variable ] unit-test diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 08836cf497..b8a4431a73 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -1,8 +1,9 @@ USING: help.markup help.syntax io io.ports kernel math -io.pathnames io.directories math.parser io.files strings ; +io.pathnames io.directories math.parser io.files strings +quotations io.files.unique.private ; IN: io.files.unique -HELP: temporary-path +HELP: default-temporary-directory { $values { "path" "a pathname string" } } @@ -25,42 +26,66 @@ HELP: unique-retries HELP: make-unique-file ( prefix suffix -- path ) { $values { "prefix" "a string" } { "suffix" "a string" } { "path" "a pathname string" } } -{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } +{ $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-temporary-directory } ". The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } { $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ; -HELP: make-unique-file* -{ $values - { "prefix" string } { "suffix" string } - { "path" "a pathname string" } -} -{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ; +{ unique-file make-unique-file cleanup-unique-file } related-words -{ make-unique-file make-unique-file* with-unique-file } related-words - -HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- ) +HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- ) { $values { "prefix" "a string" } { "suffix" "a string" } { "quot" "a quotation" } } { $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." } { $notes "The unique file will be deleted after calling this word." } ; -HELP: make-unique-directory ( -- path ) +HELP: unique-directory ( -- path ) { $values { "path" "a pathname string" } } -{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." } +{ $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." } { $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ; -HELP: with-unique-directory ( quot -- ) +HELP: cleanup-unique-directory ( quot -- ) { $values { "quot" "a quotation" } } -{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-directory } " combinator. The quotation can access the " { $link current-directory } " symbol for the name of the temporary directory." } -{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation." } ; +{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } +{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ; -ARTICLE: "io.files.unique" "Temporary files" -"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl -"Creating temporary files:" +HELP: with-unique-directory +{ $values + { "quot" quotation } + { "path" "a pathname string" } +} +{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ; + +HELP: current-temporary-directory +{ $values + { "value" "a path" } +} +{ $description "The temporary directory used for creating unique files and directories." } ; + +HELP: unique-file +{ $values + { "path" "a pathname string" } + { "path'" "a pathname string" } +} +{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ; + +HELP: with-temporary-directory +{ $values + { "path" "a pathname string" } { "quot" quotation } +} +{ $description "Sets " { $link current-temporary-directory } " to " { $snippet "path" } " and calls the quotation, restoring the previous temporary path after execution completes." } ; + +ARTICLE: "io.files.unique" "Unique files" +"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in temporary directories in a high-level and secure way." $nl +"Changing the temporary path:" +{ $subsection current-temporary-directory } +"Creating unique files:" +{ $subsection unique-file } +{ $subsection cleanup-unique-file } { $subsection make-unique-file } -{ $subsection make-unique-file* } -{ $subsection with-unique-file } -"Creating temporary directories:" -{ $subsection make-unique-directory } -{ $subsection with-unique-directory } ; +"Creating unique directories:" +{ $subsection unique-directory } +{ $subsection with-unique-directory } +{ $subsection cleanup-unique-directory } +"Default temporary directory:" +{ $subsection default-temporary-directory } ; ABOUT: "io.files.unique" diff --git a/basis/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor index 8f2e32cea2..9fa9708e7b 100644 --- a/basis/io/files/unique/unique-tests.factor +++ b/basis/io/files/unique/unique-tests.factor @@ -7,15 +7,35 @@ IN: io.files.unique.tests "core" ".test" [ [ [ 123 CHAR: a ] dip ascii set-file-contents ] [ file-info size>> ] bi - ] with-unique-file + ] cleanup-unique-file ] unit-test [ t ] [ - [ current-directory get file-info directory? ] with-unique-directory + [ current-directory get file-info directory? ] cleanup-unique-directory ] unit-test [ t ] [ current-directory get - [ [ "FAILDOG" throw ] with-unique-directory ] [ drop ] recover + [ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover current-directory get = ] unit-test + +[ t ] [ + [ + "asdf" unique-file drop + "asdf2" unique-file drop + current-temporary-directory get directory-files length 2 = + ] cleanup-unique-directory +] unit-test + +[ t ] [ + [ ] with-unique-directory >boolean +] unit-test + +[ t ] [ + [ + "asdf" unique-file drop + "asdf" unique-file drop + current-temporary-directory get directory-files length 2 = + ] with-unique-directory drop +] unit-test diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 02f4d6080c..7bd96aa63b 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -6,8 +6,13 @@ kernel math math.bitwise math.parser namespaces random sequences system vocabs.loader ; IN: io.files.unique -HOOK: touch-unique-file io-backend ( path -- ) -HOOK: temporary-path io-backend ( -- path ) +HOOK: (touch-unique-file) io-backend ( path -- ) +: touch-unique-file ( path -- ) + normalize-path (touch-unique-file) ; + +HOOK: default-temporary-directory io-backend ( -- path ) + +SYMBOL: current-temporary-directory SYMBOL: unique-length SYMBOL: unique-retries @@ -15,6 +20,9 @@ SYMBOL: unique-retries 10 unique-length set-global 10 unique-retries set-global +: with-temporary-directory ( path quot -- ) + [ current-temporary-directory ] dip with-variable ; inline + +: random-name ( -- string ) + unique-length get [ random-ch ] "" replicate-as ; : (make-unique-file) ( path prefix suffix -- path ) '[ - _ _ _ unique-length get random-name glue append-path + _ _ _ random-name glue append-path dup touch-unique-file ] unique-retries get retry ; +PRIVATE> + : make-unique-file ( prefix suffix -- path ) - [ temporary-path ] 2dip (make-unique-file) ; + [ current-temporary-directory get ] 2dip (make-unique-file) ; -: make-unique-file* ( prefix suffix -- path ) - [ current-directory get ] 2dip (make-unique-file) ; - -: with-unique-file ( prefix suffix quot: ( path -- ) -- ) +: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- ) [ make-unique-file ] dip [ delete-file ] bi ; inline -: make-unique-directory ( -- path ) +: unique-directory ( -- path ) [ - temporary-path unique-length get random-name append-path + current-temporary-directory get + random-name append-path dup make-directory ] unique-retries get retry ; -: with-unique-directory ( quot: ( -- ) -- ) - [ make-unique-directory ] dip - '[ _ with-directory ] [ delete-tree ] bi ; inline +: with-unique-directory ( quot -- path ) + [ unique-directory ] dip + [ with-temporary-directory ] [ drop ] 2bi ; inline + +: cleanup-unique-directory ( quot: ( -- ) -- ) + [ unique-directory ] dip + '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline + +: unique-file ( path -- path' ) + "" make-unique-file ; { { [ os unix? ] [ "io.files.unique.unix" ] } { [ os windows? ] [ "io.files.unique.windows" ] } } cond require + +default-temporary-directory current-temporary-directory set-global diff --git a/basis/io/files/unique/unix/unix.factor b/basis/io/files/unique/unix/unix.factor index ed4e120b79..9f35f440c7 100644 --- a/basis/io/files/unique/unix/unix.factor +++ b/basis/io/files/unique/unix/unix.factor @@ -7,7 +7,7 @@ IN: io.files.unique.unix : open-unique-flags ( -- flags ) { O_RDWR O_CREAT O_EXCL } flags ; -M: unix touch-unique-file ( path -- ) +M: unix (touch-unique-file) ( path -- ) open-unique-flags file-mode open-file close-file ; -M: unix temporary-path ( -- path ) "/tmp" ; +M: unix default-temporary-directory ( -- path ) "/tmp" ; diff --git a/basis/io/files/unique/windows/windows.factor b/basis/io/files/unique/windows/windows.factor index 47f30999c3..2c722426dc 100644 --- a/basis/io/files/unique/windows/windows.factor +++ b/basis/io/files/unique/windows/windows.factor @@ -3,8 +3,8 @@ io.files.windows io.ports windows destructors environment io.files.unique ; IN: io.files.unique.windows -M: windows touch-unique-file ( path -- ) +M: windows (touch-unique-file) ( path -- ) GENERIC_WRITE CREATE_NEW 0 open-file dispose ; -M: windows temporary-path ( -- path ) +M: windows default-temporary-directory ( -- path ) "TEMP" os-env ;