[bug#30629] [PATCH 1/5] Add (guix glob).

[Marius Bakke]

Ludovic Courtès <address@hidden> writes:

> * guix/glob.scm, tests/glob.scm: New files.
> * Makefile.am (MODULES): Add guix/glob.scm.
> (SCM_TESTS): Add tests/glob.scm.
> ---
>  Makefile.am    |  4 ++-
>  guix/glob.scm  | 97 
> ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
>  tests/glob.scm | 58 +++++++++++++++++++++++++++++++++++
>  3 files changed, 158 insertions(+), 1 deletion(-)
>  create mode 100644 guix/glob.scm
>  create mode 100644 tests/glob.scm
>
> diff --git a/Makefile.am b/Makefile.am
> index e2c940ca8..6556799e6 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -1,5 +1,5 @@
>  # GNU Guix --- Functional package management for GNU
> -# Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
> <address@hidden>
> +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
> <address@hidden>
>  # Copyright © 2013 Andreas Enge <address@hidden>
>  # Copyright © 2015, 2017 Alex Kost <address@hidden>
>  # Copyright © 2016, 2018 Mathieu Lirzin <address@hidden>
> @@ -83,6 +83,7 @@ MODULES =                                   \
>    guix/gnu-maintenance.scm                   \
>    guix/upstream.scm                          \
>    guix/licenses.scm                          \
> +  guix/glob.scm                                      \
>    guix/git.scm                                       \
>    guix/graph.scm                             \
>    guix/cache.scm                             \
> @@ -314,6 +315,7 @@ SCM_TESTS =                                       \
>    tests/substitute.scm                               \
>    tests/builders.scm                         \
>    tests/derivations.scm                              \
> +  tests/glob.scm                             \
>    tests/grafts.scm                           \
>    tests/ui.scm                                       \
>    tests/records.scm                          \
> diff --git a/guix/glob.scm b/guix/glob.scm
> new file mode 100644
> index 000000000..4fc5173ac
> --- /dev/null
> +++ b/guix/glob.scm
> @@ -0,0 +1,97 @@
> +;;; GNU Guix --- Functional package management for GNU
> +;;; Copyright © 2018 Ludovic Courtès <address@hidden>
> +;;;
> +;;; This file is part of GNU Guix.
> +;;;
> +;;; GNU Guix is free software; you can redistribute it and/or modify it
> +;;; under the terms of the GNU General Public License as published by
> +;;; the Free Software Foundation; either version 3 of the License, or (at
> +;;; your option) any later version.
> +;;;
> +;;; GNU Guix is distributed in the hope that it will be useful, but
> +;;; WITHOUT ANY WARRANTY; without even the implied warranty of
> +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;;; GNU General Public License for more details.
> +;;;
> +;;; You should have received a copy of the GNU General Public License
> +;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
> +
> +(define-module (guix glob)
> +  #:use-module (ice-9 match)
> +  #:export (compile-glob-pattern
> +            glob-match?))
> +
> +;;; Commentary:
> +;;;
> +;;; This is a minimal implementation of "glob patterns" (info "(libc)
> +;;; Globbbing").  It is currently limited to simple patterns and does not
          ^^^
This made my brain stutter :-)

> +;;; support braces and square brackets, for instance.
> +;;;
> +;;; Code:
> +
> +(define (wildcard-indices str)
> +  "Return the list of indices in STR where wildcards can be found."
> +  (let loop ((index 0)
> +             (result '()))
> +    (if (= index (string-length str))
> +        (reverse result)
> +        (loop (+ 1 index)
> +              (case (string-ref str index)
> +                ((#\? #\*) (cons index result))
> +                (else      result))))))
> +
> +(define (compile-glob-pattern str)
> +  "Return an sexp that represents the compiled form of STR, a glob pattern
> +such as \"foo*\" or \"foo??bar\"."
> +  (define flatten
> +    (match-lambda
> +      (((? string? str)) str)
> +      (x x)))
> +
> +  (let loop ((index   0)
> +             (indices (wildcard-indices str))
> +             (result '()))
> +    (match indices
> +      (()
> +       (flatten (cond ((zero? index)
> +                       (list str))
> +                      ((= index (string-length str))
> +                       (reverse result))
> +                      (else
> +                       (reverse (cons (string-drop str index)
> +                                      result))))))
> +      ((wildcard-index . rest)
> +       (let ((wildcard (match (string-ref str wildcard-index)
> +                         (#\? '?)
> +                         (#\* '*))))
> +         (match (substring str index wildcard-index)
> +           (""  (loop (+ 1 wildcard-index)
> +                      rest
> +                      (cons wildcard result)))
> +           (str (loop (+ 1 wildcard-index)
> +                      rest
> +                      (cons* wildcard str result)))))))))
> +
> +(define (glob-match? pattern str)
> +  "Return true if STR matches PATTERN, a compiled glob pattern as returned by
> +'compile-glob-pattern'."
> +  (let loop ((pattern pattern)
> +             (str str))
> +   (match pattern
> +     ((? string? literal) (string=? literal str))
> +     (((? string? one))   (string=? one str))
> +     (('*)  #t)
> +     (('?) (= 1 (string-length str)))
> +     (()    #t)
> +     (('* suffix . rest)
> +      (match (string-contains str suffix)
> +        (#f    #f)
> +        (index (loop rest
> +                     (string-drop str
> +                                  (+ index (string-length suffix)))))))
> +     (('? . rest)
> +      (and (>= (string-length str) 1)
> +           (loop rest (string-drop str 1))))
> +     ((prefix . rest)
> +      (and (string-prefix? prefix str)
> +           (loop rest (string-drop str (string-length prefix))))))))
> diff --git a/tests/glob.scm b/tests/glob.scm
> new file mode 100644
> index 000000000..033eeb10f
> --- /dev/null
> +++ b/tests/glob.scm
> @@ -0,0 +1,58 @@
> +;;; GNU Guix --- Functional package management for GNU
> +;;; Copyright © 2018 Ludovic Courtès <address@hidden>
> +;;;
> +;;; This file is part of GNU Guix.
> +;;;
> +;;; GNU Guix is free software; you can redistribute it and/or modify it
> +;;; under the terms of the GNU General Public License as published by
> +;;; the Free Software Foundation; either version 3 of the License, or (at
> +;;; your option) any later version.
> +;;;
> +;;; GNU Guix is distributed in the hope that it will be useful, but
> +;;; WITHOUT ANY WARRANTY; without even the implied warranty of
> +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;;; GNU General Public License for more details.
> +;;;
> +;;; You should have received a copy of the GNU General Public License
> +;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
> +
> +(define-module (test-glob)
> +  #:use-module (guix glob)
> +  #:use-module (srfi srfi-64))
> +
> +
> +(test-begin "glob")
> +
> +(test-equal "compile-glob-pattern, no wildcards"
> +  "foo"
> +  (compile-glob-pattern "foo"))
> +
> +(test-equal "compile-glob-pattern, Kleene star"
> +  '("foo" * "bar")
> +  (compile-glob-pattern "foo*bar"))
> +
> +(test-equal "compile-glob-pattern, question mark"
> +  '(? "foo" *)
> +  (compile-glob-pattern "?foo*"))
> +
> +(test-assert "literal match"
> +  (let ((pattern (compile-glob-pattern "foo")))
> +    (and (glob-match? pattern "foo")
> +         (not (glob-match? pattern "foobar"))
> +         (not (glob-match? pattern "barfoo")))))
> +
> +(test-assert "trailing star"
> +  (let ((pattern (compile-glob-pattern "foo*")))
> +    (and (glob-match? pattern "foo")
> +         (glob-match? pattern "foobar")
> +         (not (glob-match? pattern "xfoo")))))
> +
> +(test-assert "question marks"
> +  (let ((pattern (compile-glob-pattern "foo??bar")))
> +    (and (glob-match? pattern "fooxxbar")
> +         (glob-match? pattern "fooZZbar")
> +         (not (glob-match? pattern "foobar"))
> +         (not (glob-match? pattern "fooxxxbar"))
> +         (not (glob-match? pattern "fooxxbarzz")))))
> +
> +(test-end "glob")
> -- 
> 2.16.2

signature.asc
Description: PGP signature