Browse Source

utils: Add `fold-port-matches' and `remove-store-references'.

* guix/build/utils.scm (fold-port-matches, remove-store-references): New
  procedures.

* tests/build-utils.scm ("fold-port-matches", "fold-port-matches,
  trickier", "fold-port-matches, with unmatched chars"): New tests.
gn-latest-20200428
Ludovic Courtès 9 years ago
parent
commit
91133c2d71
  1. 87
      guix/build/utils.scm
  2. 34
      tests/build-utils.scm

87
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)

34
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:
Loading…
Cancel
Save