steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

io.files.unique: change to create unique files and directories relative to the current-directory.

locals-and-roots
John Benediktsson 2016-03-18 10:57:54 -07:00
parent f5b31a85c0
commit baae677276
19 changed files with 352 additions and 352 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
basis/bootstrap/image/upload/upload.factor
View File

@ -59,26 +59,27 @@ M: windows scp-name "pscp" ;
] change-file-lines ; ] change-file-lines ;
: with-build-images ( quot -- ) : 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 boot images
! Copy checksums _ "." copy-files-into
checksums-path current-temporary-directory get copy-file-into ! Copy checksums
current-temporary-directory get [ checksums-path "." copy-file-into
! Rewrite checksum lines with build number ! Rewrite checksum lines with build number
checksum-lines-append-build checksum-lines-append-build
! Rename file to file.build-number ! Rename file to file.build-number
current-directory get directory-files [ dup append-build move-file ] each "." directory-files [ dup append-build move-file ] each
! Run the quot in the current-directory, which is the unique directory ! Run the quot in the unique directory
@ @
] with-directory ] cleanup-unique-directory
] cleanup-unique-directory ; inline ] with-temp-directory ; inline
: upload-build-images ( -- ) : upload-build-images ( -- )
[ [
[ [
\ scp-name get-global scp-name or , \ scp-name get-global scp-name or ,
current-directory get directory-files % "." directory-files %
build-destination , build-destination ,
] { } make try-process ] { } make try-process
] with-build-images ; ] with-build-images ;

15
basis/csv/csv-tests.factor
View File

@ -79,14 +79,19 @@ IN: csv.tests
{ { { "writing" "some" "csv" "tests" } } } { { { "writing" "some" "csv" "tests" } } }
[ [
"writing,some,csv,tests" [
"csv-test1-" unique-file utf8 "writing,some,csv,tests"
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri "csv-test1-" ".csv" unique-file utf8
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
] with-temp-directory
] unit-test ] unit-test
{ t } [ { 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 ] unit-test
{ { { "hello" "" "" "" "goodbye" "" } } } { { { "hello" "" "" "" "goodbye" "" } } }

37
basis/db/errors/sqlite/sqlite-tests.factor
View File

@ -1,26 +1,29 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit db db.errors USING: accessors combinators.short-circuit db db.errors
db.errors.sqlite db.sqlite io.files.unique kernel namespaces db.errors.sqlite db.sqlite io.files.temp io.files.unique kernel
tools.test ; namespaces tools.test ;
IN: db.errors.sqlite.tests 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 "insert into foo (id) values('1');" sql-command
] [ ] [
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&& { [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
] must-fail-with ] must-fail-with
[ "create table foo(id);" sql-command
"create table foo(id);" sql-command
"create table foo(id);" sql-command
] [
{ [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
] must-fail-with
] 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

35
basis/ftp/server/server-tests.factor
View File

@ -10,26 +10,30 @@ CONSTANT: test-file-contents "Files are so boring anymore."
: create-test-file ( -- path ) : create-test-file ( -- path )
test-file-contents test-file-contents
"ftp.server" "test" make-unique-file "ftp.server" "test" unique-file
[ ascii set-file-contents ] [ normalize-path ] bi ; [ ascii set-file-contents ] [ normalize-path ] bi ;
: test-ftp-server ( quot -- ) : test-ftp-server ( quot -- )
'[ [
current-temporary-directory get '[
0 <ftp-server> [ "." 0 <ftp-server> [
"ftp://localhost" >url insecure-addr set-url-addr "ftp://localhost" >url insecure-addr set-url-addr
"ftp" >>protocol "ftp" >>protocol
create-test-file >>path create-test-file >>path
@ @
] with-threaded-server ] with-threaded-server
] cleanup-unique-directory ; inline ] cleanup-unique-directory
] with-temp-directory ; inline
{ t } { 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 = ] test-ftp-server test-file-contents =
] unit-test ] unit-test
@ -38,7 +42,10 @@ CONSTANT: test-file-contents "Files are so boring anymore."
[ [
"/" >>path "/" >>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 = ] test-ftp-server test-file-contents =
] must-fail ] must-fail

29
basis/io/directories/search/search-tests.factor
View File

@ -6,9 +6,11 @@ IN: io.directories.search.tests
{ t } [ { t } [
[ [
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate [
current-temporary-directory get [ ] find-all-files 10 [ "io.paths.test" "gogogo" unique-file ] replicate
] cleanup-unique-directory [ natural-sort ] same? "." [ ] find-all-files
] cleanup-unique-directory [ natural-sort ] same?
] with-temp-directory
] unit-test ] unit-test
{ f } [ { f } [
@ -23,17 +25,22 @@ IN: io.directories.search.tests
{ t } [ { t } [
[ [
current-temporary-directory get [
"the-head" unique-file drop t "the-head" "" unique-file drop
[ file-name "the-head" head? ] find-file string? "." t [ file-name "the-head" head? ] find-file string?
] cleanup-unique-directory ] cleanup-unique-directory
] with-temp-directory
] unit-test ] unit-test
{ t } [ { t } [
[ unique-directory unique-directory ] output>array [
[ [ "abcd" append-path touch-file ] each ] [
[ [ file-name "abcd" = ] find-all-in-directories length 2 = ] [ unique-directory unique-directory ] output>array
[ [ delete-tree ] each ] tri [ [ "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 ] unit-test
{ t } [ { t } [

22
basis/io/files/links/unix/unix-tests.factor
View File

@ -9,30 +9,30 @@ IN: io.files.links.unix.tests
{ t } [ { t } [
[ [
current-temporary-directory get [ [
5 "lol" make-test-links 5 "lol" make-test-links
"lol1" follow-links "lol1" follow-links
current-temporary-directory get "lol5" append-path = "lol5" absolute-path =
] with-directory ] cleanup-unique-directory
] cleanup-unique-directory ] with-temp-directory
] unit-test ] unit-test
[ [
[ [
current-temporary-directory get [ [
100 "laf" make-test-links "laf1" follow-links 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 ] [ too-many-symlinks? ] must-fail-with
{ t } [ { t } [
110 symlink-depth [ 110 symlink-depth [
[ [
current-temporary-directory get [ [
100 "laf" make-test-links 100 "laf" make-test-links
"laf1" follow-links "laf1" follow-links
current-temporary-directory get "laf100" append-path = "laf100" absolute-path =
] with-directory ] cleanup-unique-directory
] cleanup-unique-directory ] with-temp-directory
] with-variable ] with-variable
] unit-test ] unit-test

95
basis/io/files/unique/unique-docs.factor
View File

@ -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 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 HELP: touch-unique-file
{ $values { $values { "path" "a pathname string" } }
{ "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." } ; { $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 HELP: unique-length
@ -21,92 +14,46 @@ HELP: unique-retries
{ unique-length unique-retries } related-words { unique-length unique-retries } related-words
HELP: make-unique-file HELP: unique-file
{ $values { "prefix" string } { "suffix" string } { $values { "prefix" string } { "suffix" string } { "path" "a pathname 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." }
{ $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 " { $link unique-retries } " number of tries. The most likely error is incorrect directory permissions on the " { $link current-directory } "." } ;
{ $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." } ;
{ unique-file make-unique-file cleanup-unique-file } related-words { unique-file cleanup-unique-file } related-words
HELP: cleanup-unique-file HELP: cleanup-unique-file
{ $values { "prefix" string } { "suffix" string } { $values { "prefix" string } { "suffix" string } { "quot" { $quotation ( path -- ) } } }
{ "quot" quotation } } { $description "Creates a file with " { $link unique-file } " and calls the quotation with the path name on the stack." }
{ $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, even if an error is thrown in the quotation." } ;
{ $notes "The unique file will be deleted after calling this word." } ;
HELP: unique-directory HELP: unique-directory
{ $values { "path" "a pathname string" } } { $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." } { $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 number of tries " { $link unique-retries } ". The most likely error is incorrect directory permissions on the temporary directory." } ; { $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 HELP: cleanup-unique-directory
{ $values { "quot" quotation } } { $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." } { $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 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." } ; { $notes "The unique directory will be deleted after calling this word, even if an error is thrown in the quotation." } ;
HELP: with-unique-directory { unique-directory with-unique-directory cleanup-unique-directory } related-words
{ $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." } ;
ARTICLE: "io.files.unique" "Unique files" 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 "The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in a high-level and secure way." $nl
"Changing the temporary path:"
{ $subsections current-temporary-directory }
"Creating unique files:" "Creating unique files:"
{ $subsections { $subsections
unique-file unique-file
cleanup-unique-file cleanup-unique-file
make-unique-file
} }
"Creating unique directories:" "Creating unique directories:"
{ $subsections { $subsections
unique-directory unique-directory
with-unique-directory with-unique-directory
cleanup-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" ABOUT: "io.files.unique"

71
basis/io/files/unique/unique-tests.factor
View File

@ -1,41 +1,54 @@
USING: io.encodings.ascii sequences strings io io.files accessors USING: accessors continuations io.directories io.encodings.ascii
tools.test kernel io.files.unique namespaces continuations io.files io.files.info io.files.unique io.pathnames kernel
io.files.info io.pathnames io.directories ; namespaces sequences strings tools.test ;
IN: io.files.unique.tests IN: io.files.unique.tests
{ 123 } [ { 123 } [
"core" ".test" [ [
[ [ 123 CHAR: a <string> ] dip ascii set-file-contents ] "core" ".test" [
[ file-info size>> ] bi [ [ 123 CHAR: a <string> ] dip ascii set-file-contents ]
] cleanup-unique-file [ file-info size>> ] bi
] unit-test ] cleanup-unique-file
] with-temp-directory
{ 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 =
] unit-test ] unit-test
{ t } [ { t } [
[ [
"asdf" unique-file drop [ current-directory get file-info directory? ]
"asdf2" unique-file drop cleanup-unique-directory
current-temporary-directory get directory-files length 2 = ] with-temp-directory
] cleanup-unique-directory
] unit-test
{ t } [
[ ] with-unique-directory >boolean
] unit-test ] unit-test
{ t } [ { t } [
[ [
"asdf" unique-file drop current-directory get
"asdf" unique-file drop [ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover
current-temporary-directory get directory-files length 2 = current-directory get =
] with-unique-directory drop ] 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 ] unit-test

70
basis/io/files/unique/unique.factor
View File

@ -1,28 +1,25 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators continuations fry io io.backend USING: combinators continuations fry io.backend io.directories
io.directories io.directories.hierarchy io.files io.pathnames io.directories.hierarchy io.pathnames kernel locals namespaces
kernel locals math math.bitwise math.parser namespaces random random.data sequences system vocabs ;
sequences system vocabs random.data ;
IN: io.files.unique IN: io.files.unique
<PRIVATE
HOOK: (touch-unique-file) io-backend ( path -- ) HOOK: (touch-unique-file) io-backend ( path -- )
PRIVATE>
: touch-unique-file ( path -- ) : touch-unique-file ( path -- )
normalize-path (touch-unique-file) ; normalize-path (touch-unique-file) ;
HOOK: default-temporary-directory io-backend ( -- path )
SYMBOL: current-temporary-directory
SYMBOL: unique-length SYMBOL: unique-length
SYMBOL: unique-retries SYMBOL: unique-retries
10 unique-length set-global 10 unique-length set-global
10 unique-retries set-global 10 unique-retries set-global
: with-temporary-directory ( path quot -- )
[ current-temporary-directory ] dip with-variable ; inline
<PRIVATE <PRIVATE
: random-file-name ( -- string ) : random-file-name ( -- string )
@ -31,54 +28,37 @@ SYMBOL: unique-retries
: retry ( quot: ( -- ? ) n -- ) : retry ( quot: ( -- ? ) n -- )
iota swap [ drop ] prepose attempt-all ; inline 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 dup touch-unique-file
] unique-retries get retry ; ] unique-retries get retry ;
PRIVATE> :: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
prefix suffix unique-file :> path
: make-unique-file ( prefix suffix -- path ) [ path quot call ] [ path delete-file ] [ ] cleanup ; inline
[ current-temporary-directory get ] 2dip (make-unique-file) ;
: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
[ make-unique-file ] dip [ delete-file ] bi ; inline
: unique-directory ( -- path ) : unique-directory ( -- path )
[ [
current-temporary-directory get current-directory get
random-file-name append-path random-file-name append-path
dup make-directory dup make-directory
] unique-retries get retry ; ] unique-retries get retry ;
: with-unique-directory ( quot -- path ) :: 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 -- )
unique-directory :> path unique-directory :> path
path [ path quot with-temporary-directory ] with-directory path quot with-directory
path delete-tree ; inline 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 unix? ] [ "io.files.unique.unix" ] }
{ [ os windows? ] [ "io.files.unique.windows" ] } { [ os windows? ] [ "io.files.unique.windows" ] }
} cond require } cond require
default-temporary-directory current-temporary-directory set-global

6
basis/io/files/unique/unix/unix.factor
View File

@ -1,12 +1,10 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.backend.unix math.bitwise USING: io.backend.unix io.files.unique.private literals system
unix system io.files.unique unix.ffi literals ; unix unix.ffi ;
IN: io.files.unique.unix IN: io.files.unique.unix
CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL } CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
M: unix (touch-unique-file) ( path -- ) M: unix (touch-unique-file) ( path -- )
open-unique-flags file-mode open-file close-file ; open-unique-flags file-mode open-file close-file ;
M: unix default-temporary-directory ( -- path ) "/tmp" ;

7
basis/io/files/unique/windows/windows.factor
View File

@ -1,9 +1,6 @@
USING: destructors environment io.files.unique io.files.windows USING: destructors environment io.files.unique.private
system windows.kernel32 ; io.files.windows system windows.kernel32 ;
IN: io.files.unique.windows 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 ; GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
M: windows default-temporary-directory ( -- path )
"TEMP" os-env ;

20
basis/io/launcher/windows/windows-tests.factor
View File

@ -82,7 +82,8 @@ SYMBOLS: out-path err-path ;
[ ] [ [ ] [
<process> <process>
console-vm-path "-run=hello-world" 2array >>command 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 try-process
] unit-test ] unit-test
@ -105,8 +106,10 @@ SYMBOLS: out-path err-path ;
launcher-test-path [ launcher-test-path [
<process> <process>
console-vm-path "-script" "stderr.factor" 3array >>command 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
"err.txt" unique-file [ err-path set-global ] keep >>stderr [ out-path set-global ] keep >>stdout
[ "err" ".txt" unique-file ] with-temp-directory
[ err-path set-global ] keep >>stderr
try-process try-process
] with-directory ] with-directory
] unit-test ] unit-test
@ -123,7 +126,8 @@ SYMBOLS: out-path err-path ;
launcher-test-path [ launcher-test-path [
<process> <process>
console-vm-path "-script" "stderr.factor" 3array >>command 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 +stdout+ >>stderr
try-process try-process
] with-directory ] with-directory
@ -137,7 +141,8 @@ SYMBOLS: out-path err-path ;
launcher-test-path [ launcher-test-path [
<process> <process>
console-vm-path "-script" "stderr.factor" 3array >>command 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 utf8 <process-reader> stream-lines first
] with-directory ] with-directory
] unit-test ] unit-test
@ -197,7 +202,8 @@ SYMBOLS: out-path err-path ;
[ ] [ [ ] [
<process> <process>
"cmd.exe /c dir" >>command "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 try-process
] unit-test ] unit-test
@ -205,7 +211,7 @@ SYMBOLS: out-path err-path ;
] times ] times
{ "Hello appender\r\nÖrjan ågren är åter\r\nHello appender\r\nÖrjan ågren är åter\r\n" } [ { "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 [ 2 [
launcher-test-path [ launcher-test-path [
<process> <process>

6
basis/mime/multipart/multipart-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs continuations fry http.server io 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 io.servers io.streams.duplex io.streams.string
kernel math.ranges mime.multipart multiline namespaces random kernel math.ranges mime.multipart multiline namespaces random
sequences sorting strings threads tools.test ; sequences sorting strings threads tools.test ;
@ -13,8 +13,8 @@ CONSTANT: upload1 "------WebKitFormBoundary6odjpVPXIighAE2L\r\nContent-Dispositi
: mime-test-stream ( -- stream ) : mime-test-stream ( -- stream )
upload1 upload1
"mime" "test" make-unique-file ascii [ "mime" "test" unique-file ] with-temp-directory
[ set-file-contents ] [ <file-reader> ] 2bi ; ascii [ set-file-contents ] [ <file-reader> ] 2bi ;
{ } [ mime-test-stream [ ] with-input-stream ] unit-test { } [ mime-test-stream [ ] with-input-stream ] unit-test

6
basis/mime/multipart/multipart.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii assocs byte-arrays combinators fry USING: accessors ascii assocs byte-arrays combinators fry
hashtables http http.parsers io io.encodings.binary io.files hashtables http http.parsers io io.encodings.binary io.files
io.files.unique io.streams.string kernel math quoting sequences io.files.temp io.files.unique io.streams.string kernel math
splitting ; quoting sequences splitting ;
IN: mime.multipart IN: mime.multipart
CONSTANT: buffer-size 65536 CONSTANT: buffer-size 65536
@ -94,7 +94,7 @@ C: <mime-variable> mime-variable
] with-output-stream ; ] with-output-stream ;
: dump-file ( multipart -- multipart ) : dump-file ( multipart -- multipart )
"factor-" "-upload" make-unique-file [ "factor-" "-upload" unique-file ] with-temp-directory
[ >>temp-file ] [ dump-mime-file ] bi ; [ >>temp-file ] [ dump-mime-file ] bi ;
: parse-content-disposition-form-data ( string -- hashtable ) : parse-content-disposition-form-data ( string -- hashtable )

175
core/io/files/files-tests.factor
View File

@ -157,91 +157,116 @@ CONSTANT: pt-array-1
! File seeking tests ! File seeking tests
{ B{ 3 2 3 4 5 } } { B{ 3 2 3 4 5 } }
[ [
"seek-test1" unique-file binary
[ [
[ "seek-test1" "" [
B{ 1 2 3 4 5 } write binary
tell-output 5 assert= [
0 seek-absolute seek-output [
tell-output 0 assert= B{ 1 2 3 4 5 } write
B{ 3 } write tell-output 5 assert=
tell-output 1 assert= 0 seek-absolute seek-output
] with-file-writer tell-output 0 assert=
] [ B{ 3 } write
file-contents tell-output 1 assert=
] 2bi ] with-file-writer
] [
file-contents
] 2bi
] cleanup-unique-file
] with-temp-directory
] unit-test ] unit-test
{ B{ 1 2 3 4 3 } } { B{ 1 2 3 4 3 } }
[ [
"seek-test2" unique-file binary
[ [
[ "seek-test2" "" [
B{ 1 2 3 4 5 } write binary
tell-output 5 assert= [
-1 seek-relative seek-output [
tell-output 4 assert= B{ 1 2 3 4 5 } write
B{ 3 } write tell-output 5 assert=
tell-output 5 assert= -1 seek-relative seek-output
] with-file-writer tell-output 4 assert=
] [ B{ 3 } write
file-contents tell-output 5 assert=
] 2bi ] with-file-writer
] [
file-contents
] 2bi
] cleanup-unique-file
] with-temp-directory
] unit-test ] unit-test
{ B{ 1 2 3 4 5 0 3 } } { B{ 1 2 3 4 5 0 3 } }
[ [
"seek-test3" unique-file binary
[ [
[ "seek-test3" "" [
B{ 1 2 3 4 5 } write binary
tell-output 5 assert= [
1 seek-relative seek-output [
tell-output 6 assert= B{ 1 2 3 4 5 } write
B{ 3 } write tell-output 5 assert=
tell-output 7 assert= 1 seek-relative seek-output
] with-file-writer tell-output 6 assert=
] [ B{ 3 } write
file-contents tell-output 7 assert=
] 2bi ] with-file-writer
] [
file-contents
] 2bi
] cleanup-unique-file
] with-temp-directory
] unit-test ] unit-test
{ B{ 3 } } { B{ 3 } }
[ [
B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ [
set-file-contents "seek-test4" "" [
] [ B{ 1 2 3 4 5 } swap binary
[ [
tell-input 0 assert= set-file-contents
-3 seek-end seek-input ] [
tell-input 2 assert= [
1 read tell-input 0 assert=
tell-input 3 assert= -3 seek-end seek-input
] with-file-reader tell-input 2 assert=
] 2bi 1 read
tell-input 3 assert=
] with-file-reader
] 2bi
] cleanup-unique-file
] with-temp-directory
] unit-test ] unit-test
{ B{ 2 } } { B{ 2 } }
[ [
B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ [
set-file-contents "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= tell-input 0 assert=
-2 seek-relative seek-input 3 seek-absolute seek-input
tell-input 1 assert= tell-input 3 assert=
1 read -2 seek-relative seek-input
tell-input 2 assert= tell-input 1 assert=
] with-file-reader 1 read
] 2bi tell-input 2 assert=
] with-file-reader
] 2bi
] cleanup-unique-file
] with-temp-directory
] unit-test ] unit-test
[ [
"seek-test6" unique-file binary [ [
-10 seek-absolute seek-input "seek-test6" "" [
] with-file-reader binary [
-10 seek-absolute seek-input
] with-file-reader
] cleanup-unique-file
] with-temp-directory
] must-fail ] must-fail
{ } [ { } [
@ -254,21 +279,29 @@ CONSTANT: pt-array-1
] unit-test ] unit-test
[ [
"non-string-error" unique-file ascii [ [
{ } write "non-string-error" "" [
] with-file-writer ascii [ { } write ] with-file-writer
] cleanup-unique-file
] with-temp-directory
] [ no-method? ] must-fail-with ] [ no-method? ] must-fail-with
[ [
"non-byte-array-error" unique-file binary [ [
"" write "non-byte-array-error" "" [
] with-file-writer binary [ "" write ] with-file-writer
] cleanup-unique-file
] with-temp-directory
] [ no-method? ] must-fail-with ] [ no-method? ] must-fail-with
! What happens if we close a file twice? ! 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 ] unit-test
! Test cwd, cd. You do not want to use with-cd, you want with-directory. ! Test cwd, cd. You do not want to use with-cd, you want with-directory.

51
extra/codebook/codebook.factor
View File

@ -3,10 +3,10 @@ USING: accessors arrays assocs calendar calendar.format
combinators combinators.short-circuit fry io io.backend combinators combinators.short-circuit fry io io.backend
io.directories io.directories.hierarchy io.encodings.binary io.directories io.directories.hierarchy io.encodings.binary
io.encodings.detect io.encodings.utf8 io.files io.files.info io.encodings.detect io.encodings.utf8 io.files io.files.info
io.files.types io.files.unique io.launcher io.pathnames kernel io.files.temp io.files.types io.files.unique io.launcher
locals math math.parser namespaces sequences sorting strings io.pathnames kernel locals math math.parser namespaces sequences
system unicode.categories xml.syntax xml.writer xmode.catalog sorting strings system unicode.categories xml.syntax xml.writer
xmode.marker xmode.tokens ; xmode.catalog xmode.marker xmode.tokens ;
IN: codebook IN: codebook
! Usage: "my/source/tree" codebook ! Usage: "my/source/tree" codebook
@ -194,8 +194,8 @@ TUPLE: code-file
</guide> </guide>
</package> XML> ; </package> XML> ;
: write-dest-file ( xml dest-dir name ext -- ) : write-dest-file ( xml name ext -- )
append append-path utf8 [ write-xml ] with-file-writer ; append utf8 [ write-xml ] with-file-writer ;
SYMBOL: kindlegen-path SYMBOL: kindlegen-path
kindlegen-path [ "kindlegen" ] initialize kindlegen-path [ "kindlegen" ] initialize
@ -216,30 +216,31 @@ codebook-output-path [ "resource:codebooks" ] initialize
dest-dir make-directories dest-dir make-directories
[ [
current-temporary-directory get :> temp-dir [
src-dir file-name :> name src-dir file-name :> name
src-dir code-files :> files src-dir code-files :> files
src-dir name files code>opf src-dir name files code>opf
temp-dir name ".opf" write-dest-file 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 src-dir name files code>ncx
temp-dir name ".ncx" write-dest-file name ".ncx" write-dest-file
src-dir name files code>toc-html src-dir name files code>toc-html
temp-dir "_toc.html" "" write-dest-file "_toc.html" "" write-dest-file
files [| file | files [| file |
src-dir file code>html src-dir file code>html
temp-dir file name>> file-html-name "" write-dest-file file name>> file-html-name "" write-dest-file
] each ] each
temp-dir name ".opf" kindle-path kindlegen "." name ".opf" kindle-path kindlegen
temp-dir name ".mobi" kindle-path dest-dir copy-file-into "." 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 "Job's finished: " write mobi-path print flush
] cleanup-unique-working-directory ; ] cleanup-unique-directory
] with-temp-directory ;

9
extra/google/translate/translate.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2010 Doug Coleman. ! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators fry grouping http.client io USING: assocs combinators fry grouping http.client io
io.encodings.binary io.files io.files.unique json.reader kernel io.encodings.binary io.files io.files.temp io.files.unique
locals make namespaces sequences urls ; json.reader kernel locals make namespaces sequences urls ;
IN: google.translate IN: google.translate
CONSTANT: google-translate-url "http://ajax.googleapis.com/ajax/services/language/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 ) : translate-tts ( text -- file )
"http://translate.google.com/translate_tts?tl=en" >url "http://translate.google.com/translate_tts?tl=en" >url
swap "q" set-query-param "" ".mp3" make-unique-file swap "q" set-query-param [
[ download-to ] keep ; "" ".mp3" unique-file [ download-to ] keep
] with-temp-directory ;
! Example: ! Example:
! "dog" "en" "de" translate . ! "dog" "en" "de" translate .

14
extra/graphviz/render/render.factor
View File

@ -116,13 +116,15 @@ PRIVATE>
} case ; } case ;
:: with-preview ( graph quot: ( path -- ) -- ) :: with-preview ( graph quot: ( path -- ) -- )
"preview" ".dot" [| code-file | [
"preview" preview-extension [| image-file | "preview" ".dot" [| code-file |
graph code-file ?encoding write-dot "preview" preview-extension [| image-file |
code-file image-file try-preview-command graph code-file ?encoding write-dot
image-file quot call( path -- ) code-file image-file try-preview-command
image-file quot call( path -- )
] cleanup-unique-file
] cleanup-unique-file ] cleanup-unique-file
] cleanup-unique-file ; ] with-temp-directory ;
PRIVATE> PRIVATE>

15
extra/webapps/mason/version/source/source.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2010 Slava Pestov. ! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image bootstrap.image.download io USING: bootstrap.image bootstrap.image.download io
io.directories io.directories.hierarchy io.files.unique io.directories io.directories.hierarchy io.files.temp
io.launcher io.pathnames kernel namespaces sequences io.files.unique io.launcher io.pathnames kernel namespaces
mason.common mason.config webapps.mason.version.files ; sequences mason.common mason.config webapps.mason.version.files ;
IN: webapps.mason.version.source IN: webapps.mason.version.source
: clone-factor ( -- ) : clone-factor ( -- )
@ -34,13 +34,12 @@ IN: webapps.mason.version.source
[ suffix "factor" suffix try-process ] keep ; [ suffix "factor" suffix try-process ] keep ;
: make-source-release ( version git-id -- path ) : make-source-release ( version git-id -- path )
"Creating source release..." print flush "Creating source release..." print flush [
[ [
current-temporary-directory get [
clone-factor prepare-source (make-source-release) clone-factor prepare-source (make-source-release)
"Package created: " write absolute-path dup print "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 -- ) : upload-source-release ( package version -- )
"Uploading source release..." print flush "Uploading source release..." print flush