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 DEFER: glob-directory%
  55
  56 : ?glob-directory% ( root remaining entry -- )
  57     directory? [
  58         glob-directory%
  59     ] [
  60         empty? [ , ] [ drop ] if
  61     ] if ;
  62
  63 :: glob-wildcard% ( root globs -- )
  64     globs ?second :> next-glob
  65     next-glob dup pair? [ second ] [ drop f ] if :> next-glob-regexp
  66
  67     root directory-entries [| entry |
  68         root entry name>> append-path
  69         {
  70             { [ next-glob not ] [ dup , ] }
  71             { [ next-glob empty? ] [ entry directory? [ dup , ] when ] }
  72             [
  73                 next-glob-regexp [
  74                     entry name>> >case-fold next-glob-regexp matches?
  75                 ] [
  76                     {
  77                         [ next-glob "**" = ]
  78                         [ entry name>> next-glob = ]
  79                     } 0||
  80                 ] if [
  81                     globs 2 tail [
  82                          dup ,
  83                     ] [
  84                         entry directory? [
  85                             dupd glob-directory%
  86                         ] [
  87                             drop
  88                         ] if
  89                     ] if-empty
  90                 ] when
  91             ]
  92         } cond
  93
  94         { [ entry directory? ] [ next-glob ] } 0&& [
  95             globs glob-directory%
  96         ] [
  97             drop
  98         ] if
  99     ] each ;
 100
 101 :: glob-pattern% ( root globs -- )
 102     globs unclip second :> ( remaining glob )
 103
 104     root directory-entries [| entry |
 105         entry name>> >case-fold glob matches? [
 106             root entry name>> append-path
 107             remaining entry ?glob-directory%
 108         ] when
 109     ] each ;
 110
 111 :: glob-literal% ( root globs -- )
 112     globs unclip :> ( remaining glob )
 113
 114     root glob append-path dup exists? [
 115         remaining over file-info ?glob-directory%
 116     ] [
 117         drop
 118     ] if ;
 119
 120 : glob-directory% ( root globs -- )
 121     dup ?first {
 122         { f [ 2drop ] }
 123         { "**" [ glob-wildcard% ] }
 124         [ pair? [ glob-pattern% ] [ glob-literal% ] if ]
 125     } case ;
 126
 127 : split-glob ( glob -- path globs )
 128     { } [
 129         over glob-pattern?
 130     ] [
 131         [
 132             path-separator first over last-index
 133             [ cut rest ] [ "" swap ] if*
 134         ] dip swap prefix
 135     ] while ;
 136
 137 : glob-path ( glob -- path globs )
 138     split-glob [
 139         dup { [ "**" = not ] [ glob-pattern? ] } 1&& [
 140             dup >case-fold <glob> 2array
 141         ] when
 142     ] map ;
 143
 144 PRIVATE>
 145
 146 : glob-directory ( glob -- files )
 147     glob-path [ glob-directory% ] { } make ;