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 ;
11 : set-current-directory ( path -- )
12 absolute-path current-directory set ;
14 : with-directory ( path quot -- )
15 [ absolute-path current-directory ] dip with-variable ; inline
17 : with-resource-directory ( quot -- )
18 [ "resource:" ] dip with-directory ; inline
20 ! Creating directories
21 HOOK: make-directory io-backend ( path -- )
23 DEFER: make-parent-directories
25 : make-directories ( path -- )
26 normalize-path trim-tail-separators dup {
32 make-parent-directories
36 : make-parent-directories ( filename -- filename )
37 dup parent-directory make-directories ;
39 : with-ensure-directory ( path quot -- )
40 [ absolute-path dup make-directories current-directory ] dip with-variable ; inline
43 TUPLE: directory-entry name type ;
45 C: <directory-entry> directory-entry
47 HOOK: (directory-entries) os ( path -- seq )
49 : directory-entries ( path -- seq )
52 [ name>> { "." ".." } member? ] reject ;
54 : directory-files ( path -- seq )
55 directory-entries [ name>> ] map! ;
57 : with-directory-entries ( path quot -- )
58 '[ "" directory-entries @ ] with-directory ; inline
60 : with-directory-files ( path quot -- )
61 '[ "" directory-files @ ] with-directory ; inline
65 : qualified-directory-entries ( path -- seq )
66 dup directory-entries [ [ append-path ] change-name ] with map! ;
68 : qualified-directory-files ( path -- seq )
69 dup directory-files [ append-path ] with map! ;
71 SYMBOL: traversal-method
73 SYMBOLS: +depth-first+ +breadth-first+ ;
75 traversal-method [ +depth-first+ ] initialize
79 TUPLE: directory-iterator
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 ;
90 : <directory-iterator> ( path bfs? -- iter )
92 <dlist> directory-iterator boa
93 dup path>> over push-directory-entries ;
95 : next-directory-entry ( iter -- directory-entry/f )
96 { directory-iterator } declare
97 dup queue>> deque-empty? [ drop f ] [
100 [ [ name>> swap push-directory-entries ] keep ]
104 : iterate-directory-entries ( ... iter quot: ( ... directory-entry -- ... obj/f ) -- ... obj/f )
105 over next-directory-entry [
107 [ iterate-directory-entries ] 2curry unless*
110 ] if* ; inline recursive
112 : iterate-directory ( iter quot -- path/f )
113 [ name>> ] prepose iterate-directory-entries ; inline
116 traversal-method get {
117 { +breadth-first+ [ t ] }
118 { +depth-first+ [ f ] }
121 : setup-traversal ( path quot -- iter quot' )
122 [ bfs? <directory-iterator> ] dip [ f ] compose ; inline
126 : each-file ( ... path quot: ( ... name -- ... ) -- ... )
127 setup-traversal iterate-directory drop ; inline
129 : each-directory-entry ( path quot: ( ... entry -- ... ) -- )
130 setup-traversal iterate-directory-entries drop ; inline
132 : recursive-directory-files ( path -- paths )
133 [ ] collector [ each-file ] dip ;
135 : recursive-directory-entries ( path -- directory-entries )
136 [ ] collector [ each-directory-entry ] dip ;
138 : find-file ( path quot: ( ... name -- ... ? ) -- path/f )
139 [ bfs? <directory-iterator> ] dip
140 '[ _ keep and ] iterate-directory ; inline
142 : find-files ( path quot: ( ... name -- ... ? ) -- paths )
143 selector [ each-file ] dip ; inline
145 ERROR: sequence-expected obj ;
147 : ensure-sequence-of-directories ( obj -- seq )
148 dup string? [ 1array ] when
149 dup sequence? [ sequence-expected ] unless ;
151 : find-file-in-directories ( directories quot: ( ... name -- ... ? ) -- path'/f )
152 [ ensure-sequence-of-directories ] dip
153 '[ _ find-file ] map-find drop ; inline
155 : find-files-in-directories ( directories quot: ( ... name -- ... ? ) -- paths/f )
156 [ ensure-sequence-of-directories ] dip
157 '[ _ find-files ] map concat ; inline
159 : ?parent-directory ( path -- path'/f )
160 dup parent-directory 2dup = [ 2drop f ] [ nip ] if ;
162 : containing-directory ( path -- path' )
163 dup ?file-info directory? [ parent-directory ] unless ;
165 : ?qualified-directory-files ( path -- seq )
166 [ qualified-directory-files ]
167 [ drop ?parent-directory [ ?qualified-directory-files ] [ f ] if* ] recover ;
169 : (find-up-to-root) ( path quot: ( path -- ? ) -- obj )
170 [ [ ?qualified-directory-files ] dip find swap ] 2keep rot [
173 [ nip ?parent-directory ] dip over
174 [ (find-up-to-root) ] [ 2drop f ] if
175 ] if ; inline recursive
177 : find-up-to-root ( path quot: ( path -- ? ) -- obj )
178 [ normalize-path containing-directory ] dip (find-up-to-root) ; inline
180 : link-size/0 ( path -- n )
181 [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
183 : directory-size ( path -- n )
184 0 swap [ link-size/0 + ] each-file ;
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 ;
192 : find-files-by-extensions ( path extensions -- seq )
194 '[ >lower _ [ tail? ] with any? ] find-files ;
196 : find-files-by-extension ( path extension -- seq )
197 1array find-files-by-extensions ;
199 : find-files-larger-than ( path size -- seq )
200 '[ link-info size>> _ > ] find-files ;
202 HOOK: touch-file io-backend ( path -- )
204 HOOK: truncate-file io-backend ( path n -- )
206 HOOK: delete-file io-backend ( path -- )
208 HOOK: delete-directory io-backend ( path -- )
210 : ?delete-file ( path -- )
211 '[ _ delete-file ] ignore-errors ;
213 : to-directory ( from to -- from to' )
214 over file-name append-path ;
216 HOOK: move-file io-backend ( from to -- )
218 : create-parent-directory ( path -- )
219 normalize-path parent-directory make-directories ;
221 : ?move-file ( from to -- )
223 dup create-parent-directory move-file
226 HOOK: move-file-atomically io-backend ( from to -- )
228 : move-file-into ( from to -- )
229 to-directory move-file ;
231 : move-files-into ( files to -- )
232 '[ _ move-file-into ] each ;
234 HOOK: copy-file io-backend ( from to -- )
237 make-parent-directories binary <file-writer> [
238 swap binary <file-reader> [
243 : copy-file-into ( from to -- )
244 to-directory copy-file ;
246 : copy-files-into ( files to -- )
247 '[ _ copy-file-into ] each ;
249 : delete-tree ( path -- )
250 dup link-info directory? [
251 [ [ [ delete-tree ] each ] with-directory-files ]
254 ] [ delete-file ] if ;
256 : ?delete-tree ( path -- )
257 [ delete-tree ] when-file-exists ;
259 DEFER: copy-trees-into
261 : copy-tree ( from to -- )
263 over link-info type>>
265 { +symbolic-link+ [ copy-link ] }
266 { +directory+ [ '[ _ copy-trees-into ] with-directory-files ] }
270 : copy-tree-into ( from to -- )
271 to-directory copy-tree ;
273 : copy-trees-into ( files to -- )
274 '[ _ copy-tree-into ] each ;
277 { [ os unix? ] [ "io.directories.unix" require ] }
278 { [ os windows? ] [ "io.directories.windows" require ] }