Commit | Line | Data |
---|---|---|
7adf9b84 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1ba0b1e6 | 2 | ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
1bab9b9f | 3 | ;;; Copyright © 2021 Mark H Weaver <mhw@netris.org> |
7adf9b84 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (test-grafts) | |
c22a1324 LC |
21 | #:use-module (guix gexp) |
22 | #:use-module (guix monads) | |
7adf9b84 LC |
23 | #:use-module (guix derivations) |
24 | #:use-module (guix store) | |
25 | #:use-module (guix utils) | |
26 | #:use-module (guix grafts) | |
27 | #:use-module (guix tests) | |
c22a1324 LC |
28 | #:use-module (gnu packages bootstrap) |
29 | #:use-module (srfi srfi-1) | |
7adf9b84 | 30 | #:use-module (srfi srfi-64) |
94e86a6b LC |
31 | #:use-module (rnrs bytevectors) |
32 | #:use-module (rnrs io ports) | |
33 | #:use-module (ice-9 vlist)) | |
7adf9b84 LC |
34 | |
35 | (define %store | |
36 | (open-connection-for-tests)) | |
37 | ||
38 | (define (bootstrap-binary name) | |
39 | (let ((bin (search-bootstrap-binary name (%current-system)))) | |
40 | (and %store | |
41 | (add-to-store %store name #t "sha256" bin)))) | |
42 | ||
43 | (define %bash | |
44 | (bootstrap-binary "bash")) | |
45 | (define %mkdir | |
46 | (bootstrap-binary "mkdir")) | |
47 | ||
48 | \f | |
49 | (test-begin "grafts") | |
50 | ||
64fd1c01 LC |
51 | (test-equal "graft-derivation, grafted item is a direct dependency" |
52 | '((type . graft) (graft (count . 2))) | |
7adf9b84 LC |
53 | (let* ((build `(begin |
54 | (mkdir %output) | |
55 | (chdir %output) | |
56 | (symlink %output "self") | |
57 | (call-with-output-file "text" | |
58 | (lambda (output) | |
59 | (format output "foo/~a/bar" ,%mkdir))) | |
60 | (symlink ,%bash "sh"))) | |
c22a1324 | 61 | (orig (build-expression->derivation %store "grafted" build |
7adf9b84 LC |
62 | #:inputs `(("a" ,%bash) |
63 | ("b" ,%mkdir)))) | |
64 | (one (add-text-to-store %store "bash" "fake bash")) | |
65 | (two (build-expression->derivation %store "mkdir" | |
66 | '(call-with-output-file %output | |
67 | (lambda (port) | |
68 | (display "fake mkdir" port))))) | |
c22a1324 LC |
69 | (grafted (graft-derivation %store orig |
70 | (list (graft | |
71 | (origin %bash) | |
72 | (replacement one)) | |
73 | (graft | |
74 | (origin %mkdir) | |
75 | (replacement two)))))) | |
76 | (and (build-derivations %store (list grafted)) | |
64fd1c01 LC |
77 | (let ((properties (derivation-properties grafted)) |
78 | (two (derivation->output-path two)) | |
79 | (grafted (derivation->output-path grafted))) | |
7adf9b84 | 80 | (and (string=? (format #f "foo/~a/bar" two) |
c22a1324 | 81 | (call-with-input-file (string-append grafted "/text") |
7adf9b84 | 82 | get-string-all)) |
c22a1324 LC |
83 | (string=? (readlink (string-append grafted "/sh")) one) |
84 | (string=? (readlink (string-append grafted "/self")) | |
64fd1c01 LC |
85 | grafted) |
86 | properties))))) | |
c22a1324 | 87 | |
57bdd79e LC |
88 | (test-assert "graft-derivation, grafted item uses a different name" |
89 | (let* ((build `(begin | |
90 | (mkdir %output) | |
91 | (chdir %output) | |
92 | (symlink %output "self") | |
93 | (symlink ,%bash "sh"))) | |
94 | (orig (build-expression->derivation %store "grafted" build | |
95 | #:inputs `(("a" ,%bash)))) | |
96 | (repl (add-text-to-store %store "BaSH" "fake bash")) | |
97 | (grafted (graft-derivation %store orig | |
98 | (list (graft | |
99 | (origin %bash) | |
100 | (replacement repl)))))) | |
101 | (and (build-derivations %store (list grafted)) | |
102 | (let ((grafted (derivation->output-path grafted))) | |
103 | (and (string=? (readlink (string-append grafted "/sh")) repl) | |
104 | (string=? (readlink (string-append grafted "/self")) | |
105 | grafted)))))) | |
106 | ||
c22a1324 LC |
107 | ;; Make sure 'derivation-file-name' always gets to see an absolute file name. |
108 | (fluid-set! %file-port-name-canonicalization 'absolute) | |
109 | ||
110 | (test-assert "graft-derivation, grafted item is an indirect dependency" | |
111 | (let* ((build `(begin | |
112 | (mkdir %output) | |
113 | (chdir %output) | |
114 | (symlink %output "self") | |
115 | (call-with-output-file "text" | |
116 | (lambda (output) | |
117 | (format output "foo/~a/bar" ,%mkdir))) | |
118 | (symlink ,%bash "sh"))) | |
119 | (dep (build-expression->derivation %store "dep" build | |
120 | #:inputs `(("a" ,%bash) | |
121 | ("b" ,%mkdir)))) | |
122 | (orig (build-expression->derivation %store "thing" | |
123 | '(symlink | |
124 | (assoc-ref %build-inputs | |
125 | "dep") | |
126 | %output) | |
127 | #:inputs `(("dep" ,dep)))) | |
128 | (one (add-text-to-store %store "bash" "fake bash")) | |
129 | (two (build-expression->derivation %store "mkdir" | |
130 | '(call-with-output-file %output | |
131 | (lambda (port) | |
132 | (display "fake mkdir" port))))) | |
133 | (grafted (graft-derivation %store orig | |
134 | (list (graft | |
135 | (origin %bash) | |
136 | (replacement one)) | |
137 | (graft | |
138 | (origin %mkdir) | |
139 | (replacement two)))))) | |
140 | (and (build-derivations %store (list grafted)) | |
141 | (let* ((two (derivation->output-path two)) | |
142 | (grafted (derivation->output-path grafted)) | |
143 | (dep (readlink grafted))) | |
144 | (and (string=? (format #f "foo/~a/bar" two) | |
145 | (call-with-input-file (string-append dep "/text") | |
146 | get-string-all)) | |
147 | (string=? (readlink (string-append dep "/sh")) one) | |
148 | (string=? (readlink (string-append dep "/self")) dep) | |
149 | (equal? (references %store grafted) (list dep)) | |
150 | (lset= string=? | |
151 | (list one two dep) | |
152 | (references %store dep))))))) | |
153 | ||
cf8b312d LC |
154 | (test-assert "graft-derivation, preserve empty directories" |
155 | (run-with-store %store | |
156 | (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) | |
157 | (graft -> (graft | |
158 | (origin %bash) | |
159 | (replacement fake))) | |
160 | (drv (gexp->derivation | |
161 | "to-graft" | |
66a35ceb LC |
162 | (with-imported-modules '((guix build utils)) |
163 | #~(begin | |
164 | (use-modules (guix build utils)) | |
165 | (mkdir-p (string-append #$output | |
166 | "/a/b/c/d")) | |
167 | (symlink #$%bash | |
168 | (string-append #$output | |
169 | "/bash")))))) | |
cf8b312d LC |
170 | (grafted ((store-lift graft-derivation) drv |
171 | (list graft))) | |
172 | (_ (built-derivations (list grafted))) | |
173 | (out -> (derivation->output-path grafted))) | |
174 | (return (and (string=? (readlink (string-append out "/bash")) | |
175 | fake) | |
176 | (file-is-directory? (string-append out "/a/b/c/d"))))))) | |
177 | ||
c22a1324 LC |
178 | (test-assert "graft-derivation, no dependencies on grafted output" |
179 | (run-with-store %store | |
180 | (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) | |
181 | (graft -> (graft | |
182 | (origin %bash) | |
183 | (replacement fake))) | |
184 | (drv (gexp->derivation "foo" #~(mkdir #$output))) | |
185 | (grafted ((store-lift graft-derivation) drv | |
186 | (list graft)))) | |
187 | (return (eq? grafted drv))))) | |
7adf9b84 | 188 | |
f376dc3a LC |
189 | (test-assert "graft-derivation, multiple outputs" |
190 | (let* ((build `(begin | |
191 | (symlink (assoc-ref %build-inputs "a") | |
192 | (assoc-ref %outputs "one")) | |
193 | (symlink (assoc-ref %outputs "one") | |
194 | (assoc-ref %outputs "two")))) | |
195 | (orig (build-expression->derivation %store "grafted" build | |
196 | #:inputs `(("a" ,%bash)) | |
197 | #:outputs '("one" "two"))) | |
198 | (repl (add-text-to-store %store "bash" "fake bash")) | |
199 | (grafted (graft-derivation %store orig | |
200 | (list (graft | |
201 | (origin %bash) | |
202 | (replacement repl)))))) | |
203 | (and (build-derivations %store (list grafted)) | |
204 | (let ((one (derivation->output-path grafted "one")) | |
205 | (two (derivation->output-path grafted "two"))) | |
206 | (and (string=? (readlink one) repl) | |
207 | (string=? (readlink two) one)))))) | |
208 | ||
3d47aa81 LC |
209 | (test-assert "graft-derivation, replaced derivation has multiple outputs" |
210 | ;; Here we have a replacement just for output "one" of P1 and not for the | |
211 | ;; other output. Make sure the graft for P1:one correctly applies to the | |
212 | ;; dependents of P1. See <http://bugs.gnu.org/24712>. | |
213 | (let* ((p1 (build-expression->derivation | |
214 | %store "p1" | |
215 | `(let ((one (assoc-ref %outputs "one")) | |
216 | (two (assoc-ref %outputs "two"))) | |
217 | (mkdir one) | |
218 | (mkdir two)) | |
219 | #:outputs '("one" "two"))) | |
220 | (p1r (build-expression->derivation | |
221 | %store "P1" | |
222 | `(let ((other (assoc-ref %outputs "ONE"))) | |
223 | (mkdir other) | |
224 | (call-with-output-file (string-append other "/replacement") | |
225 | (const #t))) | |
226 | #:outputs '("ONE"))) | |
227 | (p2 (build-expression->derivation | |
228 | %store "p2" | |
229 | `(let ((out (assoc-ref %outputs "aaa"))) | |
230 | (mkdir (assoc-ref %outputs "zzz")) | |
231 | (mkdir out) (chdir out) | |
232 | (symlink (assoc-ref %build-inputs "p1:one") "one") | |
233 | (symlink (assoc-ref %build-inputs "p1:two") "two")) | |
234 | #:outputs '("aaa" "zzz") | |
235 | #:inputs `(("p1:one" ,p1 "one") | |
236 | ("p1:two" ,p1 "two")))) | |
237 | (p3 (build-expression->derivation | |
238 | %store "p3" | |
239 | `(symlink (assoc-ref %build-inputs "p2:aaa") | |
240 | (assoc-ref %outputs "out")) | |
241 | #:inputs `(("p2:aaa" ,p2 "aaa") | |
242 | ("p2:zzz" ,p2 "zzz")))) | |
243 | (p1g (graft | |
244 | (origin p1) | |
245 | (origin-output "one") | |
246 | (replacement p1r) | |
247 | (replacement-output "ONE"))) | |
248 | (p3d (graft-derivation %store p3 (list p1g)))) | |
482fda27 LC |
249 | |
250 | (and (not (find (lambda (input) | |
251 | ;; INPUT should not be P2:zzz since the result of P3 | |
252 | ;; does not depend on it. See | |
253 | ;; <http://bugs.gnu.org/24886>. | |
254 | (and (string=? (derivation-input-path input) | |
255 | (derivation-file-name p2)) | |
256 | (member "zzz" | |
257 | (derivation-input-sub-derivations input)))) | |
258 | (derivation-inputs p3d))) | |
259 | ||
260 | (build-derivations %store (list p3d)) | |
3d47aa81 LC |
261 | (let ((out (derivation->output-path (pk 'p2d p3d)))) |
262 | (and (not (string=? (readlink out) | |
263 | (derivation->output-path p2 "aaa"))) | |
264 | (string=? (derivation->output-path p1 "two") | |
265 | (readlink (string-append out "/two"))) | |
266 | (file-exists? (string-append out "/one/replacement"))))))) | |
267 | ||
482fda27 LC |
268 | (test-assert "graft-derivation with #:outputs" |
269 | ;; Call 'graft-derivation' with a narrowed set of outputs passed as | |
270 | ;; #:outputs. | |
271 | (let* ((p1 (build-expression->derivation | |
272 | %store "p1" | |
273 | `(let ((one (assoc-ref %outputs "one")) | |
274 | (two (assoc-ref %outputs "two"))) | |
275 | (mkdir one) | |
276 | (mkdir two)) | |
277 | #:outputs '("one" "two"))) | |
278 | (p1r (build-expression->derivation | |
279 | %store "P1" | |
280 | `(let ((other (assoc-ref %outputs "ONE"))) | |
281 | (mkdir other) | |
282 | (call-with-output-file (string-append other "/replacement") | |
283 | (const #t))) | |
284 | #:outputs '("ONE"))) | |
285 | (p2 (build-expression->derivation | |
286 | %store "p2" | |
287 | `(let ((aaa (assoc-ref %outputs "aaa")) | |
288 | (zzz (assoc-ref %outputs "zzz"))) | |
289 | (mkdir zzz) (chdir zzz) | |
290 | (mkdir aaa) (chdir aaa) | |
291 | (symlink (assoc-ref %build-inputs "p1:two") "two")) | |
292 | #:outputs '("aaa" "zzz") | |
293 | #:inputs `(("p1:one" ,p1 "one") | |
294 | ("p1:two" ,p1 "two")))) | |
295 | (p1g (graft | |
296 | (origin p1) | |
297 | (origin-output "one") | |
298 | (replacement p1r) | |
299 | (replacement-output "ONE"))) | |
300 | (p2g (graft-derivation %store p2 (list p1g) | |
301 | #:outputs '("aaa")))) | |
302 | ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft. | |
303 | (eq? p2g p2))) | |
304 | ||
305 | (test-equal "graft-derivation, unused outputs not depended on" | |
306 | '("aaa") | |
307 | ||
308 | ;; Make sure that the result of 'graft-derivation' does not pull outputs | |
309 | ;; that are irrelevant to the grafting process. See | |
310 | ;; <http://bugs.gnu.org/24886>. | |
311 | (let* ((p1 (build-expression->derivation | |
312 | %store "p1" | |
313 | `(let ((one (assoc-ref %outputs "one")) | |
314 | (two (assoc-ref %outputs "two"))) | |
315 | (mkdir one) | |
316 | (mkdir two)) | |
317 | #:outputs '("one" "two"))) | |
318 | (p1r (build-expression->derivation | |
319 | %store "P1" | |
320 | `(let ((other (assoc-ref %outputs "ONE"))) | |
321 | (mkdir other) | |
322 | (call-with-output-file (string-append other "/replacement") | |
323 | (const #t))) | |
324 | #:outputs '("ONE"))) | |
325 | (p2 (build-expression->derivation | |
326 | %store "p2" | |
327 | `(let ((aaa (assoc-ref %outputs "aaa")) | |
328 | (zzz (assoc-ref %outputs "zzz"))) | |
329 | (mkdir zzz) (chdir zzz) | |
330 | (symlink (assoc-ref %build-inputs "p1:two") "two") | |
331 | (mkdir aaa) (chdir aaa) | |
332 | (symlink (assoc-ref %build-inputs "p1:one") "one")) | |
333 | #:outputs '("aaa" "zzz") | |
334 | #:inputs `(("p1:one" ,p1 "one") | |
335 | ("p1:two" ,p1 "two")))) | |
336 | (p1g (graft | |
337 | (origin p1) | |
338 | (origin-output "one") | |
339 | (replacement p1r) | |
340 | (replacement-output "ONE"))) | |
341 | (p2g (graft-derivation %store p2 (list p1g) | |
342 | #:outputs '("aaa")))) | |
343 | ||
344 | ;; Here P2G should only depend on P1:one and P1R:one; it must not depend | |
345 | ;; on P1:two or P1R:two since these are unused in the grafting process. | |
346 | (and (not (eq? p2g p2)) | |
347 | (let* ((inputs (derivation-inputs p2g)) | |
348 | (match-input (lambda (drv) | |
349 | (lambda (input) | |
350 | (string=? (derivation-input-path input) | |
351 | (derivation-file-name drv))))) | |
352 | (p1-inputs (filter (match-input p1) inputs)) | |
353 | (p1r-inputs (filter (match-input p1r) inputs)) | |
354 | (p2-inputs (filter (match-input p2) inputs))) | |
355 | (and (equal? p1-inputs | |
c89985d9 | 356 | (list (derivation-input p1 '("one")))) |
482fda27 | 357 | (equal? p1r-inputs |
c89985d9 | 358 | (list (derivation-input p1r '("ONE")))) |
482fda27 | 359 | (equal? p2-inputs |
c89985d9 | 360 | (list (derivation-input p2 '("aaa")))) |
482fda27 LC |
361 | (derivation-output-names p2g)))))) |
362 | ||
ece6864b LC |
363 | (test-assert "graft-derivation, renaming" ;<http://bugs.gnu.org/23132> |
364 | (let* ((build `(begin | |
365 | (use-modules (guix build utils)) | |
366 | (mkdir-p (string-append (assoc-ref %outputs "out") "/" | |
367 | (assoc-ref %build-inputs "in"))))) | |
368 | (orig (build-expression->derivation %store "thing-to-graft" build | |
369 | #:modules '((guix build utils)) | |
370 | #:inputs `(("in" ,%bash)))) | |
371 | (repl (add-text-to-store %store "bash" "fake bash")) | |
372 | (grafted (graft-derivation %store orig | |
373 | (list (graft | |
374 | (origin %bash) | |
375 | (replacement repl)))))) | |
376 | (and (build-derivations %store (list grafted)) | |
377 | (let ((out (derivation->output-path grafted))) | |
378 | (file-is-directory? (string-append out "/" repl)))))) | |
379 | ||
b013c33f LC |
380 | (test-assert "graft-derivation, grafts are not shadowed" |
381 | ;; We build a DAG as below, where dotted arrows represent replacements and | |
382 | ;; solid arrows represent dependencies: | |
383 | ;; | |
384 | ;; P1 ·············> P1R | |
385 | ;; |\__________________. | |
386 | ;; v v | |
387 | ;; P2 ·············> P2R | |
388 | ;; | | |
389 | ;; v | |
390 | ;; P3 | |
391 | ;; | |
392 | ;; We want to make sure that the two grafts we want to apply to P3 are | |
393 | ;; honored and not shadowed by other computed grafts. | |
394 | (let* ((p1 (build-expression->derivation | |
395 | %store "p1" | |
396 | '(mkdir (assoc-ref %outputs "out")))) | |
397 | (p1r (build-expression->derivation | |
398 | %store "P1" | |
399 | '(let ((out (assoc-ref %outputs "out"))) | |
400 | (mkdir out) | |
401 | (call-with-output-file (string-append out "/replacement") | |
402 | (const #t))))) | |
403 | (p2 (build-expression->derivation | |
404 | %store "p2" | |
405 | `(let ((out (assoc-ref %outputs "out"))) | |
406 | (mkdir out) | |
407 | (chdir out) | |
408 | (symlink (assoc-ref %build-inputs "p1") "p1")) | |
409 | #:inputs `(("p1" ,p1)))) | |
410 | (p2r (build-expression->derivation | |
411 | %store "P2" | |
412 | `(let ((out (assoc-ref %outputs "out"))) | |
413 | (mkdir out) | |
414 | (chdir out) | |
415 | (symlink (assoc-ref %build-inputs "p1") "p1") | |
416 | (call-with-output-file (string-append out "/replacement") | |
417 | (const #t))) | |
418 | #:inputs `(("p1" ,p1)))) | |
419 | (p3 (build-expression->derivation | |
420 | %store "p3" | |
421 | `(let ((out (assoc-ref %outputs "out"))) | |
422 | (mkdir out) | |
423 | (chdir out) | |
424 | (symlink (assoc-ref %build-inputs "p2") "p2")) | |
425 | #:inputs `(("p2" ,p2)))) | |
426 | (p1g (graft | |
427 | (origin p1) | |
428 | (replacement p1r))) | |
429 | (p2g (graft | |
430 | (origin p2) | |
431 | (replacement (graft-derivation %store p2r (list p1g))))) | |
432 | (p3d (graft-derivation %store p3 (list p1g p2g)))) | |
433 | (and (build-derivations %store (list p3d)) | |
434 | (let ((out (derivation->output-path (pk p3d)))) | |
435 | ;; Make sure OUT refers to the replacement of P2, which in turn | |
436 | ;; refers to the replacement of P1, as specified by P1G and P2G. | |
437 | ;; It used to be the case that P2G would be shadowed by a simple | |
438 | ;; P2->P2R graft, which is not what we want. | |
439 | (and (file-exists? (string-append out "/p2/replacement")) | |
440 | (file-exists? (string-append out "/p2/p1/replacement"))))))) | |
441 | ||
94e86a6b LC |
442 | (define buffer-size |
443 | ;; Must be equal to REQUEST-SIZE in 'replace-store-references'. | |
444 | (expt 2 20)) | |
445 | ||
446 | (test-equal "replace-store-references, <http://bugs.gnu.org/28212>" | |
447 | (string-append (make-string (- buffer-size 47) #\a) | |
448 | "/gnu/store/" (make-string 32 #\8) | |
449 | "-SoMeTHiNG" | |
450 | (list->string (map integer->char (iota 77 33)))) | |
451 | ||
452 | ;; Create input data where the right-hand-size of the dash ("-something" | |
453 | ;; here) goes beyond the end of the internal buffer of | |
454 | ;; 'replace-store-references'. | |
455 | (let* ((content (string-append (make-string (- buffer-size 47) #\a) | |
456 | "/gnu/store/" (make-string 32 #\7) | |
457 | "-something" | |
458 | (list->string | |
459 | (map integer->char (iota 77 33))))) | |
460 | (replacement (alist->vhash | |
461 | `((,(make-string 32 #\7) | |
462 | . ,(string->utf8 (string-append | |
463 | (make-string 32 #\8) | |
464 | "-SoMeTHiNG"))))))) | |
465 | (call-with-output-string | |
466 | (lambda (output) | |
467 | ((@@ (guix build graft) replace-store-references) | |
468 | (open-input-string content) output | |
469 | replacement | |
470 | "/gnu/store"))))) | |
471 | ||
1bab9b9f MW |
472 | (define (insert-nuls char-size str) |
473 | (string-join (map string (string->list str)) | |
474 | (make-string (- char-size 1) #\nul))) | |
475 | ||
476 | (define (nuls-to-underscores s) | |
477 | (string-replace-substring s "\0" "_")) | |
478 | ||
479 | (define (annotate-buffer-boundary s) | |
480 | (string-append (string-take s buffer-size) | |
481 | "|" | |
482 | (string-drop s buffer-size))) | |
483 | ||
484 | (define (abbreviate-leading-fill s) | |
485 | (let ((s* (string-trim s #\=))) | |
486 | (format #f "[~a =s]~a" | |
487 | (- (string-length s) | |
488 | (string-length s*)) | |
489 | s*))) | |
490 | ||
491 | (define (prettify-for-display s) | |
492 | (abbreviate-leading-fill | |
493 | (annotate-buffer-boundary | |
494 | (nuls-to-underscores s)))) | |
495 | ||
496 | (define (two-sample-refs-with-gap char-size1 char-size2 gap offset | |
497 | char1 name1 char2 name2) | |
498 | (string-append | |
499 | (make-string (- buffer-size offset) #\=) | |
500 | (insert-nuls char-size1 | |
501 | (string-append "/gnu/store/" (make-string 32 char1) name1)) | |
502 | gap | |
503 | (insert-nuls char-size2 | |
504 | (string-append "/gnu/store/" (make-string 32 char2) name2)) | |
505 | (list->string (map integer->char (iota 77 33))))) | |
506 | ||
507 | (define (sample-map-entry old-char new-char new-name) | |
508 | (cons (make-string 32 old-char) | |
509 | (string->utf8 (string-append (make-string 32 new-char) | |
510 | new-name)))) | |
511 | ||
512 | (define (test-two-refs-with-gap char-size1 char-size2 gap offset) | |
513 | (test-equal | |
514 | (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a" | |
515 | char-size1 char-size2 gap offset) | |
516 | (prettify-for-display | |
517 | (two-sample-refs-with-gap char-size1 char-size2 gap offset | |
518 | #\6 "-BlahBlaH" | |
519 | #\8"-SoMeTHiNG")) | |
520 | (prettify-for-display | |
521 | (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset | |
522 | #\5 "-blahblah" | |
523 | #\7 "-something")) | |
524 | (replacement (alist->vhash | |
525 | (list (sample-map-entry #\5 #\6 "-BlahBlaH") | |
526 | (sample-map-entry #\7 #\8 "-SoMeTHiNG"))))) | |
527 | (call-with-output-string | |
528 | (lambda (output) | |
529 | ((@@ (guix build graft) replace-store-references) | |
530 | (open-input-string content) output | |
531 | replacement | |
532 | "/gnu/store"))))))) | |
533 | ||
534 | (for-each (lambda (char-size1) | |
535 | (for-each (lambda (char-size2) | |
536 | (for-each (lambda (gap) | |
537 | (for-each (lambda (offset) | |
538 | (test-two-refs-with-gap char-size1 | |
539 | char-size2 | |
540 | gap | |
541 | offset)) | |
542 | ;; offsets to test | |
543 | (map (lambda (i) | |
544 | (+ i (* 40 char-size1))) | |
545 | (iota 30)))) | |
546 | ;; gaps | |
547 | '("" "-" " " "a"))) | |
548 | ;; char-size2 values to test | |
549 | '(1 2))) | |
550 | ;; char-size1 values to test | |
551 | '(1 2 4)) | |
552 | ||
553 | ||
7adf9b84 | 554 | (test-end) |