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