basis/io/files/unique/unique.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators continuations fry io.backend io.directories
   4 io.directories.hierarchy io.pathnames kernel locals namespaces
   5 random.data sequences system vocabs ;
   6 IN: io.files.unique
   7
   8 <PRIVATE
   9
  10 HOOK: (touch-unique-file) io-backend ( path -- )
  11
  12 PRIVATE>
  13
  14 : touch-unique-file ( path -- )
  15     normalize-path (touch-unique-file) ;
  16
  17 SYMBOL: unique-length
  18 SYMBOL: unique-retries
  19
  20 10 unique-length set-global
  21 10 unique-retries set-global
  22
  23 <PRIVATE
  24
  25 : random-file-name ( -- string )
  26     unique-length get random-string ;
  27
  28 : retry ( quot: ( -- ? ) n -- )
  29     <iota> swap [ drop ] prepose attempt-all ; inline
  30
  31 PRIVATE>
  32
  33 : unique-file ( prefix suffix -- path )
  34     '[
  35         _ _ random-file-name glue
  36         dup touch-unique-file
  37     ] unique-retries get retry absolute-path ;
  38
  39 : unique-files ( prefix suffixes -- paths )
  40     '[
  41         V{ } clone [
  42             _ _ random-file-name '[
  43                 _ glue
  44                 dup touch-unique-file suffix!
  45             ] with each { } like
  46         ] [
  47             [ [ delete-file ] each ] [ rethrow ] bi*
  48         ] recover
  49     ] unique-retries get retry [ absolute-path ] map ;
  50
  51 :: cleanup-unique-file ( ..a prefix suffix quot: ( ..a path -- ..b ) -- ..b )
  52     prefix suffix unique-file :> path
  53     [ path quot call ] [ path delete-file ] [ ] cleanup ; inline
  54
  55 :: cleanup-unique-files ( ..a prefix suffixes quot: ( ..a paths -- ..b ) -- ..b )
  56     prefix suffixes unique-files :> paths
  57     [ paths quot call ] [ paths [ delete-file ] each ] [ ] cleanup ; inline
  58
  59 : unique-directory ( -- path )
  60     [
  61         random-file-name
  62         dup make-directory
  63     ] unique-retries get retry absolute-path ;
  64
  65 :: with-unique-directory ( quot -- path )
  66     unique-directory :> path
  67     path quot with-directory
  68     path ; inline
  69
  70 :: cleanup-unique-directory ( quot -- )
  71     unique-directory :> path
  72     [ path quot with-directory ]
  73     [ path delete-tree ] [ ] cleanup ; inline
  74
  75 {
  76     { [ os unix? ] [ "io.files.unique.unix" ] }
  77     { [ os windows? ] [ "io.files.unique.windows" ] }
  78 } cond require