From 91133c2d71960644eeba749027a4141c098ea64c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 16 Oct 2012 23:01:01 +0200
Subject: [PATCH] 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.
---
 guix/build/utils.scm  | 87 ++++++++++++++++++++++++++++++++++++++++++-
 tests/build-utils.scm | 34 +++++++++++++++++
 2 files changed, 120 insertions(+), 1 deletion(-)

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: