basis: use lint.vocabs tool to trim using lists

[factor.git] / basis / globs / globs.factor

diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor
index 72b686c3b1db7cc603037b055d9b7ab02b2dd4d1..3cb4ed094e0bbe0c608710b448063ef324b374bf 100644 (file)
--- a/basis/globs/globs.factor
+++ b/basis/globs/globs.factor
@@ -1,13 +1,18 @@
 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences io.pathnames kernel regexp.combinators
-strings unicode.case peg.ebnf regexp arrays ;
+USING: accessors arrays combinators combinators.short-circuit
+io.directories io.files io.files.info io.pathnames kernel
+make peg.ebnf regexp regexp.combinators sequences strings system
+unicode multiline ;
 IN: globs
 
 : not-path-separator ( -- sep )
-    "[^" path-separator "]" 3append <regexp> ; foldable
+    os windows? R/ [^\/\\]/ R/ [^\/]/ ? ; foldable
 
-EBNF: <glob>
+: wild-path-separator ( -- sep )
+    os windows? R/ [^\/\\][\/\\]|[^\/\\]/ R/ [^\/][\/]|[^\/]/ ? ; foldable
+
+EBNF: <glob> [=[
 
 Character = "\\" .:c => [[ c 1string <literal> ]]
           | !(","|"}") . => [[ 1string <literal> ]]
@@ -27,7 +32,8 @@ CharClass = "^"?:n Ranges:e => [[ e <or> n [ <not> ] when ]]
 AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
                 | Concatenation => [[ 1array ]]
 
-Element = "*" => [[ not-path-separator <zero-or-more> ]]
+Element = "**" => [[ wild-path-separator <zero-or-more> ]]
+        | "*" => [[ not-path-separator <zero-or-more> ]]
         | "?" => [[ not-path-separator ]]
         | "[" CharClass:c "]" => [[ c ]]
         | "{" AlternationBody:b "}" => [[ b <or> ]]
@@ -39,7 +45,7 @@ End = !(.)
 
 Main = Concatenation End
 
-;EBNF
+]=]
 
 : glob-matches? ( input glob -- ? )
     [ >case-fold ] bi@ <glob> matches? ;
@@ -47,6 +53,109 @@ Main = Concatenation End
 : glob-pattern? ( string -- ? )
     [ "\\*?[{" member? ] any? ;
 
-: glob-parent-directory ( glob -- parent-directory )
-    path-components dup [ glob-pattern? ] find drop head
-    path-separator join ;
+<PRIVATE
+
+! TODO: simplify
+! TODO: handle two more test cases
+! TODO: make case-fold an option, off by default
+! TODO: maybe make case-fold an option on regexp
+
+DEFER: glob%
+
+: glob-entries ( path -- entries )
+    directory-entries [ name>> "." head? ] reject ;
+
+: ?glob% ( root remaining entry -- )
+    over empty? [
+        2drop ,
+    ] [
+        directory? [ glob% ] [ 2drop ] if
+    ] if ;
+
+:: glob-wildcard% ( root globs -- )
+    globs ?second :> next-glob
+    next-glob dup pair? [ second ] [ drop f ] if :> next-glob-regexp
+
+    root glob-entries [| entry |
+        root entry name>> append-path
+        {
+            { [ next-glob not ] [ dup , ] }
+            { [ next-glob empty? ] [ entry directory? [ dup , ] when ] }
+            [
+                next-glob-regexp [
+                    entry name>> >case-fold next-glob-regexp matches?
+                ] [
+                    {
+                        [ next-glob "**" = ]
+                        [ entry name>> next-glob = ]
+                    } 0||
+                ] if [
+                    globs 2 tail [
+                         dup ,
+                    ] [
+                        entry directory? [
+                            dupd glob%
+                        ] [
+                            drop
+                        ] if
+                    ] if-empty
+                ] when
+            ]
+        } cond
+
+        { [ entry directory? ] [ next-glob ] } 0&& [
+            globs glob%
+        ] [
+            drop
+        ] if
+    ] each ;
+
+:: glob-pattern% ( root globs -- )
+    globs unclip second :> ( remaining glob )
+
+    root glob-entries [| entry |
+        entry name>> >case-fold glob matches? [
+            root entry name>> append-path
+            remaining entry ?glob%
+        ] when
+    ] each ;
+
+:: glob-literal% ( root globs -- )
+    globs unclip :> ( remaining glob )
+
+    root glob append-path dup file-exists? [
+        remaining over file-info ?glob%
+    ] [
+        drop
+    ] if ;
+
+: glob% ( root globs -- )
+    dup ?first {
+        { f [ 2drop ] }
+        { "**" [ glob-wildcard% ] }
+        [ pair? [ glob-pattern% ] [ glob-literal% ] if ]
+    } case ;
+
+: split-glob ( glob -- path globs )
+    { } [
+        over glob-pattern?
+    ] [
+        [
+            dup [ path-separator? ] find-last drop
+            [ cut rest ] [ "" swap ] if*
+        ] dip swap prefix
+    ] while ;
+
+: glob-path ( glob -- path globs )
+    split-glob [
+        dup { [ "**" = not ] [ glob-pattern? ] } 1&& [
+            dup >case-fold <glob> 2array
+        ] when
+    ] map ;
+
+PRIVATE>
+
+: glob ( glob -- files )
+    glob-path [
+        [ 1array f swap ] when-empty glob%
+    ] { } make ;