basis/io/files/unique/unique.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: combinators continuations fry io.backend io.directories
   4 io.files io.pathnames kernel locals namespaces random.data
   5 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 : random-file-name* ( prefix suffix -- string )
  29     unique-length get random-string glue ;
  30
  31 : retry ( quot: ( -- ? ) n -- )
  32     <iota> swap [ drop ] prepose attempt-all ; inline
  33
  34 PRIVATE>
  35
  36 : unique-file ( prefix suffix -- path )
  37     '[
  38         _ _ random-file-name glue
  39         dup touch-unique-file
  40     ] unique-retries get retry absolute-path ;
  41
  42 : unique-files ( prefix suffixes -- paths )
  43     '[
  44         V{ } clone [
  45             _ _ random-file-name '[
  46                 _ glue
  47                 dup touch-unique-file suffix!
  48             ] with each { } like
  49         ] [
  50             [ [ delete-file ] each ] [ rethrow ] bi*
  51         ] recover
  52     ] unique-retries get retry [ absolute-path ] map ;
  53
  54 : with-unique-file-writer ( ..a prefix suffix encoding quot -- ..b path )
  55     [ random-file-name* ] 2dip [ with-file-writer-secure ] keepdd normalize-path ; inline
  56
  57 :: cleanup-unique-file ( ..a prefix suffix quot: ( ..a path -- ..b ) -- ..b )
  58     prefix suffix unique-file :> path
  59     [ path quot call ] [ path delete-file ] finally ; inline
  60
  61 :: cleanup-unique-files ( ..a prefix suffixes quot: ( ..a paths -- ..b ) -- ..b )
  62     prefix suffixes unique-files :> paths
  63     [ paths quot call ] [ paths [ delete-file ] each ] finally ; inline
  64
  65 : unique-directory ( -- path )
  66     [
  67         random-file-name
  68         dup make-directory
  69     ] unique-retries get retry absolute-path ;
  70
  71 :: with-unique-directory ( quot -- path )
  72     unique-directory :> path
  73     path quot with-directory
  74     path ; inline
  75
  76 :: cleanup-unique-directory ( quot -- )
  77     unique-directory :> path
  78     [ path quot with-directory ]
  79     [ path delete-tree ] finally ; inline
  80
  81 {
  82     { [ os unix? ] [ "io.files.unique.unix" ] }
  83     { [ os windows? ] [ "io.files.unique.windows" ] }
  84 } cond require