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