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