@@ -6,7 +6,8 @@
;;; Copyright © 2018, 2022 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
-;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2020, 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com>
@@ -111,8 +112,14 @@ (define-module (guix build utils)
modify-phases
with-atomic-file-replacement
+ %substitute-requires-matches?
substitute
substitute*
+ &substitute-error
+ substitute-error?
+ substitute-error-file
+ substitute-error-patterns
+
dump-port
set-file-time
patch-shebang
@@ -971,24 +978,51 @@ (define (replace-char c1 c2 s)
c))
s)))
-(define (substitute file pattern+procs)
+(define-condition-type &substitute-error &error
+ substitute-error?
+ (file substitute-error-file)
+ (patterns substitute-error-patterns))
+
+(define %substitute-requires-matches?
+ (make-parameter #t))
+
+(define* (substitute file pattern+procs
+ #:key (require-matches? (%substitute-requires-matches?)))
"PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each
line of FILE, and for each PATTERN that it matches, call the corresponding
PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
a substitution of the original line. Be careful about using '$' to match the
-end of a line; by itself it won't match the terminating newline of a line."
- (let ((rx+proc (map (match-lambda
- (((? regexp? pattern) . proc)
+end of a line; by itself it won't match the terminating newline of a line.
+
+By default, SUBSTITUTE will raise a &substitute-error condition if one of the
+patterns fails to match. REQUIRE-MATCHES? can be set to false when lack of
+matches is acceptable (e.g. if you have multiple potential patterns not
+guaranteed to be found in FILE)."
+ (define (rx->pattern m)
+ (match m
+ ((? regexp? pattern)
+ "<unknown pattern (regexp)>")
+ ((? regexp*? pattern)
+ (regexp*-pattern pattern))
+ ((? string? pattern)
+ pattern)))
+
+ (let ((rx+proc (map (match-lambda
+ (((or (? regexp? pattern) (? regexp*? pattern)) . proc)
(cons pattern proc))
((pattern . proc)
- (cons (make-regexp pattern regexp/extended)
- proc)))
- pattern+procs)))
+ (cons (make-regexp* pattern regexp/extended) proc)))
+ pattern+procs)))
(with-atomic-file-replacement file
(lambda (in out)
- (let loop ((line (read-line in 'concat)))
+ (let loop ((line (read-line in 'concat))
+ (unmatched-regexps (map first rx+proc)))
(if (eof-object? line)
- #t
+ (when (and require-matches? (not (null? unmatched-regexps)))
+ (raise (condition
+ (&substitute-error
+ (file file)
+ (patterns (map rx->pattern unmatched-regexps))))))
;; Work around the fact that Guile's regexp-exec does not handle
;; NUL characters (a limitation of the underlying GNU libc's
;; regexec) by temporarily replacing them by an unused private
@@ -998,19 +1032,23 @@ (define (substitute file pattern+procs)
(unused-private-use-code-point line))
#\nul))
(line* (replace-char #\nul nul* line))
- (line1* (fold (lambda (r+p line)
- (match r+p
- ((regexp . proc)
- (match (list-matches regexp line)
- ((and m+ (_ _ ...))
- (proc line m+))
- (_ line)))))
- line*
- rx+proc))
+ (results ;line, unmatched-regexps
+ (fold (lambda (r+p results)
+ (let ((line (first results))
+ (unmatched (second results)))
+ (match r+p
+ ((regexp . proc)
+ (match (list-matches* regexp line)
+ ((and m+ (_ _ ...))
+ (list (proc line m+)
+ (delq regexp unmatched)))
+ (_ (list line unmatched)))))))
+ (list line* unmatched-regexps)
+ rx+proc))
+ (line1* (first results))
(line1 (replace-char nul* #\nul line1*)))
(display line1 out)
- (loop (read-line in 'concat)))))))))
-
+ (loop (read-line in 'concat) (second results)))))))))
(define-syntax let-matches
;; Helper macro for `substitute*'.
@@ -1048,9 +1086,19 @@ (define-syntax substitute*
Alternatively, FILE may be a list of file names, in which case they are
all subject to the substitutions.
+By default, SUBSTITUTE* will raise a &message condition if one of the patterns
+fails to match on one of the files; REQUIRE-MATCHES? may be set to false to
+avoid an error being raised in such condition.
+
Be careful about using '$' to match the end of a line; by itself it won't
match the terminating newline of a line."
((substitute* file ((regexp match-var ...) body ...) ...)
+ (substitute* file
+ ((regexp match-var ...) body ...) ...
+ #:require-matches? #t))
+ ((substitute* file
+ ((regexp match-var ...) body ...) ...
+ #:require-matches? require-matches?)
(let ()
(define (substitute-one-file file-name)
(substitute
@@ -1074,7 +1122,8 @@ (define-syntax substitute*
(begin body ...)
(substring l o (match:start m))
r))))))))
- ...)))
+ ...)
+ #:require-matches? require-matches?))
(match file
((files (... ...))
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
;;;
@@ -289,26 +289,52 @@ (define (arg-test bash-args)
(test-assert "wrap-script, argument handling, bash --norc"
(arg-test " --norc"))
-(test-equal "substitute*, text contains a NUL byte, UTF-8"
- "c\0d"
- (with-fluids ((%default-port-encoding "UTF-8")
- (%default-port-conversion-strategy 'error))
- ;; The GNU libc is locale sensitive. Depending on the value of LANG, the
- ;; test could fail with "string contains #\\nul character: ~S" or "cannot
- ;; convert wide string to output locale".
- (setlocale LC_ALL "en_US.UTF-8")
- (call-with-temporary-output-file
- (lambda (file port)
- (format port "a\0b")
- (flush-output-port port)
-
- (substitute* file
- (("a") "c")
- (("b") "d"))
-
- (with-input-from-file file
- (lambda _
- (get-string-all (current-input-port))))))))
+(define-syntax-rule (define-substitute*-test test-type name expected
+ content clauses ...)
+ (test-type
+ name
+ expected
+ (with-fluids ((%default-port-encoding "UTF-8")
+ (%default-port-conversion-strategy 'error))
+ ;; The GNU libc is locale sensitive. Depending on the value of LANG,
+ ;; the test could fail with "string contains #\\nul character: ~S" or
+ ;; "cannot convert wide string to output locale".
+ (setlocale LC_ALL "en_US.UTF-8")
+ (call-with-temporary-output-file
+ (lambda (file port)
+ (format port content)
+ (flush-output-port port)
+
+ (substitute* file
+ clauses ...)
+
+ (with-input-from-file file
+ (lambda _
+ (get-string-all (current-input-port)))))))))
+
+(define-substitute*-test test-equal
+ "substitute*, text contains a NUL byte, UTF-8"
+ "c\0d" ;expected
+ "a\0b" ;content
+ (("a") "c")
+ (("b") "d"))
+
+(define-substitute*-test test-error "substitute*, no match error"
+ #t ;expected
+ "a\0b" ;content
+ (("Oops!") "c"))
+
+(define-substitute*-test test-equal "substitute*, no match, ignored"
+ "abc" ;expected
+ "abc" ;content
+ (("Oops!") "c")
+ #:require-matches? #f)
+
+(define-substitute*-test test-error "substitute*, partial no match error"
+ #t ;expected
+ "a\0b" ;content
+ (("a") "c"
+ ("Oops!") "c"))
(test-equal "search-input-file: exception if not found"
`((path)
From: Jakub Kądziołka <kuba@kadziolka.net> * guix/build/utils.scm (substitute, substitute*) [require-matches?]: New argument. * tests/build-utils.scm ("substitute*"): New test group. ("substitute*, no match error") ("substitute*, partial no match error"): New tests. Co-authored-by: Maxim Cournoyer <maxim.cournoyer@gmail.com> Change-Id: I66ed33d72aa73cd35e5642521efec70bf756f86e --- guix/build/utils.scm | 93 +++++++++++++++++++++++++++++++++---------- tests/build-utils.scm | 68 +++++++++++++++++++++---------- 2 files changed, 118 insertions(+), 43 deletions(-)