Commit | Line | Data |
---|---|---|
f14c933d LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> | |
371ba7b4 | 3 | ;;; Copyright © 2020 Giacomo Leidi <goodoldpaul@autistici.org> |
f14c933d LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix glob) | |
21 | #:use-module (ice-9 match) | |
71e08fde LC |
22 | #:export (string->sglob |
23 | compile-sglob | |
24 | string->compiled-sglob | |
f14c933d LC |
25 | glob-match?)) |
26 | ||
27 | ;;; Commentary: | |
28 | ;;; | |
29 | ;;; This is a minimal implementation of "glob patterns" (info "(libc) | |
30 | ;;; Globbbing"). It is currently limited to simple patterns and does not | |
e914b398 | 31 | ;;; support braces, for instance. |
f14c933d LC |
32 | ;;; |
33 | ;;; Code: | |
34 | ||
e914b398 LC |
35 | (define (parse-bracket chars) |
36 | "Parse CHARS, a list of characters that extracted from a '[...]' sequence." | |
37 | (match chars | |
38 | ((start #\- end) | |
39 | `(range ,start ,end)) | |
40 | (lst | |
41 | `(set ,@lst)))) | |
f14c933d | 42 | |
71e08fde LC |
43 | (define (string->sglob str) |
44 | "Return an sexp, called an \"sglob\", that represents the compiled form of | |
45 | STR, a glob pattern such as \"foo*\" or \"foo??bar\"." | |
f14c933d LC |
46 | (define flatten |
47 | (match-lambda | |
48 | (((? string? str)) str) | |
49 | (x x))) | |
50 | ||
e914b398 LC |
51 | (define (cons-string chars lst) |
52 | (match chars | |
53 | (() lst) | |
54 | (_ (cons (list->string (reverse chars)) lst)))) | |
55 | ||
56 | (let loop ((chars (string->list str)) | |
57 | (pending '()) | |
58 | (brackets 0) | |
f14c933d | 59 | (result '())) |
e914b398 | 60 | (match chars |
f14c933d | 61 | (() |
e914b398 LC |
62 | (flatten (reverse (if (null? pending) |
63 | result | |
64 | (cons-string pending result))))) | |
371ba7b4 GL |
65 | ((#\* #\* #\/ . rest) |
66 | (if (zero? brackets) | |
67 | (loop rest '() 0 | |
68 | (cons* '**/ (cons-string pending result))) | |
69 | (loop rest (cons '**/ pending) brackets result))) | |
e914b398 LC |
70 | (((and chr (or #\? #\*)) . rest) |
71 | (let ((wildcard (match chr | |
f14c933d LC |
72 | (#\? '?) |
73 | (#\* '*)))) | |
e914b398 LC |
74 | (if (zero? brackets) |
75 | (loop rest '() 0 | |
76 | (cons* wildcard (cons-string pending result))) | |
77 | (loop rest (cons chr pending) brackets result)))) | |
78 | ((#\[ . rest) | |
79 | (if (zero? brackets) | |
80 | (loop rest '() (+ 1 brackets) | |
81 | (cons-string pending result)) | |
82 | (loop rest (cons #\[ pending) (+ 1 brackets) result))) | |
83 | ((#\] . rest) | |
84 | (cond ((zero? brackets) | |
85 | (error "unexpected closing bracket" str)) | |
86 | ((= 1 brackets) | |
87 | (loop rest '() 0 | |
88 | (cons (parse-bracket (reverse pending)) result))) | |
89 | (else | |
90 | (loop rest (cons #\] pending) (- brackets 1) result)))) | |
91 | ((chr . rest) | |
92 | (loop rest (cons chr pending) brackets result))))) | |
f14c933d | 93 | |
71e08fde LC |
94 | (define (compile-sglob sglob) |
95 | "Compile SGLOB into a more efficient representation." | |
96 | (if (string? sglob) | |
97 | sglob | |
98 | (let loop ((sglob sglob) | |
99 | (result '())) | |
100 | (match sglob | |
101 | (() | |
102 | (reverse result)) | |
103 | (('? . rest) | |
104 | (loop rest (cons char-set:full result))) | |
105 | ((('range start end) . rest) | |
106 | (loop rest (cons (ucs-range->char-set | |
107 | (char->integer start) | |
108 | (+ 1 (char->integer end))) | |
109 | result))) | |
110 | ((('set . chars) . rest) | |
111 | (loop rest (cons (list->char-set chars) result))) | |
112 | ((head . rest) | |
113 | (loop rest (cons head result))))))) | |
114 | ||
115 | (define string->compiled-sglob | |
116 | (compose compile-sglob string->sglob)) | |
117 | ||
f14c933d LC |
118 | (define (glob-match? pattern str) |
119 | "Return true if STR matches PATTERN, a compiled glob pattern as returned by | |
71e08fde | 120 | 'compile-sglob'." |
f14c933d LC |
121 | (let loop ((pattern pattern) |
122 | (str str)) | |
123 | (match pattern | |
e914b398 LC |
124 | ((? string? literal) |
125 | (string=? literal str)) | |
126 | (() | |
127 | (string-null? str)) | |
128 | (('*) | |
129 | #t) | |
371ba7b4 GL |
130 | (('**/) |
131 | #t) | |
132 | (('**/ suffix . rest) | |
133 | (let ((rest (if (eq? '* suffix) (cdr rest) rest)) | |
134 | (suffix (if (eq? '* suffix) (car rest) suffix))) | |
135 | (match (string-contains str suffix) | |
136 | (#f #f) | |
137 | (index (loop rest (string-drop str | |
138 | (+ index (string-length suffix)))))))) | |
f14c933d LC |
139 | (('* suffix . rest) |
140 | (match (string-contains str suffix) | |
141 | (#f #f) | |
142 | (index (loop rest | |
143 | (string-drop str | |
144 | (+ index (string-length suffix))))))) | |
71e08fde | 145 | (((? char-set? cs) . rest) |
e914b398 LC |
146 | (and (>= (string-length str) 1) |
147 | (let ((chr (string-ref str 0))) | |
71e08fde | 148 | (and (char-set-contains? cs chr) |
e914b398 | 149 | (loop rest (string-drop str 1)))))) |
f14c933d LC |
150 | ((prefix . rest) |
151 | (and (string-prefix? prefix str) | |
152 | (loop rest (string-drop str (string-length prefix)))))))) |