1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix glob)
20 #:use-module (ice-9 match)
21 #:export (compile-glob-pattern
26 ;;; This is a minimal implementation of "glob patterns" (info "(libc)
27 ;;; Globbbing"). It is currently limited to simple patterns and does not
28 ;;; support braces and square brackets, for instance.
32 (define (wildcard-indices str)
33 "Return the list of indices in STR where wildcards can be found."
36 (if (= index (string-length str))
39 (case (string-ref str index)
40 ((#\? #\*) (cons index result))
43 (define (compile-glob-pattern str)
44 "Return an sexp that represents the compiled form of STR, a glob pattern
45 such as \"foo*\" or \"foo??bar\"."
48 (((? string? str)) str)
52 (indices (wildcard-indices str))
56 (flatten (cond ((zero? index)
58 ((= index (string-length str))
61 (reverse (cons (string-drop str index)
63 ((wildcard-index . rest)
64 (let ((wildcard (match (string-ref str wildcard-index)
67 (match (substring str index wildcard-index)
68 ("" (loop (+ 1 wildcard-index)
70 (cons wildcard result)))
71 (str (loop (+ 1 wildcard-index)
73 (cons* wildcard str result)))))))))
75 (define (glob-match? pattern str)
76 "Return true if STR matches PATTERN, a compiled glob pattern as returned by
77 'compile-glob-pattern'."
78 (let loop ((pattern pattern)
81 ((? string? literal) (string=? literal str))
82 (((? string? one)) (string=? one str))
84 (('?) (= 1 (string-length str)))
87 (match (string-contains str suffix)
91 (+ index (string-length suffix)))))))
93 (and (>= (string-length str) 1)
94 (loop rest (string-drop str 1))))
96 (and (string-prefix? prefix str)
97 (loop rest (string-drop str (string-length prefix))))))))