1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs continuations deques dlists fry
4 io.backend io.directories io.files.info io.pathnames kernel
5 kernel.private locals math sequences sequences.extras sorting
6 strings system unicode.case vocabs ;
7 IN: io.directories.search
9 : qualified-directory-entries ( path -- seq )
11 dup directory-entries [ [ append-path ] change-name ] with map! ;
13 : qualified-directory-files ( path -- seq )
15 dup directory-files [ append-path ] with map! ;
17 : with-qualified-directory-files ( path quot -- )
18 '[ "" qualified-directory-files @ ] with-directory ; inline
20 : with-qualified-directory-entries ( path quot -- )
21 '[ "" qualified-directory-entries @ ] with-directory ; inline
25 TUPLE: directory-iterator
30 : push-directory-entries ( path iter -- )
31 { directory-iterator } declare
32 [ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[
33 _ [ queue>> ] [ bfs>> ] bi
34 [ push-front ] [ push-back ] if
37 : <directory-iterator> ( path bfs? -- iterator )
38 <dlist> directory-iterator boa
39 dup path>> over push-directory-entries ;
41 : next-directory-entry ( iter -- directory-entry/f )
42 { directory-iterator } declare
43 dup queue>> deque-empty? [ drop f ] [
46 [ [ name>> swap push-directory-entries ] keep ]
50 :: iterate-directory-entries ( ... iter quot: ( ... obj -- ... obj ) -- ... directory-entry/f )
51 iter next-directory-entry [
53 [ iter quot iterate-directory-entries ] unless*
56 ] if* ; inline recursive
58 : iterate-directory ( iter quot -- path/f )
59 [ name>> ] prepose iterate-directory-entries ; inline
61 : setup-traversal ( path bfs quot -- iterator quot' )
62 [ <directory-iterator> ] dip [ f ] compose ; inline
66 : each-file ( path bfs? quot -- )
67 setup-traversal iterate-directory drop ; inline
69 : each-file-breadth ( path quot -- )
70 t swap each-file ; inline
72 : each-file-depth ( path quot -- )
73 f swap each-file ; inline
75 : filter-files-by-depth ( quot -- seq )
76 selector* [ each-file-depth ] dip ; inline
78 : filter-files-by-breadth ( quot -- seq )
79 selector* [ each-file-breadth ] dip ; inline
81 : all-files-by-depth ( quot -- seq )
82 collector [ each-file-depth ] dip ; inline
84 : all-files-by-breadth ( quot -- seq )
85 collector [ each-file-breadth ] dip ; inline
87 : each-directory-entry ( path bfs? quot: ( ... entry -- ... ) -- )
88 setup-traversal iterate-directory-entries drop ; inline
90 : recursive-directory-files ( path bfs? -- paths )
91 [ ] collector [ each-file ] dip ;
93 : recursive-directory-entries ( path bfs? -- directory-entries )
94 [ ] collector [ each-directory-entry ] dip ;
96 : find-file ( path bfs? quot: ( ... name -- ... ? ) -- path/f )
97 [ <directory-iterator> ] dip
98 [ keep and ] curry iterate-directory ; inline
100 : find-all-files ( path quot: ( ... name -- ... ? ) -- paths )
101 f swap selector [ each-file ] dip ; inline
103 ERROR: file-not-found path bfs? quot ;
105 : find-file-throws ( path bfs? quot -- path )
106 3dup find-file [ 2nip nip ] [ throw-file-not-found ] if* ; inline
108 ERROR: sequence-expected obj ;
110 : ensure-sequence-of-directories ( obj -- seq )
111 dup string? [ 1array ] when
112 dup sequence? [ throw-sequence-expected ] unless ;
114 ! Can't make this generic# on string/sequence because of combinators
115 : find-in-directories ( directories bfs? quot -- path'/f )
116 [ ensure-sequence-of-directories ] 2dip
117 '[ _ [ _ _ find-file-throws ] attempt-all ]
118 [ drop f ] recover ; inline
120 : find-all-in-directories ( directories quot -- paths/f )
121 '[ _ find-all-files ] map concat ; inline
123 : ?parent-directory ( path -- path'/f )
124 dup parent-directory 2dup = [ 2drop f ] [ nip ] if ;
126 : ?file-info ( path -- file-info/f )
127 [ file-info ] [ 2drop f ] recover ;
129 : containing-directory ( path -- path' )
130 dup ?file-info directory? [ parent-directory ] unless ;
132 : ?qualified-directory-files ( path -- seq )
133 [ qualified-directory-files ]
134 [ drop ?parent-directory [ ?qualified-directory-files ] [ f ] if* ] recover ;
136 : (find-up-to-root) ( path quot: ( path -- ? ) -- obj )
137 [ [ ?qualified-directory-files ] dip find swap ] 2keep rot [
140 [ nip ?parent-directory ] dip over
141 [ (find-up-to-root) ] [ 2drop f ] if
142 ] if ; inline recursive
144 : find-up-to-root ( path quot -- obj )
145 [ normalize-path containing-directory ] dip (find-up-to-root) ; inline
147 : link-size/0 ( path -- n )
148 [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
150 : directory-size ( path -- n )
151 0 swap t [ link-size/0 + ] each-file ;
153 : directory-usage ( path -- assoc )
156 [ name>> dup ] [ directory? ] bi
157 [ directory-size ] [ link-size/0 ] if
159 ] with-qualified-directory-entries sort-values ;
161 : find-by-extensions ( path extensions -- seq )
163 '[ >lower _ [ tail? ] with any? ] find-all-files ;
165 : find-by-extension ( path extension -- seq )
166 1array find-by-extensions ;
168 : find-files-larger-than ( path size -- seq )
169 '[ file-info size>> _ > ] filter-files-by-depth ;
171 : file-info-recursive ( path -- seq )
172 [ dup ?file-info [ 2array ] [ drop f ] if* ] filter-files-by-depth ;
174 os windows? [ "io.directories.search.windows" require ] when