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 assocs combinators
   4 combinators.short-circuit continuations deques destructors
   5 dlists fry io io.backend io.encodings.binary io.files
   6 io.files.info io.files.links io.files.types io.pathnames kernel
   7 kernel.private make math namespaces sequences sorting strings
   8 system unicode vocabs ;
   9 IN: io.directories
  10
  11 : set-current-directory ( path -- )
  12     absolute-path current-directory set ;
  13
  14 : with-directory ( path quot -- )
  15     [ absolute-path current-directory ] dip with-variable ; inline
  16
  17 : with-resource-directory ( quot -- )
  18     [ "resource:" ] dip with-directory ; inline
  19
  20 ! Creating directories
  21 HOOK: make-directory io-backend ( path -- )
  22
  23 DEFER: make-parent-directories
  24
  25 : make-directories ( path -- )
  26     normalize-path trim-tail-separators dup {
  27         [ "." = ]
  28         [ root-directory? ]
  29         [ empty? ]
  30         [ file-exists? ]
  31     } 1|| [
  32         make-parent-directories
  33         dup make-directory
  34     ] unless drop ;
  35
  36 : make-parent-directories ( filename -- filename )
  37     dup parent-directory make-directories ;
  38
  39 : with-ensure-directory ( path quot -- )
  40     [ absolute-path dup make-directories current-directory ] dip with-variable ; inline
  41
  42 ! Listing directories
  43 TUPLE: directory-entry name type ;
  44
  45 C: <directory-entry> directory-entry
  46
  47 HOOK: (directory-entries) os ( path -- seq )
  48
  49 : directory-entries ( path -- seq )
  50     normalize-path
  51     (directory-entries)
  52     [ name>> { "." ".." } member? ] reject ;
  53
  54 : directory-files ( path -- seq )
  55     directory-entries [ name>> ] map! ;
  56
  57 : with-directory-entries ( path quot -- )
  58     '[ "" directory-entries @ ] with-directory ; inline
  59
  60 : with-directory-files ( path quot -- )
  61     '[ "" directory-files @ ] with-directory ; inline
  62
  63 ! Finding directories
  64
  65 : qualified-directory-entries ( path -- seq )
  66     dup directory-entries [ [ append-path ] change-name ] with map! ;
  67
  68 : qualified-directory-files ( path -- seq )
  69     dup directory-files [ append-path ] with map! ;
  70
  71 SYMBOL: traversal-method
  72
  73 SYMBOLS: +depth-first+ +breadth-first+ ;
  74
  75 traversal-method [ +depth-first+ ] initialize
  76
  77 <PRIVATE
  78
  79 TUPLE: directory-iterator
  80 { path string }
  81 { bfs boolean }
  82 { queue dlist } ;
  83
  84 : push-directory-entries ( path iter -- )
  85     { directory-iterator } declare
  86     [ [ qualified-directory-entries ] [ 2drop f ] recover ] dip
  87     [ bfs>> [ [ <reversed> ] unless ] keep ]
  88     [ queue>> swap '[ _ _ [ push-front ] [ push-back ] if ] each ] bi ;
  89
  90 : <directory-iterator> ( path bfs? -- iter )
  91     <dlist> directory-iterator boa
  92     dup path>> over push-directory-entries ;
  93
  94 : next-directory-entry ( iter -- directory-entry/f )
  95     { directory-iterator } declare
  96     dup queue>> deque-empty? [ drop f ] [
  97         dup queue>> pop-back
  98         dup directory?
  99         [ [ name>> swap push-directory-entries ] keep ]
 100         [ nip ] if
 101     ] if ;
 102
 103 : iterate-directory-entries ( ... iter quot: ( ... directory-entry -- ... obj/f ) -- ... obj/f )
 104     over next-directory-entry [
 105         over curry 2dip
 106         [ iterate-directory-entries ] 2curry unless*
 107     ] [
 108         2drop f
 109     ] if* ; inline recursive
 110
 111 : iterate-directory ( iter quot -- path/f )
 112     [ name>> ] prepose iterate-directory-entries ; inline
 113
 114 : bfs? ( -- bfs? )
 115     traversal-method get {
 116         { +breadth-first+ [ t ] }
 117         { +depth-first+ [ f ] }
 118     } case ; inline
 119
 120 : setup-traversal ( path quot -- iter quot' )
 121     [ bfs? <directory-iterator> ] dip [ f ] compose ; inline
 122
 123 PRIVATE>
 124
 125 : each-file ( ... path quot: ( ... name -- ... ) -- ... )
 126     setup-traversal iterate-directory drop ; inline
 127
 128 : each-directory-entry ( path quot: ( ... entry -- ... ) -- )
 129     setup-traversal iterate-directory-entries drop ; inline
 130
 131 : recursive-directory-files ( path -- paths )
 132     [ ] collector [ each-file ] dip ;
 133
 134 : recursive-directory-entries ( path -- directory-entries )
 135     [ ] collector [ each-directory-entry ] dip ;
 136
 137 : find-file ( path quot: ( ... name -- ... ? ) -- path/f )
 138     [ bfs? <directory-iterator> ] dip
 139     '[ _ keep and ] iterate-directory ; inline
 140
 141 : find-files ( path quot: ( ... name -- ... ? ) -- paths )
 142     selector [ each-file ] dip ; inline
 143
 144 ERROR: sequence-expected obj ;
 145
 146 : ensure-sequence-of-directories ( obj -- seq )
 147     dup string? [ 1array ] when
 148     dup sequence? [ sequence-expected ] unless ;
 149
 150 : find-file-in-directories ( directories quot: ( ... name -- ... ? ) -- path'/f )
 151     [ ensure-sequence-of-directories ] dip
 152     '[ _ find-file ] map-find drop ; inline
 153
 154 : find-files-in-directories ( directories quot: ( ... name -- ... ? ) -- paths/f )
 155     [ ensure-sequence-of-directories ] dip
 156     '[ _ find-files ] map concat ; inline
 157
 158 : ?parent-directory ( path -- path'/f )
 159     dup parent-directory 2dup = [ 2drop f ] [ nip ] if ;
 160
 161 : containing-directory ( path -- path' )
 162     dup file-info directory? [ parent-directory ] unless ;
 163
 164 : ?qualified-directory-files ( path -- seq )
 165     [ qualified-directory-files ]
 166     [ drop ?parent-directory [ ?qualified-directory-files ] [ f ] if* ] recover ;
 167
 168 : (find-up-to-root) ( path quot: ( path -- ? ) -- obj )
 169     [ [ ?qualified-directory-files ] dip find swap ] 2keep rot [
 170         2drop
 171     ] [
 172         [ nip ?parent-directory ] dip over
 173         [ (find-up-to-root) ] [ 2drop f ] if
 174     ] if ; inline recursive
 175
 176 : find-up-to-root ( path quot: ( path -- ? ) -- obj )
 177     [ normalize-path containing-directory ] dip (find-up-to-root) ; inline
 178
 179 : link-size/0 ( path -- n )
 180     [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
 181
 182 : directory-size ( path -- n )
 183     0 swap [ link-size/0 + ] each-file ;
 184
 185 : directory-usage ( path -- assoc )
 186     qualified-directory-entries [
 187         [ name>> dup ] [ directory? ] bi
 188         [ directory-size ] [ link-size/0 ] if
 189     ] { } map>assoc sort-values ;
 190
 191 : find-files-by-extensions ( path extensions -- seq )
 192     [ >lower ] map
 193     '[ >lower _ [ tail? ] with any? ] find-files ;
 194
 195 : find-files-by-extension ( path extension -- seq )
 196     1array find-files-by-extensions ;
 197
 198 : find-files-larger-than ( path size -- seq )
 199     '[ link-info size>> _ > ] find-files ;
 200
 201 ! Touching files
 202 HOOK: touch-file io-backend ( path -- )
 203
 204 ! Deleting files
 205 HOOK: delete-file io-backend ( path -- )
 206
 207 HOOK: delete-directory io-backend ( path -- )
 208
 209 : ?delete-file ( path -- )
 210     '[ _ delete-file ] ignore-errors ;
 211
 212 : to-directory ( from to -- from to' )
 213     over file-name append-path ;
 214
 215 ! Moving and renaming files
 216 HOOK: move-file io-backend ( from to -- )
 217 HOOK: move-file-atomically io-backend ( from to -- )
 218
 219 : move-file-into ( from to -- )
 220     to-directory move-file ;
 221
 222 : move-files-into ( files to -- )
 223     '[ _ move-file-into ] each ;
 224
 225 ! Copying files
 226 HOOK: copy-file io-backend ( from to -- )
 227
 228 M: object copy-file
 229     make-parent-directories binary <file-writer> [
 230         swap binary <file-reader> [
 231             swap stream-copy
 232         ] with-disposal
 233     ] with-disposal ;
 234
 235 : copy-file-into ( from to -- )
 236     to-directory copy-file ;
 237
 238 : copy-files-into ( files to -- )
 239     '[ _ copy-file-into ] each ;
 240
 241 : delete-tree ( path -- )
 242     dup link-info directory? [
 243         [ [ [ delete-tree ] each ] with-directory-files ]
 244         [ delete-directory ]
 245         bi
 246     ] [ delete-file ] if ;
 247
 248 DEFER: copy-trees-into
 249
 250 : copy-tree ( from to -- )
 251     normalize-path
 252     over link-info type>>
 253     {
 254         { +symbolic-link+ [ copy-link ] }
 255         { +directory+ [ '[ _ copy-trees-into ] with-directory-files ] }
 256         [ drop copy-file ]
 257     } case ;
 258
 259 : copy-tree-into ( from to -- )
 260     to-directory copy-tree ;
 261
 262 : copy-trees-into ( files to -- )
 263     '[ _ copy-tree-into ] each ;
 264
 265 {
 266     { [ os unix? ] [ "io.directories.unix" require ] }
 267     { [ os windows? ] [ "io.directories.windows" require ] }
 268 } cond