basis/io/files/unique/unique.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays combinators continuations fry io io.backend
   4 io.directories io.directories.hierarchy io.files io.pathnames
   5 kernel math math.bitwise math.parser namespaces random
   6 sequences system vocabs.loader ;
   7 IN: io.files.unique
   8
   9 HOOK: touch-unique-file io-backend ( path -- )
  10 HOOK: temporary-path io-backend ( -- path )
  11
  12 SYMBOL: unique-length
  13 SYMBOL: unique-retries
  14
  15 10 unique-length set-global
  16 10 unique-retries set-global
  17
  18 <PRIVATE
  19
  20 : random-letter ( -- ch )
  21     26 random { CHAR: a CHAR: A } random + ;
  22
  23 : random-ch ( -- ch )
  24     { t f } random
  25     [ 10 random CHAR: 0 + ] [ random-letter ] if ;
  26
  27 : random-name ( n -- string )
  28     [ random-ch ] "" replicate-as ;
  29
  30 PRIVATE>
  31
  32 : (make-unique-file) ( path prefix suffix -- path )
  33     '[
  34         _ _ _ unique-length get random-name glue append-path
  35         dup touch-unique-file
  36     ] unique-retries get retry ;
  37
  38 : make-unique-file ( prefix suffix -- path )
  39     [ temporary-path ] 2dip (make-unique-file) ;
  40
  41 : make-unique-file* ( prefix suffix -- path )
  42     [ current-directory get ] 2dip (make-unique-file) ;
  43
  44 : with-unique-file ( prefix suffix quot: ( path -- ) -- )
  45     [ make-unique-file ] dip [ delete-file ] bi ; inline
  46
  47 : make-unique-directory ( -- path )
  48     [
  49         temporary-path unique-length get random-name append-path
  50         dup make-directory
  51     ] unique-retries get retry ;
  52
  53 : with-unique-directory ( quot: ( -- ) -- )
  54     [ make-unique-directory ] dip
  55     '[ _ with-directory ] [ delete-tree ] bi ; inline
  56
  57 {
  58     { [ os unix? ] [ "io.files.unique.unix" ] }
  59     { [ os windows? ] [ "io.files.unique.windows" ] }
  60 } cond require