basis/io/directories/search/search.factor

   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
   8
   9 : qualified-directory-entries ( path -- seq )
  10     absolute-path
  11     dup directory-entries [ [ append-path ] change-name ] with map! ;
  12
  13 : qualified-directory-files ( path -- seq )
  14     absolute-path
  15     dup directory-files [ append-path ] with map! ;
  16
  17 : with-qualified-directory-files ( path quot -- )
  18     '[ "" qualified-directory-files @ ] with-directory ; inline
  19
  20 : with-qualified-directory-entries ( path quot -- )
  21     '[ "" qualified-directory-entries @ ] with-directory ; inline
  22
  23 <PRIVATE
  24
  25 TUPLE: directory-iterator
  26 { path string }
  27 { bfs boolean }
  28 { queue dlist } ;
  29
  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
  35     ] each ;
  36
  37 : <directory-iterator> ( path bfs? -- iterator )
  38     <dlist> directory-iterator boa
  39     dup path>> over push-directory-entries ;
  40
  41 : next-directory-entry ( iter -- directory-entry/f )
  42     { directory-iterator } declare
  43     dup queue>> deque-empty? [ drop f ] [
  44         dup queue>> pop-back
  45         dup directory?
  46         [ [ name>> swap push-directory-entries ] keep ]
  47         [ nip ] if
  48     ] if ;
  49
  50 :: iterate-directory-entries ( ... iter quot: ( ... obj -- ... obj ) -- ... directory-entry/f )
  51     iter next-directory-entry [
  52         quot call
  53         [ iter quot iterate-directory-entries ] unless*
  54     ] [
  55         f
  56     ] if* ; inline recursive
  57
  58 : iterate-directory ( iter quot -- path/f )
  59     [ name>> ] prepose iterate-directory-entries ; inline
  60
  61 : setup-traversal ( path bfs quot -- iterator quot' )
  62     [ <directory-iterator> ] dip [ f ] compose ; inline
  63
  64 PRIVATE>
  65
  66 : each-file ( path bfs? quot -- )
  67     setup-traversal iterate-directory drop ; inline
  68
  69 : each-file-breadth ( path quot -- )
  70     t swap each-file ; inline
  71
  72 : each-file-depth ( path quot -- )
  73     f swap each-file ; inline
  74
  75 : filter-files-by-depth ( quot -- seq )
  76     selector* [ each-file-depth ] dip ; inline
  77
  78 : filter-files-by-breadth ( quot -- seq )
  79     selector* [ each-file-breadth ] dip ; inline
  80
  81 : all-files-by-depth ( quot -- seq )
  82     collector [ each-file-depth ] dip ; inline
  83
  84 : all-files-by-breadth ( quot -- seq )
  85     collector [ each-file-breadth ] dip ; inline
  86
  87 : each-directory-entry ( path bfs? quot: ( ... entry -- ... ) -- )
  88     setup-traversal iterate-directory-entries drop ; inline
  89
  90 : recursive-directory-files ( path bfs? -- paths )
  91     [ ] collector [ each-file ] dip ;
  92
  93 : recursive-directory-entries ( path bfs? -- directory-entries )
  94     [ ] collector [ each-directory-entry ] dip ;
  95
  96 : find-file ( path bfs? quot: ( ... name -- ... ? ) -- path/f )
  97     [ <directory-iterator> ] dip
  98     [ keep and ] curry iterate-directory ; inline
  99
 100 : find-all-files ( path quot: ( ... name -- ... ? ) -- paths )
 101     f swap selector [ each-file ] dip ; inline
 102
 103 ERROR: file-not-found path bfs? quot ;
 104
 105 : find-file-throws ( path bfs? quot -- path )
 106     3dup find-file [ 2nip nip ] [ throw-file-not-found ] if* ; inline
 107
 108 ERROR: sequence-expected obj ;
 109
 110 : ensure-sequence-of-directories ( obj -- seq )
 111     dup string? [ 1array ] when
 112     dup sequence? [ throw-sequence-expected ] unless ;
 113
 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
 119
 120 : find-all-in-directories ( directories quot -- paths/f )
 121     '[ _ find-all-files ] map concat ; inline
 122
 123 : ?parent-directory ( path -- path'/f )
 124     dup parent-directory 2dup = [ 2drop f ] [ nip ] if ;
 125
 126 : ?file-info ( path -- file-info/f )
 127     [ file-info ] [ 2drop f ] recover ;
 128
 129 : containing-directory ( path -- path' )
 130     dup ?file-info directory? [ parent-directory ] unless ;
 131
 132 : ?qualified-directory-files ( path -- seq )
 133     [ qualified-directory-files ]
 134     [ drop ?parent-directory [ ?qualified-directory-files ] [ f ] if* ] recover ;
 135
 136 : (find-up-to-root) ( path  quot: ( path -- ? ) -- obj )
 137     [ [ ?qualified-directory-files ] dip find swap ] 2keep rot [
 138         2drop
 139     ] [
 140         [ nip ?parent-directory ] dip over
 141         [ (find-up-to-root) ] [ 2drop f ] if
 142     ] if ; inline recursive
 143
 144 : find-up-to-root ( path quot -- obj )
 145     [ normalize-path containing-directory ] dip (find-up-to-root) ; inline
 146
 147 : link-size/0 ( path -- n )
 148     [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
 149
 150 : directory-size ( path -- n )
 151     0 swap t [ link-size/0 + ] each-file ;
 152
 153 : directory-usage ( path -- assoc )
 154     [
 155         [
 156             [ name>> dup ] [ directory? ] bi
 157             [ directory-size ] [ link-size/0 ] if
 158         ] { } map>assoc
 159     ] with-qualified-directory-entries sort-values ;
 160
 161 : find-by-extensions ( path extensions -- seq )
 162     [ >lower ] map
 163     '[ >lower _ [ tail? ] with any? ] find-all-files ;
 164
 165 : find-by-extension ( path extension -- seq )
 166     1array find-by-extensions ;
 167
 168 : find-files-larger-than ( path size -- seq )
 169     '[ file-info size>> _ > ] filter-files-by-depth ;
 170
 171 : file-info-recursive ( path -- seq )
 172     [ dup ?file-info [ 2array ] [ drop f ] if* ] filter-files-by-depth ;
 173
 174 os windows? [ "io.directories.search.windows" require ] when