summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/build/utils.scm87
-rw-r--r--tests/build-utils.scm34
2 files changed, 120 insertions, 1 deletions
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 20e8cdf3e8..d1d3116c45 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -36,7 +36,9 @@
substitute
substitute*
dump-port
- patch-shebang))
+ patch-shebang
+ fold-port-matches
+ remove-store-references))
;;;
@@ -336,6 +338,89 @@ patched, #f otherwise."
file (basename cmd))
#f)))))))))))))
+(define* (fold-port-matches proc init pattern port
+ #:optional (unmatched (lambda (_ r) r)))
+ "Read from PORT character-by-character; for each match against
+PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
+PATTERN is a list of SRFI-14 char-sets. Call (UNMATCHED CHAR RESULT)
+for each unmatched character."
+ (define initial-pattern
+ ;; The poor developer's regexp.
+ (if (string? pattern)
+ (map char-set (string->list pattern))
+ pattern))
+
+ ;; Note: we're not really striving for performance here...
+ (let loop ((chars '())
+ (pattern initial-pattern)
+ (matched '())
+ (result init))
+ (cond ((null? chars)
+ (loop (list (get-char port))
+ pattern
+ matched
+ result))
+ ((null? pattern)
+ (loop chars
+ initial-pattern
+ '()
+ (proc (list->string (reverse matched)) result)))
+ ((eof-object? (car chars))
+ (fold-right unmatched result matched))
+ ((char-set-contains? (car pattern) (car chars))
+ (loop (cdr chars)
+ (cdr pattern)
+ (cons (car chars) matched)
+ result))
+ ((null? matched) ; common case
+ (loop (cdr chars)
+ pattern
+ matched
+ (unmatched (car chars) result)))
+ (else
+ (let ((matched (reverse matched)))
+ (loop (append (cdr matched) chars)
+ initial-pattern
+ '()
+ (unmatched (car matched) result)))))))
+
+(define* (remove-store-references file
+ #:optional (store (or (getenv "NIX_STORE")
+ "/nix/store")))
+ "Remove from FILE occurrences of file names in STORE; return #t when
+store paths were encountered in FILE, #f otherwise. This procedure is
+known as `nuke-refs' in Nixpkgs."
+ (define pattern
+ (let ((nix-base32-chars
+ '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+ #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
+ #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
+ `(,@(map char-set (string->list store))
+ ,(char-set #\/)
+ ,@(make-list 32 (list->char-set nix-base32-chars))
+ ,(char-set #\-))))
+
+ (with-fluids ((%default-port-encoding #f))
+ (with-atomic-file-replacement file
+ (lambda (in out)
+ ;; We cannot use `regexp-exec' here because it cannot deal with
+ ;; strings containing NUL characters.
+ (format #t "removing store references from `~a'...~%" file)
+ (setvbuf in _IOFBF 65536)
+ (setvbuf out _IOFBF 65536)
+ (fold-port-matches (lambda (match result)
+ (put-string out store)
+ (put-char out #\/)
+ (put-string out
+ "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-")
+ #t)
+ #f
+ pattern
+ in
+ (lambda (char result)
+ (put-char out char)
+ result))))))
+
;;; Local Variables:
;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 4d86037708..8140708397 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -47,6 +47,39 @@
(not (false-if-exception
(alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
+(test-equal "fold-port-matches"
+ (make-list 3 "Guix")
+ (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
+ (lambda (port)
+ (fold-port-matches cons '() "Guix" port))))
+
+(test-equal "fold-port-matches, trickier"
+ (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
+ (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
+ (lambda (port)
+ (fold-port-matches cons '()
+ (list (char-set #\G #\g)
+ (char-set #\u)
+ (char-set #\i)
+ (char-set #\x #\X))
+ port))))
+
+(test-equal "fold-port-matches, with unmatched chars"
+ '("Guix" #\, #\space
+ "guix" #\, #\space
+ #\G #\u #\i "Guix" "guiX" #\, #\space
+ "Guix")
+ (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
+ (lambda (port)
+ (reverse
+ (fold-port-matches cons '()
+ (list (char-set #\G #\g)
+ (char-set #\u)
+ (char-set #\i)
+ (char-set #\x #\X))
+ port
+ cons)))))
+
(test-end)
@@ -55,4 +88,5 @@
;;; Local Variables:
;;; eval: (put 'test-assert 'scheme-indent-function 1)
;;; eval: (put 'test-equal 'scheme-indent-function 1)
+;;; eval: (put 'call-with-input-string 'scheme-indent-function 1)
;;; End: