io.files.unique: change to create unique files and directories relative to the current-directory.
John Benediktsson
parent
f5b31a85c0
commit
baae677276
|
|
@ -59,26 +59,27 @@ M: windows scp-name "pscp" ;
|
|||
] change-file-lines ;
|
||||
|
||||
: with-build-images ( quot -- )
|
||||
[ boot-image-names [ absolute-path ] map ] dip
|
||||
'[
|
||||
! Copy boot images
|
||||
boot-image-names current-temporary-directory get copy-files-into
|
||||
! Copy checksums
|
||||
checksums-path current-temporary-directory get copy-file-into
|
||||
current-temporary-directory get [
|
||||
[
|
||||
! Copy boot images
|
||||
_ "." copy-files-into
|
||||
! Copy checksums
|
||||
checksums-path "." copy-file-into
|
||||
! Rewrite checksum lines with build number
|
||||
checksum-lines-append-build
|
||||
! Rename file to file.build-number
|
||||
current-directory get directory-files [ dup append-build move-file ] each
|
||||
! Run the quot in the current-directory, which is the unique directory
|
||||
"." directory-files [ dup append-build move-file ] each
|
||||
! Run the quot in the unique directory
|
||||
@
|
||||
] with-directory
|
||||
] cleanup-unique-directory ; inline
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory ; inline
|
||||
|
||||
: upload-build-images ( -- )
|
||||
[
|
||||
[
|
||||
\ scp-name get-global scp-name or ,
|
||||
current-directory get directory-files %
|
||||
"." directory-files %
|
||||
build-destination ,
|
||||
] { } make try-process
|
||||
] with-build-images ;
|
||||
|
|
|
|||
|
|
@ -79,14 +79,19 @@ IN: csv.tests
|
|||
|
||||
{ { { "writing" "some" "csv" "tests" } } }
|
||||
[
|
||||
"writing,some,csv,tests"
|
||||
"csv-test1-" unique-file utf8
|
||||
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
|
||||
[
|
||||
"writing,some,csv,tests"
|
||||
"csv-test1-" ".csv" unique-file utf8
|
||||
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
{ { "writing,some,csv,tests" } } dup "csv-test2-"
|
||||
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
|
||||
[
|
||||
{ { "writing,some,csv,tests" } } dup
|
||||
"csv-test2-" ".csv" unique-file utf8
|
||||
[ csv>file ] [ file>csv ] 2bi =
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ { { "hello" "" "" "" "goodbye" "" } } }
|
||||
|
|
|
|||
|
|
@ -1,26 +1,29 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit db db.errors
|
||||
db.errors.sqlite db.sqlite io.files.unique kernel namespaces
|
||||
tools.test ;
|
||||
db.errors.sqlite db.sqlite io.files.temp io.files.unique kernel
|
||||
namespaces tools.test ;
|
||||
IN: db.errors.sqlite.tests
|
||||
|
||||
: sqlite-error-test-db-path ( -- path )
|
||||
"sqlite" "error-test" make-unique-file ;
|
||||
[
|
||||
"sqlite" "error-test" [
|
||||
|
||||
sqlite-error-test-db-path <sqlite-db> [
|
||||
<sqlite-db> [
|
||||
|
||||
[
|
||||
"insert into foo (id) values('1');" sql-command
|
||||
] [
|
||||
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
[
|
||||
"insert into foo (id) values('1');" sql-command
|
||||
] [
|
||||
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table foo(id);" sql-command
|
||||
"create table foo(id);" sql-command
|
||||
] [
|
||||
{ [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
"create table foo(id);" sql-command
|
||||
|
||||
] with-db
|
||||
[
|
||||
"create table foo(id);" sql-command
|
||||
] [
|
||||
{ [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
] with-db
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
|
|
|
|||
|
|
@ -10,26 +10,30 @@ CONSTANT: test-file-contents "Files are so boring anymore."
|
|||
|
||||
: create-test-file ( -- path )
|
||||
test-file-contents
|
||||
"ftp.server" "test" make-unique-file
|
||||
"ftp.server" "test" unique-file
|
||||
[ ascii set-file-contents ] [ normalize-path ] bi ;
|
||||
|
||||
: test-ftp-server ( quot -- )
|
||||
'[
|
||||
current-temporary-directory get
|
||||
0 <ftp-server> [
|
||||
"ftp://localhost" >url insecure-addr set-url-addr
|
||||
"ftp" >>protocol
|
||||
create-test-file >>path
|
||||
@
|
||||
] with-threaded-server
|
||||
] cleanup-unique-directory ; inline
|
||||
[
|
||||
'[
|
||||
"." 0 <ftp-server> [
|
||||
"ftp://localhost" >url insecure-addr set-url-addr
|
||||
"ftp" >>protocol
|
||||
create-test-file >>path
|
||||
@
|
||||
] with-threaded-server
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory ; inline
|
||||
|
||||
{ t }
|
||||
[
|
||||
[
|
||||
[
|
||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||
] cleanup-unique-working-directory
|
||||
[
|
||||
[ ftp-get ]
|
||||
[ path>> file-name ascii file-contents ] bi
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] test-ftp-server test-file-contents =
|
||||
] unit-test
|
||||
|
||||
|
|
@ -38,7 +42,10 @@ CONSTANT: test-file-contents "Files are so boring anymore."
|
|||
[
|
||||
"/" >>path
|
||||
[
|
||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||
] cleanup-unique-working-directory
|
||||
[
|
||||
[ ftp-get ]
|
||||
[ path>> file-name ascii file-contents ] bi
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] test-ftp-server test-file-contents =
|
||||
] must-fail
|
||||
|
|
|
|||
|
|
@ -6,9 +6,11 @@ IN: io.directories.search.tests
|
|||
|
||||
{ t } [
|
||||
[
|
||||
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
|
||||
current-temporary-directory get [ ] find-all-files
|
||||
] cleanup-unique-directory [ natural-sort ] same?
|
||||
[
|
||||
10 [ "io.paths.test" "gogogo" unique-file ] replicate
|
||||
"." [ ] find-all-files
|
||||
] cleanup-unique-directory [ natural-sort ] same?
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -23,17 +25,22 @@ IN: io.directories.search.tests
|
|||
|
||||
{ t } [
|
||||
[
|
||||
current-temporary-directory get
|
||||
"the-head" unique-file drop t
|
||||
[ file-name "the-head" head? ] find-file string?
|
||||
] cleanup-unique-directory
|
||||
[
|
||||
"the-head" "" unique-file drop
|
||||
"." t [ file-name "the-head" head? ] find-file string?
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[ unique-directory unique-directory ] output>array
|
||||
[ [ "abcd" append-path touch-file ] each ]
|
||||
[ [ file-name "abcd" = ] find-all-in-directories length 2 = ]
|
||||
[ [ delete-tree ] each ] tri
|
||||
[
|
||||
[
|
||||
[ unique-directory unique-directory ] output>array
|
||||
[ [ "abcd" append-path touch-file ] each ]
|
||||
[ [ file-name "abcd" = ] find-all-in-directories length 2 = ]
|
||||
[ [ delete-tree ] each ] tri
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
|
|
|
|||
|
|
@ -9,30 +9,30 @@ IN: io.files.links.unix.tests
|
|||
|
||||
{ t } [
|
||||
[
|
||||
current-temporary-directory get [
|
||||
[
|
||||
5 "lol" make-test-links
|
||||
"lol1" follow-links
|
||||
current-temporary-directory get "lol5" append-path =
|
||||
] with-directory
|
||||
] cleanup-unique-directory
|
||||
"lol5" absolute-path =
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
current-temporary-directory get [
|
||||
[
|
||||
100 "laf" make-test-links "laf1" follow-links
|
||||
] with-directory
|
||||
] with-unique-directory
|
||||
] with-unique-directory
|
||||
] with-temp-directory
|
||||
] [ too-many-symlinks? ] must-fail-with
|
||||
|
||||
{ t } [
|
||||
110 symlink-depth [
|
||||
[
|
||||
current-temporary-directory get [
|
||||
[
|
||||
100 "laf" make-test-links
|
||||
"laf1" follow-links
|
||||
current-temporary-directory get "laf100" append-path =
|
||||
] with-directory
|
||||
] cleanup-unique-directory
|
||||
"laf100" absolute-path =
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,16 +1,9 @@
|
|||
USING: help.markup help.syntax io.directories quotations strings ;
|
||||
USING: help.markup help.syntax io.directories io.pathnames
|
||||
quotations strings ;
|
||||
IN: io.files.unique
|
||||
|
||||
HELP: default-temporary-directory
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $description "A hook that returns the path of the temporary directory in a platform-specific way. Does not guarantee that path is writable by your user." } ;
|
||||
|
||||
HELP: touch-unique-file
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Creates a unique file in a platform-specific way. The file is guaranteed not to exist and is openable by your user." } ;
|
||||
|
||||
HELP: unique-length
|
||||
|
|
@ -21,92 +14,46 @@ HELP: unique-retries
|
|||
|
||||
{ unique-length unique-retries } related-words
|
||||
|
||||
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 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: unique-file
|
||||
{ $values { "prefix" string } { "suffix" string } { "path" "a pathname string" } }
|
||||
{ $description "Creates a file that is guaranteed not to exist in the " { $link current-directory } ". The file name is composed of a prefix, a " { $link unique-length } " 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 " { $link unique-retries } " number of tries. The most likely error is incorrect directory permissions on the " { $link current-directory } "." } ;
|
||||
|
||||
{ unique-file make-unique-file cleanup-unique-file } related-words
|
||||
{ unique-file cleanup-unique-file } related-words
|
||||
|
||||
HELP: cleanup-unique-file
|
||||
{ $values { "prefix" string } { "suffix" string }
|
||||
{ "quot" 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." } ;
|
||||
{ $values { "prefix" string } { "suffix" string } { "quot" { $quotation ( path -- ) } } }
|
||||
{ $description "Creates a file with " { $link unique-file } " and calls the quotation with the path name on the stack." }
|
||||
{ $notes "The unique file will be deleted after calling this word, even if an error is thrown in the quotation." } ;
|
||||
|
||||
HELP: unique-directory
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Creates a directory in " { $link current-temporary-directory } " that is guaranteed not to exist and return the full pathname. The mechanism for the guarantee of uniqueness is retrying with a randomly generated filename until " { $link make-directory } " does not fail." }
|
||||
{ $errors "Throws an error if the directory cannot be created after a number of tries " { $link unique-retries } ". The most likely error is incorrect directory permissions on the temporary directory." } ;
|
||||
{ $description "Creates a directory in the " { $link current-directory } " that is guaranteed not to exist and return the full pathname. The mechanism for the guarantee of uniqueness is retrying with a " { $link unique-length } " randomly generated filename until " { $link make-directory } " succeeds." }
|
||||
{ $errors "Throws an error if the directory cannot be created after a " { $link unique-retries } " number of tries. The most likely error is incorrect directory permissions on the " { $link current-directory } "." } ;
|
||||
|
||||
HELP: with-unique-directory
|
||||
{ $values { "quot" quotation } { "path" "a pathname string" } }
|
||||
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation using " { $link with-directory } " to set it as the " { $link current-directory } "." } ;
|
||||
|
||||
HELP: cleanup-unique-directory
|
||||
{ $values { "quot" 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." } ;
|
||||
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation using " { $link with-directory } " to set it as the " { $link current-directory } "." }
|
||||
{ $notes "The unique directory will be deleted after calling this word, even if an error is thrown in the quotation." } ;
|
||||
|
||||
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: copy-file-unique
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "prefix" string } { "suffix" string }
|
||||
{ "path'" "a pathname string" }
|
||||
}
|
||||
{ $description "Copies " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
|
||||
|
||||
HELP: move-file-unique
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "prefix" string } { "suffix" string }
|
||||
{ "path'" "a pathname string" }
|
||||
}
|
||||
{ $description "Moves " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ;
|
||||
|
||||
HELP: current-temporary-directory
|
||||
{ $values
|
||||
{ "value" "a path" }
|
||||
}
|
||||
{ $description "The temporary directory used for creating unique files and directories." } ;
|
||||
|
||||
HELP: unique-file
|
||||
{ $values
|
||||
{ "prefix" 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." } ;
|
||||
{ unique-directory with-unique-directory cleanup-unique-directory } related-words
|
||||
|
||||
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:"
|
||||
{ $subsections current-temporary-directory }
|
||||
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in a high-level and secure way." $nl
|
||||
"Creating unique files:"
|
||||
{ $subsections
|
||||
unique-file
|
||||
cleanup-unique-file
|
||||
make-unique-file
|
||||
}
|
||||
"Creating unique directories:"
|
||||
{ $subsections
|
||||
unique-directory
|
||||
with-unique-directory
|
||||
cleanup-unique-directory
|
||||
}
|
||||
"Default temporary directory:"
|
||||
{ $subsections default-temporary-directory }
|
||||
"Copying and moving files to a new unique file:"
|
||||
{ $subsections
|
||||
copy-file-unique
|
||||
move-file-unique
|
||||
} ;
|
||||
|
||||
ABOUT: "io.files.unique"
|
||||
|
|
|
|||
|
|
@ -1,41 +1,54 @@
|
|||
USING: io.encodings.ascii sequences strings io io.files accessors
|
||||
tools.test kernel io.files.unique namespaces continuations
|
||||
io.files.info io.pathnames io.directories ;
|
||||
USING: accessors continuations io.directories io.encodings.ascii
|
||||
io.files io.files.info io.files.unique io.pathnames kernel
|
||||
namespaces sequences strings tools.test ;
|
||||
IN: io.files.unique.tests
|
||||
|
||||
{ 123 } [
|
||||
"core" ".test" [
|
||||
[ [ 123 CHAR: a <string> ] dip ascii set-file-contents ]
|
||||
[ file-info size>> ] bi
|
||||
] cleanup-unique-file
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[ current-directory get file-info directory? ] cleanup-unique-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
current-directory get
|
||||
[ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover
|
||||
current-directory get =
|
||||
[
|
||||
"core" ".test" [
|
||||
[ [ 123 CHAR: a <string> ] dip ascii set-file-contents ]
|
||||
[ file-info size>> ] bi
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] 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
|
||||
[ current-directory get file-info directory? ]
|
||||
cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[
|
||||
"asdf" unique-file drop
|
||||
"asdf" unique-file drop
|
||||
current-temporary-directory get directory-files length 2 =
|
||||
] with-unique-directory drop
|
||||
current-directory get
|
||||
[ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover
|
||||
current-directory get =
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[
|
||||
[
|
||||
"asdf" "" unique-file drop
|
||||
"asdf2" "" unique-file drop
|
||||
"." directory-files length 2 =
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[
|
||||
[ ] with-unique-directory >boolean
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[
|
||||
[
|
||||
"asdf" "" unique-file drop
|
||||
"asdf" "" unique-file drop
|
||||
"." directory-files length 2 =
|
||||
] with-unique-directory drop
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,28 +1,25 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators continuations fry io io.backend
|
||||
io.directories io.directories.hierarchy io.files io.pathnames
|
||||
kernel locals math math.bitwise math.parser namespaces random
|
||||
sequences system vocabs random.data ;
|
||||
USING: combinators continuations fry io.backend io.directories
|
||||
io.directories.hierarchy io.pathnames kernel locals namespaces
|
||||
random.data sequences system vocabs ;
|
||||
IN: io.files.unique
|
||||
|
||||
<PRIVATE
|
||||
|
||||
HOOK: (touch-unique-file) io-backend ( path -- )
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: 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
|
||||
|
||||
10 unique-length set-global
|
||||
10 unique-retries set-global
|
||||
|
||||
: with-temporary-directory ( path quot -- )
|
||||
[ current-temporary-directory ] dip with-variable ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: random-file-name ( -- string )
|
||||
|
|
@ -31,54 +28,37 @@ SYMBOL: unique-retries
|
|||
: retry ( quot: ( -- ? ) n -- )
|
||||
iota swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
: (make-unique-file) ( path prefix suffix -- path )
|
||||
PRIVATE>
|
||||
|
||||
: unique-file ( prefix suffix -- path )
|
||||
'[
|
||||
_ _ _ random-file-name glue append-path
|
||||
current-directory get
|
||||
_ _ random-file-name glue append-path
|
||||
dup touch-unique-file
|
||||
] unique-retries get retry ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: make-unique-file ( prefix suffix -- path )
|
||||
[ current-temporary-directory get ] 2dip (make-unique-file) ;
|
||||
|
||||
: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
|
||||
[ make-unique-file ] dip [ delete-file ] bi ; inline
|
||||
:: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
|
||||
prefix suffix unique-file :> path
|
||||
[ path quot call ] [ path delete-file ] [ ] cleanup ; inline
|
||||
|
||||
: unique-directory ( -- path )
|
||||
[
|
||||
current-temporary-directory get
|
||||
current-directory get
|
||||
random-file-name append-path
|
||||
dup make-directory
|
||||
] unique-retries get retry ;
|
||||
|
||||
: 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 ( prefix -- path )
|
||||
"" make-unique-file ;
|
||||
|
||||
: move-file-unique ( path prefix suffix -- path' )
|
||||
make-unique-file [ move-file ] keep ;
|
||||
|
||||
: copy-file-unique ( path prefix suffix -- path' )
|
||||
make-unique-file [ copy-file ] keep ;
|
||||
|
||||
: temporary-file ( -- path ) "" unique-file ;
|
||||
|
||||
:: cleanup-unique-working-directory ( quot -- )
|
||||
:: with-unique-directory ( quot -- path )
|
||||
unique-directory :> path
|
||||
path [ path quot with-temporary-directory ] with-directory
|
||||
path delete-tree ; inline
|
||||
path quot with-directory
|
||||
path ; inline
|
||||
|
||||
:: cleanup-unique-directory ( quot -- )
|
||||
unique-directory :> path
|
||||
[ path quot with-directory ]
|
||||
[ path delete-tree ] [ ] cleanup ; inline
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "io.files.unique.unix" ] }
|
||||
{ [ os windows? ] [ "io.files.unique.windows" ] }
|
||||
} cond require
|
||||
|
||||
default-temporary-directory current-temporary-directory set-global
|
||||
|
|
|
|||
|
|
@ -1,12 +1,10 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.ports io.backend.unix math.bitwise
|
||||
unix system io.files.unique unix.ffi literals ;
|
||||
USING: io.backend.unix io.files.unique.private literals system
|
||||
unix unix.ffi ;
|
||||
IN: io.files.unique.unix
|
||||
|
||||
CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
|
||||
|
||||
M: unix (touch-unique-file) ( path -- )
|
||||
open-unique-flags file-mode open-file close-file ;
|
||||
|
||||
M: unix default-temporary-directory ( -- path ) "/tmp" ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,6 @@
|
|||
USING: destructors environment io.files.unique io.files.windows
|
||||
system windows.kernel32 ;
|
||||
USING: destructors environment io.files.unique.private
|
||||
io.files.windows system windows.kernel32 ;
|
||||
IN: io.files.unique.windows
|
||||
|
||||
M: windows (touch-unique-file) ( path -- )
|
||||
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
|
||||
|
||||
M: windows default-temporary-directory ( -- path )
|
||||
"TEMP" os-env ;
|
||||
|
|
|
|||
|
|
@ -82,7 +82,8 @@ SYMBOLS: out-path err-path ;
|
|||
[ ] [
|
||||
<process>
|
||||
console-vm-path "-run=hello-world" 2array >>command
|
||||
"out.txt" unique-file [ out-path set-global ] keep >>stdout
|
||||
[ "out" ".txt" unique-file ] with-temp-directory
|
||||
[ out-path set-global ] keep >>stdout
|
||||
try-process
|
||||
] unit-test
|
||||
|
||||
|
|
@ -105,8 +106,10 @@ SYMBOLS: out-path err-path ;
|
|||
launcher-test-path [
|
||||
<process>
|
||||
console-vm-path "-script" "stderr.factor" 3array >>command
|
||||
"out.txt" unique-file [ out-path set-global ] keep >>stdout
|
||||
"err.txt" unique-file [ err-path set-global ] keep >>stderr
|
||||
[ "out" ".txt" unique-file ] with-temp-directory
|
||||
[ out-path set-global ] keep >>stdout
|
||||
[ "err" ".txt" unique-file ] with-temp-directory
|
||||
[ err-path set-global ] keep >>stderr
|
||||
try-process
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
|
@ -123,7 +126,8 @@ SYMBOLS: out-path err-path ;
|
|||
launcher-test-path [
|
||||
<process>
|
||||
console-vm-path "-script" "stderr.factor" 3array >>command
|
||||
"out.txt" unique-file [ out-path set-global ] keep >>stdout
|
||||
[ "out" ".txt" unique-file ] with-temp-directory
|
||||
[ out-path set-global ] keep >>stdout
|
||||
+stdout+ >>stderr
|
||||
try-process
|
||||
] with-directory
|
||||
|
|
@ -137,7 +141,8 @@ SYMBOLS: out-path err-path ;
|
|||
launcher-test-path [
|
||||
<process>
|
||||
console-vm-path "-script" "stderr.factor" 3array >>command
|
||||
"err2.txt" unique-file [ err-path set-global ] keep >>stderr
|
||||
[ "err2" ".txt" unique-file ] with-temp-directory
|
||||
[ err-path set-global ] keep >>stderr
|
||||
utf8 <process-reader> stream-lines first
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
|
@ -197,7 +202,8 @@ SYMBOLS: out-path err-path ;
|
|||
[ ] [
|
||||
<process>
|
||||
"cmd.exe /c dir" >>command
|
||||
"dir.txt" unique-file [ out-path set-global ] keep >>stdout
|
||||
[ "dir" ".txt" unique-file ] with-temp-directory
|
||||
[ out-path set-global ] keep >>stdout
|
||||
try-process
|
||||
] unit-test
|
||||
|
||||
|
|
@ -205,7 +211,7 @@ SYMBOLS: out-path err-path ;
|
|||
] times
|
||||
|
||||
{ "Hello appender\r\nÖrjan ågren är åter\r\nHello appender\r\nÖrjan ågren är åter\r\n" } [
|
||||
"append-test" unique-file out-path set-global
|
||||
[ "append-test" "" unique-file ] with-temp-directory out-path set-global
|
||||
2 [
|
||||
launcher-test-path [
|
||||
<process>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs continuations fry http.server io
|
||||
io.encodings.ascii io.files io.files.unique
|
||||
io.encodings.ascii io.files io.files.temp io.files.unique
|
||||
io.servers io.streams.duplex io.streams.string
|
||||
kernel math.ranges mime.multipart multiline namespaces random
|
||||
sequences sorting strings threads tools.test ;
|
||||
|
|
@ -13,8 +13,8 @@ CONSTANT: upload1 "------WebKitFormBoundary6odjpVPXIighAE2L\r\nContent-Dispositi
|
|||
|
||||
: mime-test-stream ( -- stream )
|
||||
upload1
|
||||
"mime" "test" make-unique-file ascii
|
||||
[ set-file-contents ] [ <file-reader> ] 2bi ;
|
||||
[ "mime" "test" unique-file ] with-temp-directory
|
||||
ascii [ set-file-contents ] [ <file-reader> ] 2bi ;
|
||||
|
||||
{ } [ mime-test-stream [ ] with-input-stream ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors ascii assocs byte-arrays combinators fry
|
||||
hashtables http http.parsers io io.encodings.binary io.files
|
||||
io.files.unique io.streams.string kernel math quoting sequences
|
||||
splitting ;
|
||||
io.files.temp io.files.unique io.streams.string kernel math
|
||||
quoting sequences splitting ;
|
||||
IN: mime.multipart
|
||||
|
||||
CONSTANT: buffer-size 65536
|
||||
|
|
@ -94,7 +94,7 @@ C: <mime-variable> mime-variable
|
|||
] with-output-stream ;
|
||||
|
||||
: dump-file ( multipart -- multipart )
|
||||
"factor-" "-upload" make-unique-file
|
||||
[ "factor-" "-upload" unique-file ] with-temp-directory
|
||||
[ >>temp-file ] [ dump-mime-file ] bi ;
|
||||
|
||||
: parse-content-disposition-form-data ( string -- hashtable )
|
||||
|
|
|
|||
|
|
@ -157,91 +157,116 @@ CONSTANT: pt-array-1
|
|||
! File seeking tests
|
||||
{ B{ 3 2 3 4 5 } }
|
||||
[
|
||||
"seek-test1" unique-file binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write
|
||||
tell-output 5 assert=
|
||||
0 seek-absolute seek-output
|
||||
tell-output 0 assert=
|
||||
B{ 3 } write
|
||||
tell-output 1 assert=
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
"seek-test1" "" [
|
||||
binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write
|
||||
tell-output 5 assert=
|
||||
0 seek-absolute seek-output
|
||||
tell-output 0 assert=
|
||||
B{ 3 } write
|
||||
tell-output 1 assert=
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ B{ 1 2 3 4 3 } }
|
||||
[
|
||||
"seek-test2" unique-file binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write
|
||||
tell-output 5 assert=
|
||||
-1 seek-relative seek-output
|
||||
tell-output 4 assert=
|
||||
B{ 3 } write
|
||||
tell-output 5 assert=
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
"seek-test2" "" [
|
||||
binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write
|
||||
tell-output 5 assert=
|
||||
-1 seek-relative seek-output
|
||||
tell-output 4 assert=
|
||||
B{ 3 } write
|
||||
tell-output 5 assert=
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ B{ 1 2 3 4 5 0 3 } }
|
||||
[
|
||||
"seek-test3" unique-file binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write
|
||||
tell-output 5 assert=
|
||||
1 seek-relative seek-output
|
||||
tell-output 6 assert=
|
||||
B{ 3 } write
|
||||
tell-output 7 assert=
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
"seek-test3" "" [
|
||||
binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write
|
||||
tell-output 5 assert=
|
||||
1 seek-relative seek-output
|
||||
tell-output 6 assert=
|
||||
B{ 3 } write
|
||||
tell-output 7 assert=
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ B{ 3 } }
|
||||
[
|
||||
B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
|
||||
set-file-contents
|
||||
] [
|
||||
[
|
||||
tell-input 0 assert=
|
||||
-3 seek-end seek-input
|
||||
tell-input 2 assert=
|
||||
1 read
|
||||
tell-input 3 assert=
|
||||
] with-file-reader
|
||||
] 2bi
|
||||
[
|
||||
"seek-test4" "" [
|
||||
B{ 1 2 3 4 5 } swap binary
|
||||
[
|
||||
set-file-contents
|
||||
] [
|
||||
[
|
||||
tell-input 0 assert=
|
||||
-3 seek-end seek-input
|
||||
tell-input 2 assert=
|
||||
1 read
|
||||
tell-input 3 assert=
|
||||
] with-file-reader
|
||||
] 2bi
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
{ B{ 2 } }
|
||||
[
|
||||
B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
|
||||
set-file-contents
|
||||
] [
|
||||
[
|
||||
tell-input 0 assert=
|
||||
3 seek-absolute seek-input
|
||||
tell-input 3 assert=
|
||||
-2 seek-relative seek-input
|
||||
tell-input 1 assert=
|
||||
1 read
|
||||
tell-input 2 assert=
|
||||
] with-file-reader
|
||||
] 2bi
|
||||
[
|
||||
"seek-test5" "" [
|
||||
B{ 1 2 3 4 5 } swap binary [
|
||||
set-file-contents
|
||||
] [
|
||||
[
|
||||
tell-input 0 assert=
|
||||
3 seek-absolute seek-input
|
||||
tell-input 3 assert=
|
||||
-2 seek-relative seek-input
|
||||
tell-input 1 assert=
|
||||
1 read
|
||||
tell-input 2 assert=
|
||||
] with-file-reader
|
||||
] 2bi
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"seek-test6" unique-file binary [
|
||||
-10 seek-absolute seek-input
|
||||
] with-file-reader
|
||||
[
|
||||
"seek-test6" "" [
|
||||
binary [
|
||||
-10 seek-absolute seek-input
|
||||
] with-file-reader
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] must-fail
|
||||
|
||||
{ } [
|
||||
|
|
@ -254,21 +279,29 @@ CONSTANT: pt-array-1
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"non-string-error" unique-file ascii [
|
||||
{ } write
|
||||
] with-file-writer
|
||||
[
|
||||
"non-string-error" "" [
|
||||
ascii [ { } write ] with-file-writer
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] [ no-method? ] must-fail-with
|
||||
|
||||
[
|
||||
"non-byte-array-error" unique-file binary [
|
||||
"" write
|
||||
] with-file-writer
|
||||
[
|
||||
"non-byte-array-error" "" [
|
||||
binary [ "" write ] with-file-writer
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] [ no-method? ] must-fail-with
|
||||
|
||||
! What happens if we close a file twice?
|
||||
{ } [
|
||||
"closing-twice" unique-file ascii <file-writer>
|
||||
[ dispose ] [ dispose ] bi
|
||||
[
|
||||
"closing-twice" "" [
|
||||
ascii <file-writer>
|
||||
[ dispose ] [ dispose ] bi
|
||||
] cleanup-unique-file
|
||||
] with-temp-directory
|
||||
] unit-test
|
||||
|
||||
! Test cwd, cd. You do not want to use with-cd, you want with-directory.
|
||||
|
|
|
|||
|
|
@ -3,10 +3,10 @@ USING: accessors arrays assocs calendar calendar.format
|
|||
combinators combinators.short-circuit fry io io.backend
|
||||
io.directories io.directories.hierarchy io.encodings.binary
|
||||
io.encodings.detect io.encodings.utf8 io.files io.files.info
|
||||
io.files.types io.files.unique io.launcher io.pathnames kernel
|
||||
locals math math.parser namespaces sequences sorting strings
|
||||
system unicode.categories xml.syntax xml.writer xmode.catalog
|
||||
xmode.marker xmode.tokens ;
|
||||
io.files.temp io.files.types io.files.unique io.launcher
|
||||
io.pathnames kernel locals math math.parser namespaces sequences
|
||||
sorting strings system unicode.categories xml.syntax xml.writer
|
||||
xmode.catalog xmode.marker xmode.tokens ;
|
||||
IN: codebook
|
||||
|
||||
! Usage: "my/source/tree" codebook
|
||||
|
|
@ -194,8 +194,8 @@ TUPLE: code-file
|
|||
</guide>
|
||||
</package> XML> ;
|
||||
|
||||
: write-dest-file ( xml dest-dir name ext -- )
|
||||
append append-path utf8 [ write-xml ] with-file-writer ;
|
||||
: write-dest-file ( xml name ext -- )
|
||||
append utf8 [ write-xml ] with-file-writer ;
|
||||
|
||||
SYMBOL: kindlegen-path
|
||||
kindlegen-path [ "kindlegen" ] initialize
|
||||
|
|
@ -216,30 +216,31 @@ codebook-output-path [ "resource:codebooks" ] initialize
|
|||
|
||||
dest-dir make-directories
|
||||
[
|
||||
current-temporary-directory get :> temp-dir
|
||||
src-dir file-name :> name
|
||||
src-dir code-files :> files
|
||||
[
|
||||
src-dir file-name :> name
|
||||
src-dir code-files :> files
|
||||
|
||||
src-dir name files code>opf
|
||||
temp-dir name ".opf" write-dest-file
|
||||
src-dir name files code>opf
|
||||
name ".opf" write-dest-file
|
||||
|
||||
"vocab:codebook/cover.jpg" temp-dir copy-file-into
|
||||
"vocab:codebook/cover.jpg" "." copy-file-into
|
||||
|
||||
src-dir name files code>ncx
|
||||
temp-dir name ".ncx" write-dest-file
|
||||
src-dir name files code>ncx
|
||||
name ".ncx" write-dest-file
|
||||
|
||||
src-dir name files code>toc-html
|
||||
temp-dir "_toc.html" "" write-dest-file
|
||||
src-dir name files code>toc-html
|
||||
"_toc.html" "" write-dest-file
|
||||
|
||||
files [| file |
|
||||
src-dir file code>html
|
||||
temp-dir file name>> file-html-name "" write-dest-file
|
||||
] each
|
||||
files [| file |
|
||||
src-dir file code>html
|
||||
file name>> file-html-name "" write-dest-file
|
||||
] each
|
||||
|
||||
temp-dir name ".opf" kindle-path kindlegen
|
||||
temp-dir name ".mobi" kindle-path dest-dir copy-file-into
|
||||
"." name ".opf" kindle-path kindlegen
|
||||
"." name ".mobi" kindle-path dest-dir copy-file-into
|
||||
|
||||
dest-dir name ".mobi" kindle-path :> mobi-path
|
||||
dest-dir name ".mobi" kindle-path :> mobi-path
|
||||
|
||||
"Job's finished: " write mobi-path print flush
|
||||
] cleanup-unique-working-directory ;
|
||||
"Job's finished: " write mobi-path print flush
|
||||
] cleanup-unique-directory
|
||||
] with-temp-directory ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2010 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs combinators fry grouping http.client io
|
||||
io.encodings.binary io.files io.files.unique json.reader kernel
|
||||
locals make namespaces sequences urls ;
|
||||
io.encodings.binary io.files io.files.temp io.files.unique
|
||||
json.reader kernel locals make namespaces sequences urls ;
|
||||
IN: google.translate
|
||||
|
||||
CONSTANT: google-translate-url "http://ajax.googleapis.com/ajax/services/language/translate"
|
||||
|
|
@ -53,8 +53,9 @@ TUPLE: response-error response error ;
|
|||
|
||||
: translate-tts ( text -- file )
|
||||
"http://translate.google.com/translate_tts?tl=en" >url
|
||||
swap "q" set-query-param "" ".mp3" make-unique-file
|
||||
[ download-to ] keep ;
|
||||
swap "q" set-query-param [
|
||||
"" ".mp3" unique-file [ download-to ] keep
|
||||
] with-temp-directory ;
|
||||
|
||||
! Example:
|
||||
! "dog" "en" "de" translate .
|
||||
|
|
|
|||
|
|
@ -116,13 +116,15 @@ PRIVATE>
|
|||
} case ;
|
||||
|
||||
:: with-preview ( graph quot: ( path -- ) -- )
|
||||
"preview" ".dot" [| code-file |
|
||||
"preview" preview-extension [| image-file |
|
||||
graph code-file ?encoding write-dot
|
||||
code-file image-file try-preview-command
|
||||
image-file quot call( path -- )
|
||||
[
|
||||
"preview" ".dot" [| code-file |
|
||||
"preview" preview-extension [| image-file |
|
||||
graph code-file ?encoding write-dot
|
||||
code-file image-file try-preview-command
|
||||
image-file quot call( path -- )
|
||||
] cleanup-unique-file
|
||||
] cleanup-unique-file
|
||||
] cleanup-unique-file ;
|
||||
] with-temp-directory ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image bootstrap.image.download io
|
||||
io.directories io.directories.hierarchy io.files.unique
|
||||
io.launcher io.pathnames kernel namespaces sequences
|
||||
mason.common mason.config webapps.mason.version.files ;
|
||||
io.directories io.directories.hierarchy io.files.temp
|
||||
io.files.unique io.launcher io.pathnames kernel namespaces
|
||||
sequences mason.common mason.config webapps.mason.version.files ;
|
||||
IN: webapps.mason.version.source
|
||||
|
||||
: clone-factor ( -- )
|
||||
|
|
@ -34,13 +34,12 @@ IN: webapps.mason.version.source
|
|||
[ suffix "factor" suffix try-process ] keep ;
|
||||
|
||||
: make-source-release ( version git-id -- path )
|
||||
"Creating source release..." print flush
|
||||
[
|
||||
current-temporary-directory get [
|
||||
"Creating source release..." print flush [
|
||||
[
|
||||
clone-factor prepare-source (make-source-release)
|
||||
"Package created: " write absolute-path dup print
|
||||
] with-directory
|
||||
] with-unique-directory drop ;
|
||||
] with-unique-directory drop
|
||||
] with-temp-directory ;
|
||||
|
||||
: upload-source-release ( package version -- )
|
||||
"Uploading source release..." print flush
|
||||
|
|
|
|||
Loading…
Reference in New Issue