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 locals math sequences sorting system unicode.case vocabs.loader ;
   6 IN: io.directories.search
   7
   8 : qualified-directory-entries ( path -- seq )
   9     absolute-path
  10     dup directory-entries [ [ append-path ] change-name ] with map ;
  11
  12 : qualified-directory-files ( path -- seq )
  13     absolute-path
  14     dup directory-files [ append-path ] with map ;
  15
  16 : with-qualified-directory-files ( path quot -- )
  17     '[ "" qualified-directory-files @ ] with-directory ; inline
  18
  19 : with-qualified-directory-entries ( path quot -- )
  20     '[ "" qualified-directory-entries @ ] with-directory ; inline
  21
  22 <PRIVATE
  23
  24 TUPLE: directory-iterator path bfs queue ;
  25
  26 : push-directory-entries ( path iter -- )
  27     [ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[
  28         _ [ queue>> ] [ bfs>> ] bi
  29         [ push-front ] [ push-back ] if
  30     ] each ;
  31
  32 : <directory-iterator> ( path bfs? -- iterator )
  33     <dlist> directory-iterator boa
  34     dup path>> over push-directory-entries ;
  35
  36 : next-directory-entry ( iter -- directory-entry/f )
  37     dup queue>> deque-empty? [ drop f ] [
  38         dup queue>> pop-back
  39         dup directory?
  40         [ name>> over push-directory-entries next-directory-entry ]
  41         [ nip ] if
  42     ] if ;
  43
  44 :: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
  45     iter next-directory-entry [
  46         quot call
  47         [ iter quot iterate-directory-entries ] unless*
  48     ] [
  49         f
  50     ] if* ; inline recursive
  51
  52 : iterate-directory ( iter quot -- path/f )
  53     [ name>> ] prepose iterate-directory-entries ; inline
  54
  55 : setup-traversal ( path bfs quot -- iterator quot' )
  56     [ <directory-iterator> ] dip [ f ] compose ; inline
  57
  58 PRIVATE>
  59
  60 : each-file ( path bfs? quot -- )
  61     setup-traversal iterate-directory drop ; inline
  62
  63 : each-directory-entry ( path bfs? quot -- )
  64     setup-traversal iterate-directory-entries drop ; inline
  65
  66 : recursive-directory-files ( path bfs? -- paths )
  67     [ ] accumulator [ each-file ] dip ; inline
  68
  69 : recursive-directory-entries ( path bfs? -- directory-entries )
  70     [ ] accumulator [ each-directory-entry ] dip ; inline
  71
  72 : find-file ( path bfs? quot -- path/f )
  73     [ <directory-iterator> ] dip
  74     [ keep and ] curry iterate-directory ; inline
  75
  76 : find-all-files ( path quot -- paths/f )
  77     [ f <directory-iterator> ] dip pusher
  78     [ [ f ] compose iterate-directory drop ] dip ; inline
  79
  80 ERROR: file-not-found path bfs? quot ;
  81
  82 : find-file-throws ( path bfs? quot -- path )
  83     3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
  84
  85 : find-in-directories ( directories bfs? quot -- path'/f )
  86     '[ _ [ _ _ find-file-throws ] attempt-all ]
  87     [ drop f ] recover ; inline
  88
  89 : find-all-in-directories ( directories quot -- paths/f )
  90     '[ _ find-all-files ] map concat ; inline
  91
  92 : link-size/0 ( path -- n )
  93     [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
  94
  95 : directory-size ( path -- n )
  96     0 swap t [ link-size/0 + ] each-file ;
  97
  98 : path>usage ( directory-entry -- name size )
  99     [ name>> dup ] [ directory? ] bi
 100     [ directory-size ] [ link-size/0 ] if ;
 101
 102 : directory-usage ( path -- assoc )
 103     [
 104         [
 105             [ path>usage ] [ drop name>> 0 ] recover
 106         ] { } map>assoc
 107     ] with-qualified-directory-entries sort-values ;
 108
 109 : find-by-extensions ( path extensions -- seq )
 110     [ >lower ] map
 111     '[ >lower _ [ tail? ] with any? ] find-all-files ;
 112
 113 : find-by-extension ( path extension -- seq )
 114     1array find-by-extensions ;
 115
 116 os windows? [ "io.directories.search.windows" require ] when