Ludovic Courtès 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 > +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès > # Copyright © 2013 Andreas Enge > # Copyright © 2015, 2017 Alex Kost > # Copyright © 2016, 2018 Mathieu Lirzin > @@ -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 > +;;; > +;;; 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 . > + > +(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 > +;;; > +;;; 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 . > + > +(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