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 : touch-unique-file ( path -- )
  11     normalize-path (touch-unique-file) ;
  12
  13 HOOK: default-temporary-directory io-backend ( -- path )
  14
  15 SYMBOL: current-temporary-directory
  16
  17 SYMBOL: unique-length
  18 SYMBOL: unique-retries
  19
  20 10 unique-length set-global
  21 10 unique-retries set-global
  22
  23 : with-temporary-directory ( path quot -- )
  24     [ current-temporary-directory ] dip with-variable ; inline
  25
  26 <PRIVATE
  27
  28 : random-letter ( -- ch )
  29     26 random { CHAR: a CHAR: A } random + ;
  30
  31 : random-ch ( -- ch )
  32     { t f } random
  33     [ 10 random CHAR: 0 + ] [ random-letter ] if ;
  34
  35 : random-name ( -- string )
  36     unique-length get [ random-ch ] "" replicate-as ;
  37
  38 : (make-unique-file) ( path prefix suffix -- path )
  39     '[
  40         _ _ _ random-name glue append-path
  41         dup touch-unique-file
  42     ] unique-retries get retry ;
  43
  44 PRIVATE>
  45
  46 : make-unique-file ( prefix suffix -- path )
  47     [ current-temporary-directory get ] 2dip (make-unique-file) ;
  48
  49 : cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
  50     [ make-unique-file ] dip [ delete-file ] bi ; inline
  51
  52 : unique-directory ( -- path )
  53     [
  54         current-temporary-directory get
  55         random-name append-path
  56         dup make-directory
  57     ] unique-retries get retry ;
  58
  59 : with-unique-directory ( quot -- path )
  60     [ unique-directory ] dip
  61     [ with-temporary-directory ] [ drop ] 2bi ; inline
  62
  63 : cleanup-unique-directory ( quot: ( -- ) -- )
  64     [ unique-directory ] dip
  65     '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
  66
  67 : unique-file ( path -- path' )
  68     "" make-unique-file ;
  69
  70 {
  71     { [ os unix? ] [ "io.files.unique.unix" ] }
  72     { [ os windows? ] [ "io.files.unique.windows" ] }
  73 } cond require
  74
  75 default-temporary-directory current-temporary-directory set-global