gnu: komikku: Update to 0.20.0.

[jackhill/guix/guix.git] / tests / grafts.scm

diff --git a/tests/grafts.scm b/tests/grafts.scm
index 08f05c0..a12c6a5 100644 (file)
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,11 +24,12 @@
   #:use-module (guix utils)
   #:use-module (guix grafts)
   #:use-module (guix tests)
-  #:use-module ((gnu packages) #:select (search-bootstrap-binary))
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
-  #:use-module (rnrs io ports))
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 vlist))
 
 (define %store
   (open-connection-for-tests))
@@ -43,13 +44,11 @@
 (define %mkdir
   (bootstrap-binary "mkdir"))
 
-(define make-derivation-input
-  (@@ (guix derivations) make-derivation-input))
-
 \f
 (test-begin "grafts")
 
-(test-assert "graft-derivation, grafted item is a direct dependency"
+(test-equal "graft-derivation, grafted item is a direct dependency"
+  '((type . graft) (graft (count . 2)))
   (let* ((build `(begin
                    (mkdir %output)
                    (chdir %output)
@@ -74,14 +73,16 @@
                                             (origin %mkdir)
                                             (replacement two))))))
     (and (build-derivations %store (list grafted))
-         (let ((two     (derivation->output-path two))
-               (grafted (derivation->output-path grafted)))
+         (let ((properties (derivation-properties grafted))
+               (two        (derivation->output-path two))
+               (grafted    (derivation->output-path grafted)))
            (and (string=? (format #f "foo/~a/bar" two)
                           (call-with-input-file (string-append grafted "/text")
                             get-string-all))
                 (string=? (readlink (string-append grafted "/sh")) one)
                 (string=? (readlink (string-append grafted "/self"))
-                          grafted))))))
+                          grafted)
+                properties)))))
 
 (test-assert "graft-derivation, grafted item uses a different name"
   (let* ((build   `(begin
@@ -351,16 +352,11 @@
                 (p1r-inputs  (filter (match-input p1r) inputs))
                 (p2-inputs   (filter (match-input p2) inputs)))
            (and (equal? p1-inputs
-                        (list (make-derivation-input (derivation-file-name p1)
-                                                     '("one"))))
+                        (list (derivation-input p1 '("one"))))
                 (equal? p1r-inputs
-                        (list
-                         (make-derivation-input (derivation-file-name p1r)
-                                                '("ONE"))))
+                        (list (derivation-input p1r '("ONE"))))
                 (equal? p2-inputs
-                        (list
-                         (make-derivation-input (derivation-file-name p2)
-                                                '("aaa"))))
+                        (list (derivation-input p2 '("aaa"))))
                 (derivation-output-names p2g))))))
 
 (test-assert "graft-derivation, renaming"         ;<http://bugs.gnu.org/23132>
@@ -442,4 +438,34 @@
            (and (file-exists? (string-append out "/p2/replacement"))
                 (file-exists? (string-append out "/p2/p1/replacement")))))))
 
+(define buffer-size
+  ;; Must be equal to REQUEST-SIZE in 'replace-store-references'.
+  (expt 2 20))
+
+(test-equal "replace-store-references, <http://bugs.gnu.org/28212>"
+  (string-append (make-string (- buffer-size 47) #\a)
+                 "/gnu/store/" (make-string 32 #\8)
+                 "-SoMeTHiNG"
+                 (list->string (map integer->char (iota 77 33))))
+
+  ;; Create input data where the right-hand-size of the dash ("-something"
+  ;; here) goes beyond the end of the internal buffer of
+  ;; 'replace-store-references'.
+  (let* ((content     (string-append (make-string (- buffer-size 47) #\a)
+                                     "/gnu/store/" (make-string 32 #\7)
+                                     "-something"
+                                     (list->string
+                                      (map integer->char (iota 77 33)))))
+         (replacement (alist->vhash
+                       `((,(make-string 32 #\7)
+                          . ,(string->utf8 (string-append
+                                            (make-string 32 #\8)
+                                            "-SoMeTHiNG")))))))
+    (call-with-output-string
+      (lambda (output)
+        ((@@ (guix build graft) replace-store-references)
+         (open-input-string content) output
+         replacement
+         "/gnu/store")))))
+
 (test-end)