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: