From 1441d665535cecd5cdea10c2716ed51db40645c7 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sun, 27 Mar 2016 18:52:20 -0700
Subject: [PATCH] globs: implement glob-directory.

It looks too complicated, and maybe it is.  Some tests pass.
---
 basis/globs/globs-tests.factor |  54 ++++++++++++++++-
 basis/globs/globs.factor       | 103 ++++++++++++++++++++++++++++++++-
 2 files changed, 154 insertions(+), 3 deletions(-)

diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor
index f9b476bca4..c048af9eb6 100755
--- a/basis/globs/globs-tests.factor
+++ b/basis/globs/globs-tests.factor
@@ -1,4 +1,5 @@
-USING: globs io.pathnames literals sequences tools.test ;
+USING: globs io.directories io.files.temp io.files.unique
+io.pathnames literals sequences tools.test ;
 IN: globs.tests
 
 { f } [ "abd" "fdf" glob-matches? ] unit-test
@@ -30,6 +31,57 @@ IN: globs.tests
 { t } [ "fo\\*" glob-pattern? ] unit-test
 { t } [ "fo{o,bro}" glob-pattern? ] unit-test
 
+{
+    { "a" }
+    { "a" "a/b" "a/b/c" "a/b/c/d" "a/b/h" "a/e" "a/e/g" }
+    {
+        "a" "a/b" "a/b/c" "a/b/c/d" "a/b/c/d/e" "a/b/c/f"
+        "a/b/g" "a/b/h" "a/b/h/e" "a/e" "a/e/f" "a/e/g"
+        "a/e/g/e"
+    }
+    {
+        "a" "a/b" "a/b/c" "a/b/c/d" "a/b/c/d/e" "a/b/c/f"
+        "a/b/g" "a/b/h" "a/b/h/e" "a/e" "a/e/f" "a/e/g"
+        "a/e/g/e"
+    }
+    { "a/b" }
+    { "a/b/c/d/e" "a/b/h/e" "a/e" "a/e/g/e" }
+    ! { "a/b/c/d/e" "a/b/h/e" "a/e" "a/e/g/e" }
+    ! { "a/b/c/d/e" "a/b/h/e" "a/e" "a/e/g/e" }
+    { "a/e/f" "a/e/g" }
+    { "a/b" "a/e" }
+} [
+
+    [
+        [
+            "a" make-directory
+            "a/b" make-directory
+            "a/b/c" make-directory
+            "a/b/c/d" make-directory
+            "a/b/c/d/e" touch-file
+            "a/b/c/f" touch-file
+            "a/b/g" touch-file
+            "a/b/h" make-directory
+            "a/b/h/e" touch-file
+            "a/e" make-directory
+            "a/e/f" touch-file
+            "a/e/g" make-directory
+            "a/e/g/e" touch-file
+
+            "**" glob-directory
+            "**/" glob-directory
+            "**/*" glob-directory
+            "**/**" glob-directory
+            "**/b" glob-directory
+            "**/e" glob-directory
+            ! "**//e" glob-directory
+            ! "**/**/e" glob-directory
+            "**/e/**" glob-directory
+            "a/**" glob-directory
+        ] cleanup-unique-directory
+    ] with-temp-directory
+] unit-test
+
 ${ { "foo" "bar" } path-separator join }
 [ { "foo" "bar" "ba?" } path-separator join glob-parent-directory ] unit-test
 
diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor
index 9cd6a73891..a22330ffa4 100644
--- a/basis/globs/globs.factor
+++ b/basis/globs/globs.factor
@@ -1,7 +1,9 @@
 ! 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 splitting system unicode.case peg.ebnf regexp arrays ;
+USING: accessors arrays combinators combinators.short-circuit
+io.directories io.files io.files.info io.pathnames kernel locals
+make peg.ebnf regexp regexp.combinators sequences splitting
+strings system unicode.case ;
 IN: globs
 
 : not-path-separator ( -- sep )
@@ -47,6 +49,103 @@ Main = Concatenation End
 : glob-pattern? ( string -- ? )
     [ "\\*?[{" member? ] any? ;
 
+<PRIVATE
+
+DEFER: glob-directory%
+
+: ?glob-directory% ( root remaining entry -- )
+    directory? [
+        glob-directory%
+    ] [
+        empty? [ , ] [ drop ] if
+    ] if ;
+
+:: glob-wildcard% ( root globs -- )
+    globs ?second :> next-glob
+    next-glob dup pair? [ second ] [ drop f ] if :> next-glob-regexp
+
+    root directory-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-directory%
+                        ] [
+                            drop
+                        ] if
+                    ] if-empty
+                ] when
+            ]
+        } cond
+
+        { [ entry directory? ] [ next-glob ] } 0&& [
+            globs glob-directory%
+        ] [
+            drop
+        ] if
+    ] each ;
+
+:: glob-pattern% ( root globs -- )
+    globs unclip second :> ( remaining glob )
+
+    root directory-entries [| entry |
+        entry name>> >case-fold glob matches? [
+            root entry name>> append-path
+            remaining entry ?glob-directory%
+        ] when
+    ] each ;
+
+:: glob-literal% ( root globs -- )
+    globs unclip :> ( remaining glob )
+
+    root glob append-path dup exists? [
+        remaining over file-info ?glob-directory%
+    ] [
+        drop
+    ] if ;
+
+: glob-directory% ( root globs -- )
+    dup ?first {
+        { f [ 2drop ] }
+        { "**" [ glob-wildcard% ] }
+        [ pair? [ glob-pattern% ] [ glob-literal% ] if ]
+    } case ;
+
+: split-glob ( glob -- path globs )
+    { } [
+        over glob-pattern?
+    ] [
+        [
+            path-separator first over last-index
+            [ 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-directory ( glob -- files )
+    glob-path [ glob-directory% ] { } make ;
+
 : glob-parent-directory ( glob -- parent-directory )
     path-separator split harvest dup [ glob-pattern? ] find drop head
     path-separator join ;