92 lines
2.5 KiB
Factor
92 lines
2.5 KiB
Factor
! 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.loader ;
|
|
IN: io.files.unique
|
|
|
|
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
|
|
|
|
10 unique-length set-global
|
|
10 unique-retries set-global
|
|
|
|
: with-temporary-directory ( path quot -- )
|
|
[ current-temporary-directory ] dip with-variable ; inline
|
|
|
|
<PRIVATE
|
|
|
|
: random-letter ( -- ch )
|
|
26 random { CHAR: a CHAR: A } random + ;
|
|
|
|
: random-ch ( -- ch )
|
|
{ t f } random
|
|
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
|
|
|
|
: random-name ( -- string )
|
|
unique-length get [ random-ch ] "" replicate-as ;
|
|
|
|
: retry ( quot: ( -- ? ) n -- )
|
|
iota swap [ drop ] prepose attempt-all ; inline
|
|
|
|
: (make-unique-file) ( path prefix suffix -- path )
|
|
'[
|
|
_ _ _ random-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
|
|
|
|
: unique-directory ( -- path )
|
|
[
|
|
current-temporary-directory get
|
|
random-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 -- )
|
|
unique-directory :> path
|
|
path [ path quot with-temporary-directory ] with-directory
|
|
path delete-tree ; inline
|
|
|
|
{
|
|
{ [ os unix? ] [ "io.files.unique.unix" ] }
|
|
{ [ os windows? ] [ "io.files.unique.windows" ] }
|
|
} cond require
|
|
|
|
default-temporary-directory current-temporary-directory set-global
|