basis/io/directories/directories.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators destructors io io.backend
   4 io.encodings.binary io.files io.files.types io.pathnames
   5 kernel namespaces sequences system vocabs.loader fry ;
   6 IN: io.directories
   7
   8 : set-current-directory ( path -- )
   9     absolute-path current-directory set ;
  10
  11 : with-directory ( path quot -- )
  12     [ absolute-path current-directory ] dip with-variable ; inline
  13
  14 ! Creating directories
  15 HOOK: make-directory io-backend ( path -- )
  16
  17 : make-directories ( path -- )
  18     normalize-path trim-tail-separators {
  19         { [ dup "." = ] [ ] }
  20         { [ dup root-directory? ] [ ] }
  21         { [ dup empty? ] [ ] }
  22         { [ dup exists? ] [ ] }
  23         [
  24             dup parent-directory make-directories
  25             dup make-directory
  26         ]
  27     } cond drop ;
  28
  29 ! Listing directories
  30 TUPLE: directory-entry name type ;
  31
  32 HOOK: >directory-entry os ( byte-array -- directory-entry )
  33
  34 HOOK: (directory-entries) os ( path -- seq )
  35
  36 : directory-entries ( path -- seq )
  37     normalize-path
  38     (directory-entries)
  39     [ name>> { "." ".." } member? not ] filter ;
  40
  41 : directory-files ( path -- seq )
  42     directory-entries [ name>> ] map ;
  43
  44 : directory-tree-files ( path -- seq )
  45     dup directory-entries
  46     [
  47         dup type>> +directory+ =
  48         [ name>>
  49             [ append-path directory-tree-files ]
  50             [ [ prepend-path ] curry map ]
  51             [ prefix ] tri
  52         ] [ nip name>> 1array ] if
  53     ] with map concat ;
  54
  55 : with-directory-entries ( path quot -- )
  56     '[ "" directory-entries @ ] with-directory ; inline
  57
  58 : with-directory-files ( path quot -- )
  59     '[ "" directory-files @ ] with-directory ; inline
  60
  61 : with-directory-tree-files ( path quot -- )
  62     '[ "" directory-tree-files @ ] with-directory ; inline
  63
  64 ! Touching files
  65 HOOK: touch-file io-backend ( path -- )
  66
  67 ! Deleting files
  68 HOOK: delete-file io-backend ( path -- )
  69
  70 HOOK: delete-directory io-backend ( path -- )
  71
  72 : to-directory ( from to -- from to' )
  73     over file-name append-path ;
  74
  75 ! Moving and renaming files
  76 HOOK: move-file io-backend ( from to -- )
  77
  78 : move-file-into ( from to -- )
  79     to-directory move-file ;
  80
  81 : move-files-into ( files to -- )
  82     '[ _ move-file-into ] each ;
  83
  84 ! Copying files
  85 HOOK: copy-file io-backend ( from to -- )
  86
  87 M: object copy-file
  88     dup parent-directory make-directories
  89     binary <file-writer> [
  90         swap binary <file-reader> [
  91             swap stream-copy
  92         ] with-disposal
  93     ] with-disposal ;
  94
  95 : copy-file-into ( from to -- )
  96     to-directory copy-file ;
  97
  98 : copy-files-into ( files to -- )
  99     '[ _ copy-file-into ] each ;
 100
 101 {
 102     { [ os unix? ] [ "io.directories.unix" require ] }
 103     { [ os windows? ] [ "io.directories.windows" require ] }
 104 } cond