projects/guix·blob perlssl · refs

708 lines · 31.5 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016-2017, 2019-2024, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2021 Marius Bakke <[email protected]>
4;;; Copyright © 2026 Maxim Cournoyer <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (test-transformations)
22 #:use-module (guix tests)
23 #:use-module (guix store)
24 #:use-module ((guix gexp) #:select (lower-object))
25 #:use-module ((guix profiles)
26 #:select (package->manifest-entry
27 manifest-entry-properties))
28 #:use-module (guix derivations)
29 #:use-module (guix packages)
30 #:use-module (guix git-download)
31 #:use-module (guix build-system)
32 #:use-module (guix build-system gnu)
33 #:use-module (guix transformations)
34 #:use-module ((guix gexp)
35 #:select (local-file? local-file-file
36 computed-file? computed-file-gexp
37 gexp-input-thing gexp->approximate-sexp))
38 #:use-module (guix ui)
39 #:use-module (guix utils)
40 #:use-module (guix git)
41 #:use-module (guix upstream)
42 #:use-module (guix diagnostics)
43 #:use-module (gnu packages)
44 #:use-module (gnu packages base)
45 #:use-module (gnu packages busybox)
46 #:use-module (ice-9 match)
47 #:use-module (srfi srfi-1)
48 #:use-module (srfi srfi-26)
49 #:use-module (srfi srfi-34)
50 #:use-module (srfi srfi-64))
51
52
53(test-begin "transformations")
54
55(test-assert "options->transformation, no transformations"
56 (let ((p (dummy-package "foo"))
57 (t (options->transformation '())))
58 (eq? (t p) p)))
59
60(test-assert "options->transformation, with-source"
61 ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
62 ;; be applicable.
63 (let* ((p (dummy-package "guix.scm"))
64 (s (search-path %load-path "guix.scm"))
65 (t (options->transformation `((with-source . ,s)))))
66 (with-store store
67 (let* ((new (t p))
68 (source (run-with-store store
69 (lower-object (package-source new)))))
70 (and (not (eq? new p))
71 (string=? source
72 (add-to-store store "guix.scm" #t
73 "sha256" s)))))))
74
75(test-assert "options->transformation, with-source, replacement"
76 ;; Same, but this time the original package has a 'replacement' field. We
77 ;; expect that replacement to be set to #f in the new package.
78 (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
79 (s (search-path %load-path "guix.scm"))
80 (t (options->transformation `((with-source . ,s)))))
81 (let ((new (t p)))
82 (and (not (eq? new p))
83 (not (package-replacement new))))))
84
85(test-assert "options->transformation, with-source, with version"
86 ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
87 ;; should be applicable, and its version should be extracted.
88 (let ((p (dummy-package "foo"))
89 (s (search-path %load-path "guix.scm")))
90 (call-with-temporary-directory
91 (lambda (directory)
92 (let* ((f (string-append directory "/foo-42.0.tar.gz"))
93 (t (options->transformation `((with-source . ,f)))))
94 (copy-file s f)
95 (with-store store
96 (let* ((new (t p))
97 (source (run-with-store store
98 (lower-object (package-source new)))))
99 (and (not (eq? new p))
100 (string=? (package-name new) (package-name p))
101 (string=? (package-version new) "42.0")
102 (string=? source
103 (add-to-store store (basename f) #t
104 "sha256" f))))))))))
105
106(test-assert "options->transformation, with-source, no matches"
107 (let* ((p (dummy-package "foobar"))
108 (s (search-path %load-path "guix.scm"))
109 (t (options->transformation `((with-source . ,s)))))
110 (eq? (package-source (t p))
111 (package-source p))))
112
113(test-assert "options->transformation, with-source, PKG=URI"
114 (let* ((p (dummy-package "foo"))
115 (s (search-path %load-path "guix.scm"))
116 (f (string-append "foo=" s))
117 (t (options->transformation `((with-source . ,f)))))
118 (with-store store
119 (let* ((new (t p))
120 (source (run-with-store store
121 (lower-object (package-source new)))))
122 (and (not (eq? new p))
123 (string=? (package-name new) (package-name p))
124 (string=? (package-version new)
125 (package-version p))
126 (string=? source
127 (add-to-store store (basename s) #t
128 "sha256" s)))))))
129
130(test-assert "options->transformation, with-source, PKG@VER=URI"
131 (let* ((p (dummy-package "foo"))
132 (s (search-path %load-path "guix.scm"))
133 (f (string-append "[email protected]=" s))
134 (t (options->transformation `((with-source . ,f)))))
135 (with-store store
136 (let* ((new (t p))
137 (source (run-with-store store
138 (lower-object (package-source new)))))
139 (and (not (eq? new p))
140 (string=? (package-name new) (package-name p))
141 (string=? (package-version new) "42.0")
142 (string=? source
143 (add-to-store store (basename s) #t
144 "sha256" s)))))))
145
146(test-assert "options->transformation, with-source, in depth"
147 (let* ((p0 (dummy-package "foo" (version "0.0")))
148 (s (search-path %load-path "guix.scm"))
149 (f (string-append "[email protected]=" s))
150 (t (options->transformation `((with-source . ,f))))
151 (p1 (dummy-package "bar" (inputs (list p0))))
152 (p2 (dummy-package "baz" (inputs (list p1)))))
153 (with-store store
154 (let ((new (t p2)))
155 (and (not (eq? new p2))
156 (match (package-inputs new)
157 ((("bar" p1*))
158 (match (package-inputs p1*)
159 ((("foo" p0*))
160 (and (not (eq? p0* p0))
161 (string=? (package-name p0*) (package-name p0))
162 (string=? (package-version p0*) "42.0")
163 (string=? (add-to-store store (basename s) #t
164 "sha256" s)
165 (run-with-store store
166 (lower-object
167 (package-source p0*))))))))))))))
168
169(test-assert "options->transformation, with-input"
170 (let* ((p (dummy-package "guix.scm"
171 (inputs `(("foo" ,(specification->package "coreutils"))
172 ("bar" ,(specification->package "grep"))
173 ("baz" ,(dummy-package "chbouib"
174 (native-inputs `(("x" ,grep)))))))))
175 (t (options->transformation '((with-input . "coreutils=busybox")
176 (with-input . "grep=findutils")))))
177 (let ((new (t p)))
178 (and (not (eq? new p))
179 (match (package-inputs new)
180 ((("foo" dep1) ("bar" dep2) ("baz" dep3))
181 (and (string=? (package-full-name dep1)
182 (package-full-name busybox))
183 (string=? (package-full-name dep2)
184 (package-full-name findutils))
185 (string=? (package-name dep3) "chbouib")
186 (match (package-native-inputs dep3)
187 ((("x" dep))
188 (string=? (package-full-name dep)
189 (package-full-name findutils)))))))))))
190
191;; The following test requires grafting enabled, but it becomes extremely
192;; expensive if there's a graft on glibc or other package deep in the graph.
193(when (package-replacement (@ (gnu packages commencement) glibc-final))
194 (test-skip 1))
195
196(test-assert "options->transformation, with-graft"
197 (let* ((p (dummy-package "guix.scm"
198 (inputs `(("foo" ,grep)
199 ("bar" ,(dummy-package "chbouib"
200 (native-inputs `(("x" ,grep)))))))))
201 (t (options->transformation '((with-graft . "grep=findutils")))))
202 (let ((new (t p)))
203 (and (not (eq? new p))
204 (match (package-inputs new)
205 ((("foo" dep1) ("bar" dep2))
206 (and (string=? (package-full-name dep1)
207 (package-full-name grep))
208 (string=? (package-full-name (package-replacement dep1))
209 (package-full-name findutils))
210 (string=? (package-name dep2) "chbouib")
211 (match (package-native-inputs dep2)
212 ((("x" dep))
213 (with-store store
214 (string=? (derivation-file-name
215 (package-derivation store findutils))
216 (derivation-file-name
217 (package-derivation store dep)))))))))))))
218
219(test-equal "options->transformation, with-branch"
220 (git-checkout (url "https://example.org")
221 (branch "devel"))
222 (let* ((p (dummy-package "guix.scm"
223 (inputs `(("foo" ,grep)
224 ("bar" ,(dummy-package "chbouib"
225 (source (origin
226 (method git-fetch)
227 (uri (git-reference
228 (url "https://example.org")
229 (commit "cabba9e")))
230 (sha256 #f)))))))))
231 (t (options->transformation '((with-branch . "chbouib=devel")))))
232 (let ((new (t p)))
233 (and (not (eq? new p))
234 (match (package-inputs new)
235 ((("foo" dep1) ("bar" dep2))
236 (and (string=? (package-full-name dep1)
237 (package-full-name grep))
238 (string=? (package-name dep2) "chbouib")
239 (package-source dep2))))))))
240
241(test-equal "options->transformation, with-branch, recursive? inheritance"
242 (git-checkout (url "https://example.org")
243 (branch "devel")
244 (recursive? #t))
245 (let* ((p (dummy-package "guix.scm"
246 (inputs `(("foo" ,grep)
247 ("bar" ,(dummy-package "chbouib"
248 (source (origin
249 (method git-fetch)
250 (uri (git-reference
251 (url "https://example.org")
252 (commit "cabba9e")
253 (recursive? #t)))
254 (sha256 #f)))))))))
255 (t (options->transformation '((with-branch . "chbouib=devel")))))
256 (let ((new (t p)))
257 (and (not (eq? new p))
258 (match (package-inputs new)
259 ((("foo" dep1) ("bar" dep2))
260 (and (string=? (package-full-name dep1)
261 (package-full-name grep))
262 (string=? (package-name dep2) "chbouib")
263 (package-source dep2))))))))
264
265(test-equal "options->transformation, with-commit"
266 (git-checkout (url "https://example.org")
267 (commit "abcdef"))
268 (let* ((p (dummy-package "guix.scm"
269 (inputs `(("foo" ,grep)
270 ("bar" ,(dummy-package "chbouib"
271 (source (origin
272 (method git-fetch)
273 (uri (git-reference
274 (url "https://example.org")
275 (commit "cabba9e")))
276 (sha256 #f)))))))))
277 (t (options->transformation '((with-commit . "chbouib=abcdef")))))
278 (let ((new (t p)))
279 (and (not (eq? new p))
280 (match (package-inputs new)
281 ((("foo" dep1) ("bar" dep2))
282 (and (string=? (package-full-name dep1)
283 (package-full-name grep))
284 (string=? (package-name dep2) "chbouib")
285 (package-source dep2))))))))
286
287(test-equal "options->transformation, with-commit, recursive? inheritance"
288 (git-checkout (url "https://example.org")
289 (commit "abcdef")
290 (recursive? #t))
291 (let* ((p (dummy-package "guix.scm"
292 (inputs `(("foo" ,grep)
293 ("bar" ,(dummy-package "chbouib"
294 (source (origin
295 (method git-fetch)
296 (uri (git-reference
297 (url "https://example.org")
298 (commit "cabba9e")
299 (recursive? #t)))
300 (sha256 #f)))))))))
301 (t (options->transformation '((with-commit . "chbouib=abcdef")))))
302 (let ((new (t p)))
303 (and (not (eq? new p))
304 (match (package-inputs new)
305 ((("foo" dep1) ("bar" dep2))
306 (and (string=? (package-full-name dep1)
307 (package-full-name grep))
308 (string=? (package-name dep2) "chbouib")
309 (package-source dep2))))))))
310
311(test-equal "options->transformation, with-commit, version transformation"
312 '("1.0" "1.0-rc1-2-gabc123" "git.abc123")
313 (map (lambda (commit)
314 (let* ((p (dummy-package "guix.scm"
315 (inputs `(("foo" ,(dummy-package "chbouib"
316 (source (origin
317 (method git-fetch)
318 (uri (git-reference
319 (url "https://example.org")
320 (commit "cabba9e")))
321 (sha256 #f)))))))))
322 (t (options->transformation
323 `((with-commit . ,(string-append "chbouib=" commit))))))
324 (let ((new (t p)))
325 (and (not (eq? new p))
326 (match (package-inputs new)
327 ((("foo" dep1))
328 (package-version dep1)))))))
329 '("v1.0" "1.0-rc1-2-gabc123" "abc123")))
330
331(test-equal "options->transformation, with-git-url"
332 (let ((source (git-checkout (url "https://example.org")
333 (recursive? #t))))
334 (list source source))
335 (let* ((p (dummy-package "guix.scm"
336 (inputs `(("foo" ,grep)
337 ("bar" ,(dummy-package "chbouib"
338 (native-inputs `(("x" ,grep)))))))))
339 (t (options->transformation '((with-git-url . "grep=https://example.org")))))
340 (let ((new (t p)))
341 (and (not (eq? new p))
342 (match (package-inputs new)
343 ((("foo" dep1) ("bar" dep2))
344 (and (string=? (package-full-name dep1)
345 (package-full-name grep))
346 (string=? (package-name dep2) "chbouib")
347 (match (package-native-inputs dep2)
348 ((("x" dep3))
349 (map package-source (list dep1 dep3)))))))))))
350
351(test-equal "options->transformation, with-git-url + with-branch"
352 ;; Combine the two options and make sure the 'with-branch' transformation
353 ;; comes after the 'with-git-url' transformation.
354 (let ((source (git-checkout (url "https://example.org")
355 (branch "BRANCH")
356 (recursive? #t))))
357 (list source source))
358 (let* ((p (dummy-package "guix.scm"
359 (inputs `(("foo" ,grep)
360 ("bar" ,(dummy-package "chbouib"
361 (native-inputs `(("x" ,grep)))))))))
362 (t (options->transformation
363 (reverse '((with-git-url
364 . "grep=https://example.org")
365 (with-branch . "grep=BRANCH"))))))
366 (let ((new (t p)))
367 (and (not (eq? new p))
368 (match (package-inputs new)
369 ((("foo" dep1) ("bar" dep2))
370 (and (string=? (package-name dep1) "grep")
371 (string=? (package-name dep2) "chbouib")
372 (match (package-native-inputs dep2)
373 ((("x" dep3))
374 (map package-source (list dep1 dep3)))))))))))
375
376(test-equal "options->transformation, with-git-url, recursive? inheritance"
377 (git-checkout (url "https://example2.org")
378 (recursive? #f))
379 (let* ((p (dummy-package "chbouib"
380 (source (origin
381 (method git-fetch)
382 (uri (git-reference
383 (url "https://example1.org")
384 (commit "cabba9e")
385 (recursive? #f)))
386 (sha256 #f)))))
387 (t (options->transformation
388 '((with-git-url . "chbouib=https://example2.org")))))
389 (let ((new (t p)))
390 (package-source new))))
391
392(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
393 "Return true if P depends on TOOLCHAIN instead of the default tool chain."
394 (define toolchain-packages
395 '("gcc" "binutils" "glibc" "ld-wrapper"))
396
397 (define (package-name* obj)
398 (and (package? obj) (package-name obj)))
399
400 (match (bag-build-inputs (package->bag p))
401 (((_ (= package-name* packages) . _) ...)
402 (and (not (any (cut member <> packages) toolchain-packages))
403 (member toolchain packages)))))
404
405(test-assert "options->transformation, with-c-toolchain"
406 (let* ((dep0 (dummy-package "chbouib"
407 (build-system gnu-build-system)
408 (native-inputs `(("y" ,grep)))))
409 (dep1 (dummy-package "stuff"
410 (native-inputs `(("x" ,dep0)))))
411 (p (dummy-package "thingie"
412 (build-system gnu-build-system)
413 (inputs `(("foo" ,grep)
414 ("bar" ,dep1)))))
415 (t (options->transformation
416 '((with-c-toolchain . "chbouib=gcc-toolchain")))))
417 ;; Here we check that the transformation applies to DEP0 and all its
418 ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
419 ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
420 (let ((new (t p)))
421 (and (depends-on-toolchain? new "gcc-toolchain")
422 (match (bag-build-inputs (package->bag new))
423 ((("foo" dep0) ("bar" dep1) _ ...)
424 (and (depends-on-toolchain? dep1 "gcc-toolchain")
425 (not (depends-on-toolchain? dep0 "gcc-toolchain"))
426 (string=? (package-full-name dep0)
427 (package-full-name grep))
428 (match (bag-build-inputs (package->bag dep1))
429 ((("x" dep) _ ...)
430 (and (depends-on-toolchain? dep "gcc-toolchain")
431 (match (bag-build-inputs (package->bag dep))
432 ((("y" dep) _ ...) ;this one is unchanged
433 (eq? dep grep)))))))))))))
434
435(test-equal "options->transformation, with-c-toolchain twice"
436 (package-full-name grep)
437 (let* ((dep0 (dummy-package "chbouib"))
438 (dep1 (dummy-package "stuff"))
439 (p (dummy-package "thingie"
440 (build-system gnu-build-system)
441 (inputs `(("foo" ,dep0)
442 ("bar" ,dep1)
443 ("baz" ,grep)))))
444 (t (options->transformation
445 '((with-c-toolchain . "chbouib=clang-toolchain")
446 (with-c-toolchain . "stuff=clang-toolchain")))))
447 (let ((new (t p)))
448 (and (depends-on-toolchain? new "clang-toolchain")
449 (match (bag-build-inputs (package->bag new))
450 ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
451 (and (depends-on-toolchain? dep0 "clang-toolchain")
452 (depends-on-toolchain? dep1 "clang-toolchain")
453 (not (depends-on-toolchain? dep2 "clang-toolchain"))
454 (package-full-name dep2))))))))
455
456(test-assert "options->transformation, with-c-toolchain, no effect"
457 (let ((p (dummy-package "thingie"))
458 (t (options->transformation
459 '((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
460 ;; When it has no effect, '--with-c-toolchain' returns P.
461 (eq? (t p) p)))
462
463(test-equal "options->transformation, with-debug-info"
464 '(#:strip-binaries? #f)
465 (let* ((dep (dummy-package "chbouib"))
466 (p (dummy-package "thingie"
467 (build-system gnu-build-system)
468 (inputs `(("foo" ,dep)
469 ("bar" ,grep)))))
470 (t (options->transformation
471 '((with-debug-info . "chbouib")))))
472 (let ((new (t p)))
473 (match (package-inputs new)
474 ((("foo" dep0) ("bar" dep1))
475 (and (string=? (package-full-name dep1)
476 (package-full-name grep))
477 (package-arguments (package-replacement dep0))))))))
478
479(test-equal "options->transformation, with-configure-flag"
480 '(append '() '("--flag=42"))
481 (let* ((p (dummy-package "foo"
482 (build-system gnu-build-system)))
483 (t (options->transformation
484 '((with-configure-flag . "foo=--flag=42")))))
485 (let ((new (t p)))
486 (match (package-arguments new)
487 ((#:configure-flags flags)
488 (gexp->approximate-sexp flags))))))
489
490(test-assert "options->transformation, without-tests"
491 (let* ((dep (dummy-package "dep"))
492 (p (dummy-package "foo"
493 (inputs `(("dep" ,dep)))))
494 (t (options->transformation '((without-tests . "dep")
495 (without-tests . "tar")))))
496 (let ((new (t p)))
497 (match (bag-direct-inputs (package->bag new))
498 ((("dep" dep) ("tar" tar) _ ...)
499 (and (equal? (package-arguments dep) '(#:tests? #f))
500 (match (memq #:tests? (package-arguments tar))
501 ((#:tests? #f _ ...) #t))))))))
502
503(test-equal "options->transformation, with-patch"
504 (search-patches "glibc-locales.patch" "guile-relocatable.patch")
505 (let* ((dep (dummy-package "dep"
506 (source (dummy-origin))))
507 (p (dummy-package "foo"
508 (inputs `(("dep" ,dep)))))
509 (patch1 (search-patch "glibc-locales.patch"))
510 (patch2 (search-patch "guile-relocatable.patch"))
511 (t (options->transformation
512 `((with-patch . ,(string-append "dep=" patch1))
513 (with-patch . ,(string-append "dep=" patch2))
514 (with-patch . ,(string-append "tar=" patch1))))))
515 (let ((new (t p)))
516 (match (bag-direct-inputs (package->bag new))
517 ((("dep" dep) ("tar" tar) _ ...)
518 (and (member patch1
519 (filter-map (lambda (patch)
520 (and (local-file? patch)
521 (local-file-file patch)))
522 (origin-patches (package-source tar))))
523 (map local-file-file
524 (origin-patches (package-source dep)))))))))
525
526(test-equal "options->transformation, with-commit + with-patch"
527 '(#t #t)
528 (let* ((patch (search-patch "glibc-locales.patch"))
529 (commit "f8934ec94df5868ee8baf1fb0f8ed0f24e7e91eb")
530 (t (options->transformation
531 ;; Note: options are applied in reverse order, so
532 ;; 'with-patch' comes on top.
533 `((with-patch . ,(string-append "guile-gcrypt=" patch))
534 (with-commit
535 . ,(string-append "guile-gcrypt=" commit))))))
536 (let ((new (t (@ (gnu packages gnupg) guile-gcrypt))))
537 (match (package-source new)
538 ((? computed-file? source)
539 (let* ((gexp (computed-file-gexp source))
540 (inputs (map gexp-input-thing
541 ((@@ (guix gexp) gexp-inputs) gexp))))
542 (list (any (lambda (input)
543 (and (git-checkout? input)
544 (string=? commit (git-checkout-commit input))))
545 inputs)
546 (any (lambda (input)
547 (and (local-file? input)
548 (string=? (local-file-file input) patch)))
549 inputs))))))))
550
551(test-equal "options->transformation, property order"
552 ;; See <https://issues.guix.gnu.org/54942>.
553 '((with-debug-info . "does-not-exist")
554 (with-commit . "does-not-exist=aaaaaaa")
555 (without-tests . "does-not-exist"))
556 (let* ((t (options->transformation
557 '((with-debug-info . "does-not-exist")
558 (with-commit . "does-not-exist=aaaaaaa")
559 (without-tests . "does-not-exist")))))
560 (let ((new (t coreutils)))
561 (assq-ref (package-properties new) 'transformations))))
562
563(test-equal "package-with-upstream-version"
564 '("42.0" "42.0"
565 ("http://example.org")
566 ("a" "b") (do something))
567 (mock ((guix upstream) %updaters
568 (delay (list (upstream-updater
569 (name 'dummy)
570 (pred (const #t))
571 (description "")
572 (import (const (upstream-source
573 (package "foo")
574 (version "42.0")
575 (urls '("http://example.org")))))))))
576 (let* ((old (dummy-package "foo" (version "1.0")
577 (source (dummy-origin
578 (patches '("a" "b"))
579 (snippet '(do something))))))
580 (new (package-with-upstream-version old))
581 (new+patches (package-with-upstream-version
582 old #:preserve-patches? #t)))
583 (list (package-version new) (package-version new+patches)
584
585 ;; Source of NEW is directly an <upstream-source>.
586 (upstream-source-urls (package-source new))
587
588 ;; Check that #:preserve-patches? #t gave us an origin.
589 (origin-patches (package-source new+patches))
590 (origin-snippet (package-source new+patches))))))
591
592(test-equal "options->transformation, with-latest"
593 "42.0"
594 (mock ((guix upstream) %updaters
595 (delay (list (upstream-updater
596 (name 'dummy)
597 (pred (const #t))
598 (description "")
599 (import (const (upstream-source
600 (package "foo")
601 (version "42.0")
602 (urls '("http://example.org")))))))))
603 (let* ((p (dummy-package "foo" (version "1.0")))
604 (t (options->transformation
605 `((with-latest . "foo")))))
606 (package-version (t p)))))
607
608(test-equal "options->transformation, with-version"
609 "1.0"
610 (mock ((guix upstream) %updaters
611 (delay (list (upstream-updater
612 (name 'dummy)
613 (pred (const #t))
614 (description "")
615 (import (const (upstream-source
616 (package "foo")
617 (version "1.0")
618 (urls '("http://example.org")))))))))
619 (let* ((p0 (dummy-package "foo" (version "7.7")))
620 (p1 (dummy-package "bar" (inputs (list p0))))
621 (t (options->transformation
622 `((with-version . "foo=1.0")))))
623 (package-version (lookup-package-input (t p1) "foo")))))
624
625(test-equal "options->transformation, tune"
626 '(cpu-tuning . "superfast")
627 (let* ((p0 (dummy-package "p0"))
628 (p1 (dummy-package "p1"
629 (inputs `(("p0" ,p0)))
630 (properties '((tunable? . #t)))))
631 (p2 (dummy-package "p2"
632 (inputs `(("p1" ,p1)))))
633 (t (options->transformation '((tune . "superfast"))))
634 (p3 (t p2)))
635 (and (not (package-replacement p3))
636 (match (package-inputs p3)
637 ((("p1" tuned))
638 (match (package-inputs tuned)
639 ((("p0" p0))
640 (and (not (package-replacement p0))
641 (assq 'cpu-tuning
642 (package-properties
643 (package-replacement tuned)))))))))))
644
645(test-assert "options->transformations, tune, wrong micro-architecture"
646 (let ((p (dummy-package "tunable"
647 (properties '((tunable? . #t)))))
648 (t (options->transformation '((tune . "nonexistent-superfast")))))
649 ;; Because GCC used by P's build system does not support
650 ;; '-march=nonexistent-superfast', we should see an error when lowering
651 ;; the tuned package.
652 (guard (c ((formatted-message? c)
653 (member "nonexistent-superfast"
654 (formatted-message-arguments c))))
655 (package->bag (t p))
656 #f)))
657
658(test-equal "options->transformations, amd-gpu"
659 '("gfx90a" "gfx942")
660 (let ((p (dummy-package "amd-gpu-code"
661 (native-inputs
662 (list (@ (gnu packages llvm) clang-rocm)))
663 (properties '((amd-gpu-targets . ("whatever"))))))
664 (t (options->transformation '((amd-gpu . ("gfx90a" "gfx942"))))))
665 (assoc-ref (package-properties (t p)) 'amd-gpu-targets)))
666
667(test-equal "options->transformations, amd-gpu, not applicable"
668 #f
669 (let ((p (dummy-package "not-amd-gpu-code"))
670 (t (options->transformation '((amd-gpu . ("gfx90a" "gfx942"))))))
671 (assoc-ref (package-properties (t p)) 'amd-gpu-targets)))
672
673(test-assert "options->transformations, amd-gpu, missing clang-rocm input"
674 (let ((p (dummy-package "amd-gpu-code"
675 (properties '((amd-gpu-targets . ("whatever"))))))
676 (t (options->transformation '((amd-gpu . ("generic"))))))
677 ;; Since 'clang-rocm' is not among the inputs, an error should be raised.
678 (guard (c ((formatted-message? c)
679 (string-contains (formatted-message-string c)
680 "no ROCm compiler")))
681 (t p)
682 #f)))
683
684(test-assert "options->transformations, amd-gpu, wrong GPU"
685 (let ((p (dummy-package "amd-gpu-code"
686 (native-inputs
687 (list (@ (gnu packages llvm) clang-rocm)))
688 (properties '((amd-gpu-targets . ("whatever"))))))
689 (t (options->transformation '((amd-gpu . ("does-not-exist"))))))
690 ;; Since this AMD GPU target is not known to 'clang-rocm', an error should
691 ;; be raised.
692 (guard (c ((formatted-message? c)
693 (member "does-not-exist" (formatted-message-arguments c))))
694 (t p)
695 #f)))
696
697(test-equal "options->transformation + package->manifest-entry"
698 '((transformations . ((without-tests . "foo"))))
699 (let* ((p (dummy-package "foo"))
700 (t (options->transformation '((without-tests . "foo"))))
701 (e (package->manifest-entry (t p))))
702 (manifest-entry-properties e)))
703
704(test-end)
705
706;;; Local Variables:
707;;; eval: (put 'dummy-package 'scheme-indent-function 1)
708;;; End: