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 locals math math.bitwise math.parser namespaces random
   6 sequences system vocabs random.data ;
   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-file-name ( -- string )
  29     unique-length get random-string ;
  30
  31 : retry ( quot: ( -- ? ) n -- )
  32     iota swap [ drop ] prepose attempt-all ; inline
  33
  34 : (make-unique-file) ( path prefix suffix -- path )
  35     '[
  36         _ _ _ random-file-name glue append-path
  37         dup touch-unique-file
  38     ] unique-retries get retry ;
  39
  40 PRIVATE>
  41
  42 : make-unique-file ( prefix suffix -- path )
  43     [ current-temporary-directory get ] 2dip (make-unique-file) ;
  44
  45 : cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
  46     [ make-unique-file ] dip [ delete-file ] bi ; inline
  47
  48 : unique-directory ( -- path )
  49     [
  50         current-temporary-directory get
  51         random-file-name append-path
  52         dup make-directory
  53     ] unique-retries get retry ;
  54
  55 : with-unique-directory ( quot -- path )
  56     [ unique-directory ] dip
  57     [ with-temporary-directory ] [ drop ] 2bi ; inline
  58
  59 : cleanup-unique-directory ( quot: ( -- ) -- )
  60     [ unique-directory ] dip
  61     '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
  62
  63 : unique-file ( prefix -- path )
  64     "" make-unique-file ;
  65
  66 : move-file-unique ( path prefix suffix -- path' )
  67     make-unique-file [ move-file ] keep ;
  68
  69 : copy-file-unique ( path prefix suffix -- path' )
  70     make-unique-file [ copy-file ] keep ;
  71
  72 : temporary-file ( -- path ) "" unique-file ;
  73
  74 :: cleanup-unique-working-directory ( quot -- )
  75     unique-directory :> path
  76     path [ path quot with-temporary-directory ] with-directory
  77     path delete-tree ; inline
  78
  79 {
  80     { [ os unix? ] [ "io.files.unique.unix" ] }
  81     { [ os windows? ] [ "io.files.unique.windows" ] }
  82 } cond require
  83
  84 default-temporary-directory current-temporary-directory set-global