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 vocabs.platforms ;
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 )
91 <dlist> directory-iterator boa
92 dup path>> over push-directory-entries ;
94 : next-directory-entry ( iter -- directory-entry/f )
95 { directory-iterator } declare
96 dup queue>> deque-empty? [ drop f ] [
99 [ [ name>> swap push-directory-entries ] keep ]
103 : iterate-directory-entries ( ... iter quot: ( ... directory-entry -- ... obj/f ) -- ... obj/f )
104 over next-directory-entry [
106 [ iterate-directory-entries ] 2curry unless*
109 ] if* ; inline recursive
111 : iterate-directory ( iter quot -- path/f )
112 [ name>> ] prepose iterate-directory-entries ; inline
115 traversal-method get {
116 { +breadth-first+ [ t ] }
117 { +depth-first+ [ f ] }
120 : setup-traversal ( path quot -- iter quot' )
121 [ bfs? <directory-iterator> ] dip [ f ] compose ; inline
125 : each-file ( ... path quot: ( ... name -- ... ) -- ... )
126 setup-traversal iterate-directory drop ; inline
128 : each-directory-entry ( path quot: ( ... entry -- ... ) -- )
129 setup-traversal iterate-directory-entries drop ; inline
131 : recursive-directory-files ( path -- paths )
132 [ ] collector [ each-file ] dip ;
134 : recursive-directory-entries ( path -- directory-entries )
135 [ ] collector [ each-directory-entry ] dip ;
137 : find-file ( path quot: ( ... name -- ... ? ) -- path/f )
138 [ bfs? <directory-iterator> ] dip
139 '[ _ keep and ] iterate-directory ; inline
141 : find-files ( path quot: ( ... name -- ... ? ) -- paths )
142 selector [ each-file ] dip ; inline
144 ERROR: sequence-expected obj ;
146 : ensure-sequence-of-directories ( obj -- seq )
147 dup string? [ 1array ] when
148 dup sequence? [ sequence-expected ] unless ;
150 : find-file-in-directories ( directories quot: ( ... name -- ... ? ) -- path'/f )
151 [ ensure-sequence-of-directories ] dip
152 '[ _ find-file ] map-find drop ; inline
154 : find-files-in-directories ( directories quot: ( ... name -- ... ? ) -- paths/f )
155 [ ensure-sequence-of-directories ] dip
156 '[ _ find-files ] map concat ; inline
158 : ?parent-directory ( path -- path'/f )
159 dup parent-directory 2dup = [ 2drop f ] [ nip ] if ;
161 : containing-directory ( path -- path' )
162 dup file-info directory? [ parent-directory ] unless ;
164 : ?qualified-directory-files ( path -- seq )
165 [ qualified-directory-files ]
166 [ drop ?parent-directory [ ?qualified-directory-files ] [ f ] if* ] recover ;
168 : (find-up-to-root) ( path quot: ( path -- ? ) -- obj )
169 [ [ ?qualified-directory-files ] dip find swap ] 2keep rot [
172 [ nip ?parent-directory ] dip over
173 [ (find-up-to-root) ] [ 2drop f ] if
174 ] if ; inline recursive
176 : find-up-to-root ( path quot: ( path -- ? ) -- obj )
177 [ normalize-path containing-directory ] dip (find-up-to-root) ; inline
179 : link-size/0 ( path -- n )
180 [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
182 : directory-size ( path -- n )
183 0 swap [ link-size/0 + ] each-file ;
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 ;
191 : find-files-by-extensions ( path extensions -- seq )
193 '[ >lower _ [ tail? ] with any? ] find-files ;
195 : find-files-by-extension ( path extension -- seq )
196 1array find-files-by-extensions ;
198 : find-files-larger-than ( path size -- seq )
199 '[ link-info size>> _ > ] find-files ;
202 HOOK: touch-file io-backend ( path -- )
205 HOOK: delete-file io-backend ( path -- )
207 HOOK: delete-directory io-backend ( path -- )
209 : ?delete-file ( path -- )
210 '[ _ delete-file ] ignore-errors ;
212 : to-directory ( from to -- from to' )
213 over file-name append-path ;
215 ! Moving and renaming files
216 HOOK: move-file io-backend ( from to -- )
217 HOOK: move-file-atomically io-backend ( from to -- )
219 : move-file-into ( from to -- )
220 to-directory move-file ;
222 : move-files-into ( files to -- )
223 '[ _ move-file-into ] each ;
226 HOOK: copy-file io-backend ( from to -- )
229 make-parent-directories binary <file-writer> [
230 swap binary <file-reader> [
235 : copy-file-into ( from to -- )
236 to-directory copy-file ;
238 : copy-files-into ( files to -- )
239 '[ _ copy-file-into ] each ;
241 : delete-tree ( path -- )
242 dup link-info directory? [
243 [ [ [ delete-tree ] each ] with-directory-files ]
246 ] [ delete-file ] if ;
248 DEFER: copy-trees-into
250 : copy-tree ( from to -- )
252 over link-info type>>
254 { +symbolic-link+ [ copy-link ] }
255 { +directory+ [ '[ _ copy-trees-into ] with-directory-files ] }
259 : copy-tree-into ( from to -- )
260 to-directory copy-tree ;
262 : copy-trees-into ( files to -- )
263 '[ _ copy-tree-into ] each ;
265 USE-UNIX: io.directories.unix
266 USE-WINDOWS: io.directories.windows