basis/io/directories/directories.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
   2 ! See https://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     [ pathname> ] dip
  92     <dlist> directory-iterator boa
  93     dup path>> over push-directory-entries ;
  94
  95 : next-directory-entry ( iter -- directory-entry/f )
  96     { directory-iterator } declare
  97     dup queue>> deque-empty? [ drop f ] [
  98         dup queue>> pop-back
  99         dup directory?
 100         [ [ name>> swap push-directory-entries ] keep ]
 101         [ nip ] if
 102     ] if ;
 103
 104 : iterate-directory-entries ( ... iter quot: ( ... directory-entry -- ... obj/f ) -- ... obj/f )
 105     over next-directory-entry [
 106         over curry 2dip
 107         [ iterate-directory-entries ] 2curry unless*
 108     ] [
 109         2drop f
 110     ] if* ; inline recursive
 111
 112 : iterate-directory ( iter quot -- path/f )
 113     [ name>> ] prepose iterate-directory-entries ; inline
 114
 115 : bfs? ( -- bfs? )
 116     traversal-method get {
 117         { +breadth-first+ [ t ] }
 118         { +depth-first+ [ f ] }
 119     } case ; inline
 120
 121 : setup-traversal ( path quot -- iter quot' )
 122     [ bfs? <directory-iterator> ] dip [ f ] compose ; inline
 123
 124 PRIVATE>
 125
 126 : each-file ( ... path quot: ( ... name -- ... ) -- ... )
 127     setup-traversal iterate-directory drop ; inline
 128
 129 : each-directory-entry ( path quot: ( ... entry -- ... ) -- )
 130     setup-traversal iterate-directory-entries drop ; inline
 131
 132 : recursive-directory-files ( path -- paths )
 133     [ ] collector [ each-file ] dip ;
 134
 135 : recursive-directory-entries ( path -- directory-entries )
 136     [ ] collector [ each-directory-entry ] dip ;
 137
 138 : find-file ( path quot: ( ... name -- ... ? ) -- path/f )
 139     [ bfs? <directory-iterator> ] dip
 140     '[ _ keep and ] iterate-directory ; inline
 141
 142 : find-files ( path quot: ( ... name -- ... ? ) -- paths )
 143     selector [ each-file ] dip ; inline
 144
 145 ERROR: sequence-expected obj ;
 146
 147 : ensure-sequence-of-directories ( obj -- seq )
 148     dup string? [ 1array ] when
 149     dup sequence? [ sequence-expected ] unless ;
 150
 151 : find-file-in-directories ( directories quot: ( ... name -- ... ? ) -- path'/f )
 152     [ ensure-sequence-of-directories ] dip
 153     '[ _ find-file ] map-find drop ; inline
 154
 155 : find-files-in-directories ( directories quot: ( ... name -- ... ? ) -- paths/f )
 156     [ ensure-sequence-of-directories ] dip
 157     '[ _ find-files ] map concat ; inline
 158
 159 : ?parent-directory ( path -- path'/f )
 160     dup parent-directory 2dup = [ 2drop f ] [ nip ] if ;
 161
 162 : containing-directory ( path -- path' )
 163     dup file-info directory? [ parent-directory ] unless ;
 164
 165 : ?qualified-directory-files ( path -- seq )
 166     [ qualified-directory-files ]
 167     [ drop ?parent-directory [ ?qualified-directory-files ] [ f ] if* ] recover ;
 168
 169 : (find-up-to-root) ( path quot: ( path -- ? ) -- obj )
 170     [ [ ?qualified-directory-files ] dip find swap ] 2keep rot [
 171         2drop
 172     ] [
 173         [ nip ?parent-directory ] dip over
 174         [ (find-up-to-root) ] [ 2drop f ] if
 175     ] if ; inline recursive
 176
 177 : find-up-to-root ( path quot: ( path -- ? ) -- obj )
 178     [ normalize-path containing-directory ] dip (find-up-to-root) ; inline
 179
 180 : link-size/0 ( path -- n )
 181     [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
 182
 183 : directory-size ( path -- n )
 184     0 swap [ link-size/0 + ] each-file ;
 185
 186 : directory-usage ( path -- assoc )
 187     qualified-directory-entries [
 188         [ name>> dup ] [ directory? ] bi
 189         [ directory-size ] [ link-size/0 ] if
 190     ] { } map>assoc sort-values ;
 191
 192 : find-files-by-extensions ( path extensions -- seq )
 193     [ >lower ] map
 194     '[ >lower _ [ tail? ] with any? ] find-files ;
 195
 196 : find-files-by-extension ( path extension -- seq )
 197     1array find-files-by-extensions ;
 198
 199 : find-files-larger-than ( path size -- seq )
 200     '[ link-info size>> _ > ] find-files ;
 201
 202 ! Touching files
 203 HOOK: touch-file io-backend ( path -- )
 204
 205 ! Deleting files
 206 HOOK: delete-file io-backend ( path -- )
 207
 208 HOOK: delete-directory io-backend ( path -- )
 209
 210 : ?delete-file ( path -- )
 211     '[ _ delete-file ] ignore-errors ;
 212
 213 : to-directory ( from to -- from to' )
 214     over file-name append-path ;
 215
 216 ! Moving and renaming files
 217 HOOK: move-file io-backend ( from to -- )
 218 HOOK: move-file-atomically io-backend ( from to -- )
 219
 220 : move-file-into ( from to -- )
 221     to-directory move-file ;
 222
 223 : move-files-into ( files to -- )
 224     '[ _ move-file-into ] each ;
 225
 226 ! Copying files
 227 HOOK: copy-file io-backend ( from to -- )
 228
 229 M: object copy-file
 230     make-parent-directories binary <file-writer> [
 231         swap binary <file-reader> [
 232             swap stream-copy
 233         ] with-disposal
 234     ] with-disposal ;
 235
 236 : copy-file-into ( from to -- )
 237     to-directory copy-file ;
 238
 239 : copy-files-into ( files to -- )
 240     '[ _ copy-file-into ] each ;
 241
 242 : delete-tree ( path -- )
 243     dup link-info directory? [
 244         [ [ [ delete-tree ] each ] with-directory-files ]
 245         [ delete-directory ]
 246         bi
 247     ] [ delete-file ] if ;
 248
 249 : ?delete-tree ( path -- )
 250     dup file-exists? [ delete-tree ] [ drop ] if ;
 251
 252 DEFER: copy-trees-into
 253
 254 : copy-tree ( from to -- )
 255     normalize-path
 256     over link-info type>>
 257     {
 258         { +symbolic-link+ [ copy-link ] }
 259         { +directory+ [ '[ _ copy-trees-into ] with-directory-files ] }
 260         [ drop copy-file ]
 261     } case ;
 262
 263 : copy-tree-into ( from to -- )
 264     to-directory copy-tree ;
 265
 266 : copy-trees-into ( files to -- )
 267     '[ _ copy-tree-into ] each ;
 268
 269 {
 270     { [ os unix? ] [ "io.directories.unix" require ] }
 271     { [ os windows? ] [ "io.directories.windows" require ] }
 272 } cond