basis/globs/globs.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators combinators.short-circuit
   4 io.directories io.files io.files.info io.pathnames kernel locals
   5 make peg.ebnf regexp regexp.combinators sequences strings system
   6 unicode multiline ;
   7 IN: globs
   8
   9 : not-path-separator ( -- sep )
  10     os windows? R/ [^\/\\]/ R/ [^\/]/ ? ; foldable
  11
  12 : wild-path-separator ( -- sep )
  13     os windows? R/ [^\/\\][\/\\]|[^\/\\]/ R/ [^\/][\/]|[^\/]/ ? ; foldable
  14
  15 EBNF: <glob> [=[
  16
  17 Character = "\\" .:c => [[ c 1string <literal> ]]
  18           | !(","|"}") . => [[ 1string <literal> ]]
  19
  20 RangeCharacter = !("]") .
  21
  22 Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <char-range> ]]
  23       | RangeCharacter => [[ 1string <literal> ]]
  24
  25 StartRange = .:a "-" RangeCharacter:b => [[ a b <char-range> ]]
  26            | . => [[ 1string <literal> ]]
  27
  28 Ranges = StartRange:s Range*:r => [[ r s prefix ]]
  29
  30 CharClass = "^"?:n Ranges:e => [[ e <or> n [ <not> ] when ]]
  31
  32 AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
  33                 | Concatenation => [[ 1array ]]
  34
  35 Element = "**" => [[ wild-path-separator <zero-or-more> ]]
  36         | "*" => [[ not-path-separator <zero-or-more> ]]
  37         | "?" => [[ not-path-separator ]]
  38         | "[" CharClass:c "]" => [[ c ]]
  39         | "{" AlternationBody:b "}" => [[ b <or> ]]
  40         | Character
  41
  42 Concatenation = Element* => [[ <sequence> ]]
  43
  44 End = !(.)
  45
  46 Main = Concatenation End
  47
  48 ]=]
  49
  50 : glob-matches? ( input glob -- ? )
  51     [ >case-fold ] bi@ <glob> matches? ;
  52
  53 : glob-pattern? ( string -- ? )
  54     [ "\\*?[{" member? ] any? ;
  55
  56 <PRIVATE
  57
  58 ! TODO: simplify
  59 ! TODO: handle two more test cases
  60 ! TODO: make case-fold an option, off by default
  61 ! TODO: maybe make case-fold an option on regexp
  62
  63 DEFER: glob%
  64
  65 : glob-entries ( path -- entries )
  66     directory-entries [ name>> "." head? ] reject ;
  67
  68 : ?glob% ( root remaining entry -- )
  69     over empty? [
  70         2drop ,
  71     ] [
  72         directory? [ glob% ] [ 2drop ] if
  73     ] if ;
  74
  75 :: glob-wildcard% ( root globs -- )
  76     globs ?second :> next-glob
  77     next-glob dup pair? [ second ] [ drop f ] if :> next-glob-regexp
  78
  79     root glob-entries [| entry |
  80         root entry name>> append-path
  81         {
  82             { [ next-glob not ] [ dup , ] }
  83             { [ next-glob empty? ] [ entry directory? [ dup , ] when ] }
  84             [
  85                 next-glob-regexp [
  86                     entry name>> >case-fold next-glob-regexp matches?
  87                 ] [
  88                     {
  89                         [ next-glob "**" = ]
  90                         [ entry name>> next-glob = ]
  91                     } 0||
  92                 ] if [
  93                     globs 2 tail [
  94                          dup ,
  95                     ] [
  96                         entry directory? [
  97                             dupd glob%
  98                         ] [
  99                             drop
 100                         ] if
 101                     ] if-empty
 102                 ] when
 103             ]
 104         } cond
 105
 106         { [ entry directory? ] [ next-glob ] } 0&& [
 107             globs glob%
 108         ] [
 109             drop
 110         ] if
 111     ] each ;
 112
 113 :: glob-pattern% ( root globs -- )
 114     globs unclip second :> ( remaining glob )
 115
 116     root glob-entries [| entry |
 117         entry name>> >case-fold glob matches? [
 118             root entry name>> append-path
 119             remaining entry ?glob%
 120         ] when
 121     ] each ;
 122
 123 :: glob-literal% ( root globs -- )
 124     globs unclip :> ( remaining glob )
 125
 126     root glob append-path dup file-exists? [
 127         remaining over file-info ?glob%
 128     ] [
 129         drop
 130     ] if ;
 131
 132 : glob% ( root globs -- )
 133     dup ?first {
 134         { f [ 2drop ] }
 135         { "**" [ glob-wildcard% ] }
 136         [ pair? [ glob-pattern% ] [ glob-literal% ] if ]
 137     } case ;
 138
 139 : split-glob ( glob -- path globs )
 140     { } [
 141         over glob-pattern?
 142     ] [
 143         [
 144             dup [ path-separator? ] find-last drop
 145             [ cut rest ] [ "" swap ] if*
 146         ] dip swap prefix
 147     ] while ;
 148
 149 : glob-path ( glob -- path globs )
 150     split-glob [
 151         dup { [ "**" = not ] [ glob-pattern? ] } 1&& [
 152             dup >case-fold <glob> 2array
 153         ] when
 154     ] map ;
 155
 156 PRIVATE>
 157
 158 : glob ( glob -- files )
 159     glob-path [
 160         [ 1array f swap ] when-empty glob%
 161     ] { } make ;