1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
5 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
7 ;;; This file is part of GNU Guix.
9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
10 ;;; under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 3 of the License, or (at
12 ;;; your option) any later version.
14 ;;; GNU Guix is distributed in the hope that it will be useful, but
15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (tests packages)
23 #:use-module (guix tests)
24 #:use-module (guix store)
25 #:use-module (guix monads)
26 #:use-module (guix grafts)
27 #:use-module (guix gexp)
28 #:use-module (guix utils)
29 #:use-module ((guix build utils) #:select (tarball?))
30 #:use-module ((guix diagnostics)
31 ;; Rename the 'location' binding to allow proper syntax
32 ;; matching when setting the 'location' field of a package.
33 #:renamer (lambda (name)
34 (cond ((eq? name 'location) 'make-location)
36 #:use-module ((gcrypt hash) #:prefix gcrypt:)
37 #:use-module (guix derivations)
38 #:use-module (guix download)
39 #:use-module (guix packages)
40 #:use-module (guix grafts)
41 #:use-module (guix search-paths)
42 #:use-module (guix build-system)
43 #:use-module (guix build-system trivial)
44 #:use-module (guix build-system gnu)
45 #:use-module (guix build-system python)
46 #:use-module (guix memoization)
47 #:use-module (guix profiles)
48 #:use-module (guix scripts package)
49 #:use-module (guix sets)
50 #:use-module (gnu packages)
51 #:use-module (gnu packages base)
52 #:use-module (gnu packages guile)
53 #:use-module (gnu packages bootstrap)
54 #:use-module (gnu packages python)
55 #:use-module (gnu packages version-control)
56 #:use-module (gnu packages xml)
57 #:use-module (srfi srfi-1)
58 #:use-module (srfi srfi-11)
59 #:use-module (srfi srfi-26)
60 #:use-module (srfi srfi-34)
61 #:use-module (srfi srfi-35)
62 #:use-module (srfi srfi-64)
63 #:use-module (srfi srfi-71)
64 #:use-module (rnrs bytevectors)
65 #:use-module (rnrs io ports)
66 #:use-module (ice-9 vlist)
67 #:use-module (ice-9 regex)
68 #:use-module (ice-9 match))
70 ;; Test the high-level packaging layer.
73 (open-connection-for-tests))
75 ;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
76 ;; can trigger builds early.)
80 (test-begin "packages")
82 (test-assert "printer with location"
83 (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
84 (with-output-to-string
88 (location (make-location "foo.scm" 42 7))))))))
90 (test-assert "printer without location"
91 (string-match "^#<package foo@0 [[:xdigit:]]+>$"
92 (with-output-to-string
95 (dummy-package "foo" (location #f)))))))
97 (test-assert "hidden-package"
98 (and (hidden-package? (hidden-package (dummy-package "foo")))
99 (not (hidden-package? (dummy-package "foo")))))
101 (test-assert "package-superseded"
102 (let* ((new (dummy-package "bar"))
103 (old (deprecated-package "foo" new)))
104 (and (eq? (package-superseded old) new)
105 (mock ((gnu packages) find-best-packages-by-name (const (list old)))
106 (specification->package "foo")
107 (and (eq? new (specification->package "foo"))
108 (eq? new (specification->package+output "foo")))))))
110 (test-assert "transaction-upgrade-entry, zero upgrades"
111 (let* ((old (dummy-package "foo" (version "1")))
112 (tx (mock ((gnu packages) find-best-packages-by-name
114 (transaction-upgrade-entry
115 #f ;no store access needed
117 (inherit (package->manifest-entry old))
118 (item (string-append (%store-prefix) "/"
119 (make-string 32 #\e) "-foo-1")))
120 (manifest-transaction)))))
121 (manifest-transaction-null? tx)))
123 (test-assert "transaction-upgrade-entry, zero upgrades, equivalent package"
124 (let* ((old (dummy-package "foo" (version "1")))
125 (drv (package-derivation %store old))
126 (tx (mock ((gnu packages) find-best-packages-by-name
128 (transaction-upgrade-entry
131 (inherit (package->manifest-entry old))
132 (item (derivation->output-path drv)))
133 (manifest-transaction)))))
134 (manifest-transaction-null? tx)))
136 (test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs"
137 ;; Properly detect equivalent packages even when they have propagated
138 ;; inputs. See <https://bugs.gnu.org/35872>.
139 (let* ((dep (dummy-package "dep" (version "2")))
140 (old (dummy-package "foo" (version "1")
141 (propagated-inputs (list dep))))
142 (drv (package-derivation %store old))
143 (tx (mock ((gnu packages) find-best-packages-by-name
145 (transaction-upgrade-entry
148 (inherit (package->manifest-entry old))
149 (item (derivation->output-path drv))
151 (list (manifest-entry
152 (inherit (package->manifest-entry dep))
153 (item (derivation->output-path
154 (package-derivation %store dep)))))))
155 (manifest-transaction)))))
156 (manifest-transaction-null? tx)))
158 (test-assert "transaction-upgrade-entry, one upgrade"
159 (let* ((old (dummy-package "foo" (version "1")))
160 (new (dummy-package "foo" (version "2")))
161 (tx (mock ((gnu packages) find-best-packages-by-name
163 (transaction-upgrade-entry
164 #f ;no store access needed
166 (inherit (package->manifest-entry old))
167 (item (string-append (%store-prefix) "/"
168 (make-string 32 #\e) "-foo-1")))
169 (manifest-transaction)))))
170 (and (match (manifest-transaction-install tx)
171 ((($ <manifest-entry> "foo" "2" "out" item))
173 (null? (manifest-transaction-remove tx)))))
175 (test-assert "transaction-upgrade-entry, superseded package"
176 (let* ((old (dummy-package "foo" (version "1")))
177 (new (dummy-package "bar" (version "2")))
178 (dep (deprecated-package "foo" new))
179 (tx (mock ((gnu packages) find-best-packages-by-name
181 (transaction-upgrade-entry
182 #f ;no store access needed
184 (inherit (package->manifest-entry old))
185 (item (string-append (%store-prefix) "/"
186 (make-string 32 #\e) "-foo-1")))
187 (manifest-transaction)))))
188 (and (match (manifest-transaction-install tx)
189 ((($ <manifest-entry> "bar" "2" "out" item))
191 (match (manifest-transaction-remove tx)
192 (((? manifest-pattern? pattern))
193 (and (string=? (manifest-pattern-name pattern) "foo")
194 (string=? (manifest-pattern-version pattern) "1")
195 (string=? (manifest-pattern-output pattern) "out")))))))
197 (test-equal "transaction-upgrade-entry, transformation options preserved"
198 (derivation-file-name (package-derivation %store grep))
200 (let* ((old (dummy-package "emacs" (version "1")))
201 (props '((transformations . ((with-input . "emacs=grep")))))
202 (tx (transaction-upgrade-entry
205 (inherit (package->manifest-entry old))
207 (item (string-append (%store-prefix) "/"
208 (make-string 32 #\e) "-foo-1")))
209 (manifest-transaction))))
210 (match (manifest-transaction-install tx)
211 (((? manifest-entry? entry))
212 (and (string=? (manifest-entry-version entry)
213 (package-version grep))
214 (string=? (manifest-entry-name entry)
216 (equal? (manifest-entry-properties entry) props)
217 (derivation-file-name
218 (package-derivation %store (manifest-entry-item entry))))))))
220 (test-assert "transaction-upgrade-entry, grafts"
221 ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't
222 ;; try to build stuff.
223 (with-build-handler (const 'failed!)
224 (parameterize ((%graft? #t))
225 (let* ((old (dummy-package "foo" (version "1")))
226 (bar (dummy-package "bar" (version "0")
228 (new (dummy-package "foo" (version "1")
229 (inputs (list bar))))
230 (tx (mock ((gnu packages) find-best-packages-by-name
232 (transaction-upgrade-entry
235 (inherit (package->manifest-entry old))
236 (item (string-append (%store-prefix) "/"
237 (make-string 32 #\e) "-foo-1")))
238 (manifest-transaction)))))
239 (and (match (manifest-transaction-install tx)
240 ((($ <manifest-entry> "foo" "1" "out" item))
242 (null? (manifest-transaction-remove tx)))))))
244 (test-assert "package-definition-location"
245 (let ((location (package-location hello))
246 (definition (package-definition-location hello)))
247 ;; Check for the usual layout of (define-public hello (package ...)).
248 (and (string=? (location-file location)
249 (location-file definition))
250 (= 0 (location-column definition))
251 (= 2 (location-column location))
252 (= (location-line definition)
253 (- (location-line location) 1)))))
255 (test-assert "package-field-location"
257 (define (goto port line column)
258 (unless (and (= (port-column port) (- column 1))
259 (= (port-line port) (- line 1)))
260 (unless (eof-object? (get-char port))
261 (goto port line column))))
265 (($ <location> file line column)
266 (call-with-input-file (search-path %load-path file)
268 (goto port line column)
271 ;; Until Guile 2.0.6 included, source properties were added only to pairs.
272 ;; Thus, check against both VALUE and (FIELD VALUE).
273 (and (member (read-at (package-field-location %bootstrap-guile 'name))
274 (let ((name (package-name %bootstrap-guile)))
275 (list name `(name ,name))))
276 (member (read-at (package-field-location %bootstrap-guile 'version))
277 (let ((version (package-version %bootstrap-guile)))
278 (list version `(version ,version))))
279 (not (package-field-location %bootstrap-guile 'does-not-exist)))))
281 ;; Make sure we don't change the file name to an absolute file name.
282 (test-equal "package-field-location, relative file name"
283 (location-file (package-location %bootstrap-guile))
284 (with-fluids ((%file-port-name-canonicalization 'absolute))
285 (location-file (package-field-location %bootstrap-guile 'version))))
287 (test-assert "package-transitive-inputs"
288 (let* ((a (dummy-package "a"))
289 (b (dummy-package "b"
290 (propagated-inputs (list a))))
291 (c (dummy-package "c"
293 (d (dummy-package "d"
294 (propagated-inputs `(("x" "something.drv")))))
295 (e (dummy-package "e"
296 (inputs (list b c d)))))
297 (and (null? (package-transitive-inputs a))
298 (equal? `(("a" ,a)) (package-transitive-inputs b))
299 (equal? `(("a" ,a)) (package-transitive-inputs c))
300 (equal? (package-propagated-inputs d)
301 (package-transitive-inputs d))
302 (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
303 ("a" ,a) ("x" "something.drv"))
304 (pk 'x (package-transitive-inputs e))))))
306 (test-assert "package-transitive-inputs, no duplicates"
307 (let* ((a (dummy-package "a"))
308 (b (dummy-package "b"
309 (inputs `(("a+" ,a)))
310 (native-inputs `(("a*" ,a)))
311 (propagated-inputs `(("a" ,a)))))
312 (c (dummy-package "c"
313 (propagated-inputs `(("b" ,b)))))
314 (d (dummy-package "d"
315 (inputs `(("a" ,a) ("c" ,c)))))
316 (e (dummy-package "e"
317 (inputs `(("b" ,b) ("c" ,c))))))
318 (and (null? (package-transitive-inputs a))
319 (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a)) ;here duplicates are kept
320 (package-transitive-inputs b))
321 (equal? `(("b" ,b) ("a" ,a))
322 (package-transitive-inputs c))
323 (equal? `(("a" ,a) ("c" ,c) ("b" ,b)) ;duplicate A removed
324 (package-transitive-inputs d))
325 (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
326 (package-transitive-inputs e))))) ;ditto
328 (test-equal "package-transitive-supported-systems"
334 ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
335 ;; doesn't restrict the set of supported systems.
336 (let* ((a (dummy-package "a"
337 (build-system trivial-build-system)
338 (supported-systems '("x" "y" "z"))))
339 (b (dummy-package "b"
340 (build-system trivial-build-system)
341 (supported-systems '("x" "y"))
343 (c (dummy-package "c"
344 (build-system trivial-build-system)
345 (supported-systems '("y" "z"))
347 (d (dummy-package "d"
348 (build-system trivial-build-system)
349 (supported-systems '("x" "y" "z"))
350 (inputs (list b c))))
351 (e (dummy-package "e"
352 (build-system trivial-build-system)
353 (supported-systems '("x" "y" "z"))
355 (list (package-transitive-supported-systems a)
356 (package-transitive-supported-systems b)
357 (package-transitive-supported-systems c)
358 (package-transitive-supported-systems d)
359 (package-transitive-supported-systems e))))
361 (test-assert "package-development-inputs"
362 ;; Note: Due to propagated inputs, 'package-development-inputs' returns a
363 ;; couple more inputs, such as 'linux-libre-headers'.
365 `(("source" ,(package-source hello)) ,@(standard-packages))
366 (package-development-inputs hello)))
368 (test-assert "package-development-inputs, cross-compilation"
370 `(("source" ,(package-source hello))
371 ,@(standard-cross-packages "mips64el-linux-gnu" 'host)
372 ,@(standard-cross-packages "mips64el-linux-gnu" 'target))
373 (package-development-inputs hello #:target "mips64el-linux-gnu")))
375 (test-assert "package-closure"
376 (let-syntax ((dummy-package/no-implicit
380 (inherit (dummy-package name rest ...))
381 (build-system trivial-build-system))))))
382 (let* ((a (dummy-package/no-implicit "a"))
383 (b (dummy-package/no-implicit "b"
384 (propagated-inputs (list a))))
385 (c (dummy-package/no-implicit "c"
387 (d (dummy-package/no-implicit "d"
388 (native-inputs (list b))))
389 (e (dummy-package/no-implicit "e"
390 (inputs (list c d)))))
393 (package-closure (list e))
394 (package-closure (list e d))
395 (package-closure (list e c b))))))
397 (test-equal "origin-actual-file-name"
399 (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
400 (origin-actual-file-name o)))
402 (test-equal "origin-actual-file-name, file-name"
404 (let ((o (dummy-origin
405 (uri "http://www.example.com/tarball")
406 (file-name "foo-1.tar.gz"))))
407 (origin-actual-file-name o)))
409 (let* ((o (dummy-origin))
412 (a (dummy-package "a"))
413 (b (dummy-package "b" (inputs (list a i))))
414 (c (package (inherit b) (source o)))
415 (d (dummy-package "d"
416 (build-system trivial-build-system)
417 (source u) (inputs (list c)))))
418 (test-assert "package-direct-sources, no source"
419 (null? (package-direct-sources a)))
420 (test-equal "package-direct-sources, #f source"
422 (package-direct-sources b))
423 (test-equal "package-direct-sources, not input source"
425 (package-direct-sources d))
426 (test-assert "package-direct-sources"
427 (let ((s (package-direct-sources c)))
428 (and (= (length (pk 's-sources s)) 2)
431 (test-assert "package-transitive-sources"
432 (let ((s (package-transitive-sources d)))
433 (and (= (length (pk 'd-sources s)) 3)
438 (test-assert "transitive-input-references"
439 (let* ((a (dummy-package "a"))
440 (b (dummy-package "b"))
441 (c (dummy-package "c"
443 (propagated-inputs `(("boo" ,b)))))
444 (d (dummy-package "d"
445 (inputs `(("c*" ,c)))))
446 (keys (map (match-lambda
449 (pk 'refs (transitive-input-references
450 'l (package-inputs d))))))
451 (and (= (length keys) 2)
453 (member "boo" keys))))
455 (test-equal "package-transitive-supported-systems, implicit inputs"
458 ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
459 ;; %SUPPORTED-SYSTEMS. Thus the others must be ignored.
460 (let ((p (dummy-package "foo"
461 (build-system gnu-build-system)
463 `("does-not-exist" "foobar" ,@%supported-systems)))))
464 (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture
465 (package-transitive-supported-systems p))))
467 (test-equal "package-transitive-supported-systems: reduced binary seed, implicit inputs"
468 '("x86_64-linux" "i686-linux")
470 ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
471 ;; %SUPPORTED-SYSTEMS. Thus the others must be ignored.
472 (let ((p (dummy-package "foo"
473 (build-system gnu-build-system)
475 `("does-not-exist" "foobar" ,@%supported-systems)))))
476 (parameterize ((%current-system "x86_64-linux"))
477 (package-transitive-supported-systems p))))
479 (test-assert "supported-package?"
480 (let* ((d (dummy-package "dep"
481 (build-system trivial-build-system)
482 (supported-systems '("x86_64-linux"))))
483 (p (dummy-package "foo"
484 (build-system gnu-build-system)
486 (supported-systems '("x86_64-linux" "armhf-linux")))))
487 (and (supported-package? p "x86_64-linux")
488 (not (supported-package? p "i686-linux"))
489 (not (supported-package? p "armhf-linux")))))
491 (test-assert "supported-package? vs. system-dependent graph"
492 ;; The inputs of a package can depend on (%current-system). Thus,
493 ;; 'supported-package?' must make sure that it binds (%current-system)
494 ;; appropriately before traversing the dependency graph. In the example
495 ;; below, 'supported-package?' must thus return true for both systems.
496 (let* ((p0a (dummy-package "foo-arm"
497 (build-system trivial-build-system)
498 (supported-systems '("armhf-linux"))))
499 (p0b (dummy-package "foo-x86_64"
500 (build-system trivial-build-system)
501 (supported-systems '("x86_64-linux"))))
502 (p (dummy-package "bar"
503 (build-system trivial-build-system)
505 (if (string=? (%current-system) "armhf-linux")
508 (and (supported-package? p "x86_64-linux")
509 (supported-package? p "armhf-linux"))))
511 (test-assert "supported-package? vs. %current-target-system"
512 ;; The %CURRENT-TARGET-SYSTEM value should have no influence.
513 (parameterize ((%current-target-system "arm-linux-gnueabihf"))
514 (let ((p (dummy-package "foo"
515 (build-system gnu-build-system)
516 (supported-systems '("x86_64-linux" "armhf-linux")))))
517 (and (supported-package? p "x86_64-linux")
518 (not (supported-package? p "i686-linux"))
519 (supported-package? p "armhf-linux")))))
521 (test-skip (if (not %store) 8 0))
523 (test-assert "package-source-derivation, file"
524 (let* ((file (search-path %load-path "guix.scm"))
525 (package (package (inherit (dummy-package "p"))
527 (source (package-source-derivation %store
528 (package-source package))))
529 (and (store-path? source)
530 (valid-path? %store source)
531 (equal? (call-with-input-file source get-bytevector-all)
532 (call-with-input-file file get-bytevector-all)))))
534 (test-assert "package-source-derivation, store path"
535 (let* ((file (add-to-store %store "guix.scm" #t "sha256"
536 (search-path %load-path "guix.scm")))
537 (package (package (inherit (dummy-package "p"))
539 (source (package-source-derivation %store
540 (package-source package))))
541 (string=? file source)))
543 (test-assert "package-source-derivation, indirect store path"
544 (let* ((dir (add-to-store %store "guix-build" #t "sha256"
545 (dirname (search-path %load-path
546 "guix/build/utils.scm"))))
547 (package (package (inherit (dummy-package "p"))
548 (source (string-append dir "/utils.scm"))))
549 (source (package-source-derivation %store
550 (package-source package))))
551 (and (direct-store-path? source)
552 (string-suffix? "utils.scm" source))))
554 (test-assert "package-source-derivation, local-file"
555 (let* ((file (local-file "../guix/base32.scm"))
556 (package (package (inherit (dummy-package "p"))
558 (source (package-source-derivation %store
559 (package-source package))))
560 (and (store-path? source)
561 (string-suffix? "base32.scm" source)
562 (valid-path? %store source)
563 (equal? (call-with-input-file source get-bytevector-all)
564 (call-with-input-file
565 (search-path %load-path "guix/base32.scm")
566 get-bytevector-all)))))
568 (test-equal "package-source-derivation, origin, sha512"
570 (let* ((bash (search-bootstrap-binary "bash" (%current-system)))
571 (builder (add-text-to-store %store "my-fixed-builder.sh"
572 "echo -n hello > $out" '()))
573 (method (lambda* (url hash-algo hash #:optional name
575 (and (eq? hash-algo 'sha512)
576 (raw-derivation name bash (list builder)
577 #:sources (list builder)
579 #:hash-algo hash-algo))))
583 (file-name "origin-sha512")
585 (gcrypt:bytevector-hash (string->utf8 "hello")
586 (gcrypt:lookup-hash-algorithm
589 (drv (package-source-derivation %store source))
590 (output (derivation->output-path drv)))
591 (build-derivations %store (list drv))
592 (call-with-input-file output get-string-all)))
594 (test-equal "package-source-derivation, origin, sha3-512"
596 (let* ((bash (search-bootstrap-binary "bash" (%current-system)))
597 (builder (add-text-to-store %store "my-fixed-builder.sh"
598 "echo -n hello, sha3 > $out" '()))
599 (method (lambda* (url hash-algo hash #:optional name
601 (and (eq? hash-algo 'sha3-512)
602 (raw-derivation name bash (list builder)
603 #:sources (list builder)
605 #:hash-algo hash-algo))))
609 (file-name "origin-sha3")
611 (gcrypt:bytevector-hash (string->utf8 "hello, sha3")
612 (gcrypt:lookup-hash-algorithm
615 (drv (package-source-derivation %store source))
616 (output (derivation->output-path drv)))
617 (build-derivations %store (list drv))
618 (call-with-input-file output get-string-all)))
622 ;;; Source derivation with snippets.
625 (unless (network-reachable?) (test-skip 1))
626 (test-equal "package-source-derivation, snippet"
628 (let* ((source (bootstrap-origin
630 (inherit (bootstrap-guile-origin (%current-system)))
632 `(("tar" ,%bootstrap-coreutils&co)
633 ("xz" ,%bootstrap-coreutils&co)
634 ("patch" ,%bootstrap-coreutils&co)))
635 (patch-guile %bootstrap-guile)
636 (modules '((guix build utils)))
638 ;; We end up in 'bin', because it's the first
639 ;; directory, alphabetically. Not a very good
642 (symlink "guile" "guile-rocks")
643 (copy-recursively "../share/guile/2.0/scripts"
646 ;; Make sure '.file_list' can be created.
647 (chmod ".." #o777))))))
648 (package (package (inherit (dummy-package "with-snippet"))
650 (build-system trivial-build-system)
652 `(("tar" ,(search-bootstrap-binary "tar"
654 ("xz" ,(search-bootstrap-binary "xz"
655 (%current-system)))))
657 `(#:guile ,%bootstrap-guile
658 #:modules ((guix build utils))
661 (use-modules (guix build utils))
662 (let ((tar (assoc-ref %build-inputs "tar"))
663 (xz (assoc-ref %build-inputs "xz"))
664 (source (assoc-ref %build-inputs "source")))
665 (invoke tar "xvf" source
666 "--use-compress-program" xz)
667 (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
668 (file-exists? "bin/scripts/compile.scm"))
669 (error "the snippet apparently failed"))
670 (let ((out (assoc-ref %outputs "out")))
671 (call-with-output-file out
675 (drv (package-derivation %store package))
676 (out (derivation->output-path drv)))
677 (and (build-derivations %store (list (pk 'snippet-drv drv)))
678 (call-with-input-file out get-string-all))))
680 ;; Note: lzip is not part of bootstrap-coreutils&co, so is not included to
681 ;; avoid having to rebuild the world.
682 (define compressors '(("gzip" . "gz")
690 (unless (network-reachable?) (test-skip 1))
691 (test-equal (string-append "origin->derivation, single file with snippet "
692 "(compression: " (if comp comp "None") ")")
696 ((compressed-name) (if comp
697 (string-append name "." ext)
699 ((file hash) (test-file %store compressed-name "2 + 2 = 5"))
700 ;; Create an origin using the above computed file and its hash.
703 (uri (string-append "file://" file))
704 (file-name compressed-name)
705 (patch-inputs `(("tar" ,%bootstrap-coreutils&co)
706 ("xz" ,%bootstrap-coreutils&co)
707 ("bzip2" ,%bootstrap-coreutils&co)
708 ("gzip" ,%bootstrap-coreutils&co)))
709 (patch-guile %bootstrap-guile)
710 (modules '((guix build utils)))
711 (snippet `(substitute* ,name
713 (hash (content-hash hash))))
715 ((drv) (run-with-store %store (origin->derivation source)))
716 ((out) (derivation->output-path drv)))
717 ;; Decompress the resulting tar.xz and return its content.
718 (and (build-derivations %store (list drv))
720 (let* ((bin #~(string-append #+%bootstrap-coreutils&co
724 (with-imported-modules '((guix build utils))
726 (use-modules (guix build utils))
727 (setenv "PATH" #+bin)
728 (invoke "tar" "xvf" #+out)
729 (copy-file #+name #$output)))
730 #:guile %bootstrap-guile))
731 (drv (run-with-store %store (lower-object f)))
732 (_ (build-derivations %store (list drv))))
733 (call-with-input-file (derivation->output-path drv)
735 (call-with-input-file out get-string-all)))))))
738 (test-assert "return value"
739 (let ((drv (package-derivation %store (dummy-package "p"))))
740 (and (derivation? drv)
741 (file-exists? (derivation-file-name drv)))))
743 (test-assert "package-derivation, inputs deduplicated"
744 (let* ((dep (dummy-package "dep"))
745 (p0 (dummy-package "p" (inputs (list dep))))
746 (p1 (package (inherit p0)
747 (inputs `(("dep" ,(package (inherit dep)))
748 ,@(package-inputs p0))))))
749 ;; Here P1 ends up with two non-eq? copies of DEP, under the same label.
750 ;; They should be deduplicated so that P0 and P1 lead to the same
751 ;; derivation rather than P1 ending up with duplicate entries in its
752 ;; '%build-inputs' variable.
753 (string=? (derivation-file-name (package-derivation %store p0))
754 (derivation-file-name (package-derivation %store p1)))))
756 (test-assert "package-derivation, different system"
757 ;; Make sure the 'system' argument of 'package-derivation' is respected.
758 (let* ((system (if (string=? (%current-system) "x86_64-linux")
761 (drv (package-derivation %store (dummy-package "p")
762 system #:graft? #f)))
763 (define right-system?
765 (and (string=? (derivation-system drv) system)
766 (every (compose right-system? derivation-input-derivation)
767 (derivation-inputs drv)))))
769 (right-system? drv)))
771 (test-assert "package-output"
772 (let* ((package (dummy-package "p"))
773 (drv (package-derivation %store package)))
774 (and (derivation? drv)
775 (string=? (derivation->output-path drv)
776 (package-output %store package "out")))))
778 (test-equal "patch not found yields a run-time error"
779 '("~a: patch not found\n" "does-not-exist.patch")
780 (guard (c ((formatted-message? c)
781 (cons (formatted-message-string c)
782 (formatted-message-arguments c))))
784 (inherit (dummy-package "p"))
787 (uri "http://whatever")
789 (list (search-patch "does-not-exist.patch")))
792 "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
793 (package-derivation %store p)
796 (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
797 (test-equal "&package-input-error"
798 (list dummy `("x" ,(current-module)))
799 (guard (c ((package-input-error? c)
800 (list (package-error-package c)
801 (package-error-invalid-input c))))
802 (package-derivation %store dummy))))
804 (test-assert "reference to non-existent output"
805 ;; See <http://bugs.gnu.org/19630>.
806 (parameterize ((%graft? #f))
807 (let* ((dep (dummy-package "dep"))
808 (p (dummy-package "p"
809 (inputs (list `(,dep "non-existent"))))))
810 (guard (c ((derivation-missing-output-error? c)
811 (and (string=? (derivation-missing-output c) "non-existent")
812 (equal? (package-derivation %store dep)
813 (derivation-error-derivation c)))))
814 (package-derivation %store p)))))
816 (test-assert "trivial"
817 (let* ((p (package (inherit (dummy-package "trivial"))
818 (build-system trivial-build-system)
821 `(#:guile ,%bootstrap-guile
825 (call-with-output-file (string-append %output "/test")
827 (display '(hello guix) p)))
829 (d (package-derivation %store p)))
830 (and (build-derivations %store (list d))
831 (let ((p (pk 'drv d (derivation->output-path d))))
832 (equal? '(hello guix)
833 (call-with-input-file (string-append p "/test") read))))))
835 (test-assert "trivial with local file as input"
836 (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
837 (p (package (inherit (dummy-package "trivial-with-input-file"))
838 (build-system trivial-build-system)
841 `(#:guile ,%bootstrap-guile
843 (copy-file (assoc-ref %build-inputs "input")
846 (inputs `(("input" ,i)))))
847 (d (package-derivation %store p)))
848 (and (build-derivations %store (list d))
849 (let ((p (pk 'drv d (derivation->output-path d))))
850 (equal? (call-with-input-file p get-bytevector-all)
851 (call-with-input-file i get-bytevector-all))))))
853 (test-assert "trivial with source"
854 (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
855 (p (package (inherit (dummy-package "trivial-with-source"))
856 (build-system trivial-build-system)
859 `(#:guile ,%bootstrap-guile
861 (copy-file (assoc-ref %build-inputs "source")
864 (d (package-derivation %store p)))
865 (and (build-derivations %store (list d))
866 (let ((p (derivation->output-path d)))
867 (equal? (call-with-input-file p get-bytevector-all)
868 (call-with-input-file i get-bytevector-all))))))
870 (test-assert "trivial with system-dependent input"
871 (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
872 (build-system trivial-build-system)
875 `(#:guile ,%bootstrap-guile
876 #:modules ((guix build utils))
879 (use-modules (guix build utils))
880 (let ((out (assoc-ref %outputs "out"))
881 (bash (assoc-ref %build-inputs "bash")))
883 (format #f "echo hello > ~a" out))))))
884 (inputs `(("bash" ,(search-bootstrap-binary "bash"
885 (%current-system)))))))
886 (d (package-derivation %store p)))
887 (and (build-derivations %store (list d))
888 (let ((p (pk 'drv d (derivation->output-path d))))
889 (eq? 'hello (call-with-input-file p read))))))
891 (test-assert "trivial with #:allowed-references"
893 (inherit (dummy-package "trivial"))
894 (build-system trivial-build-system)
896 `(#:guile ,%bootstrap-guile
897 #:allowed-references (,%bootstrap-guile)
901 ;; The reference to itself isn't allowed so building it
903 (symlink %output (string-append %output "/self"))
905 (d (package-derivation %store p)))
906 (guard (c ((store-protocol-error? c) #t))
907 (build-derivations %store (list d))
910 (test-assert "trivial with #:allowed-references + grafts"
912 (inherit %bootstrap-guile)
913 (replacement (package
914 (inherit %bootstrap-guile)
917 (inherit (dummy-package "trivial"))
918 (build-system trivial-build-system)
922 #:allowed-references (,g)
923 #:builder (mkdir %output)))))
924 (d0 (package-derivation %store p #:graft? #f))
925 (d1 (parameterize ((%graft? #t))
926 (package-derivation %store p #:graft? #t))))
927 ;; D1 should be equal to D2 because there's nothing to graft. In
928 ;; particular, its #:disallowed-references should be lowered in the same
929 ;; way (ungrafted) whether or not #:graft? is true.
930 (string=? (derivation-file-name d1) (derivation-file-name d0))))
932 (test-assert "search paths"
933 (let* ((p (make-prompt-tag "return-search-paths"))
934 (t (make-parameter "guile-0"))
937 (description "Raw build system with direct store access")
938 (lower (lambda* (name #:key source inputs system target
942 (system system) (target target)
943 (build-inputs inputs)
945 (lambda* (name inputs
946 #:key outputs system search-paths)
947 (if (string=? name (t))
948 (abort-to-prompt p search-paths)
949 (gexp->derivation name
950 #~(mkdir #$output))))))))))
951 (x (list (search-path-specification
952 (variable "GUILE_LOAD_PATH")
953 (files '("share/guile/site/2.0")))
954 (search-path-specification
955 (variable "GUILE_LOAD_COMPILED_PATH")
956 (files '("share/guile/site/2.0")))))
957 (a (package (inherit (dummy-package "guile"))
959 (native-search-paths x)))
960 (b (package (inherit (dummy-package "guile-foo"))
962 (inputs `(("guile" ,a)))))
963 (c (package (inherit (dummy-package "guile-bar"))
965 (inputs `(("guile" ,a)
966 ("guile-foo" ,b))))))
967 (let-syntax ((collect (syntax-rules ()
972 (lambda (k search-paths)
974 (and (null? (collect (package-derivation %store a)))
975 (parameterize ((t "guile-foo-0"))
976 (equal? x (collect (package-derivation %store b))))
977 (parameterize ((t "guile-bar-0"))
978 (equal? x (collect (package-derivation %store c))))))))
980 (test-assert "package-transitive-native-search-paths"
981 (let* ((sp (lambda (name)
982 (list (search-path-specification
984 (files '("foo/bar"))))))
985 (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
986 (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
987 (p2 (dummy-package "p2"
988 (native-search-paths (sp "PATH2"))
990 (propagated-inputs (list p1))))
991 (p3 (dummy-package "p3"
992 (native-search-paths (sp "PATH3"))
993 (native-inputs (list p0))
994 (propagated-inputs (list p2)))))
996 '("PATH1" "PATH2" "PATH3")
997 (map search-path-specification-variable
998 (package-transitive-native-search-paths p3)))))
1000 (test-assert "package-cross-derivation"
1001 (let ((drv (package-cross-derivation %store (dummy-package "p")
1002 "mips64el-linux-gnu")))
1003 (and (derivation? drv)
1004 (file-exists? (derivation-file-name drv)))))
1006 (test-assert "package-cross-derivation, trivial-build-system"
1007 (let ((p (package (inherit (dummy-package "p"))
1008 (build-system trivial-build-system)
1009 (arguments '(#:builder (exit 1))))))
1010 (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
1011 (derivation? drv))))
1013 (test-assert "package-cross-derivation, no cross builder"
1014 (let* ((b (build-system (inherit trivial-build-system)
1015 (lower (const #f))))
1016 (p (package (inherit (dummy-package "p"))
1018 (guard (c ((package-cross-build-system-error? c)
1019 (eq? (package-error-package c) p)))
1020 (package-cross-derivation %store p "mips64el-linux-gnu")
1023 ;; XXX: The next two tests can trigger builds when the distro defines
1024 ;; replacements on core packages, so they're disable for lack of a better
1027 ;; (test-equal "package-derivation, direct graft"
1028 ;; (package-derivation %store gnu-make #:graft? #f)
1029 ;; (let ((p (package (inherit coreutils)
1030 ;; (replacement gnu-make))))
1031 ;; (package-derivation %store p #:graft? #t)))
1033 ;; (test-equal "package-cross-derivation, direct graft"
1034 ;; (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
1036 ;; (let ((p (package (inherit coreutils)
1037 ;; (replacement gnu-make))))
1038 ;; (package-cross-derivation %store p "mips64el-linux-gnu"
1041 (test-assert "package-grafts, indirect grafts"
1042 (let* ((new (dummy-package "dep"
1043 (arguments '(#:implicit-inputs? #f))))
1044 (dep (package (inherit new) (version "0.0")))
1045 (dep* (package (inherit dep) (replacement new)))
1046 (dummy (dummy-package "dummy"
1047 (arguments '(#:implicit-inputs? #f))
1048 (inputs (list dep*)))))
1049 (equal? (package-grafts %store dummy)
1051 (origin (package-derivation %store dep))
1052 (replacement (package-derivation %store new)))))))
1054 ;; XXX: This test would require building the cross toolchain just to see if it
1055 ;; needs grafting, which is obviously too expensive, and thus disabled.
1057 ;; (test-assert "package-grafts, indirect grafts, cross"
1058 ;; (let* ((new (dummy-package "dep"
1059 ;; (arguments '(#:implicit-inputs? #f))))
1060 ;; (dep (package (inherit new) (version "0.0")))
1061 ;; (dep* (package (inherit dep) (replacement new)))
1062 ;; (dummy (dummy-package "dummy"
1063 ;; (arguments '(#:implicit-inputs? #f))
1064 ;; (inputs `(("dep" ,dep*)))))
1065 ;; (target "mips64el-linux-gnu"))
1066 ;; ;; XXX: There might be additional grafts, for instance if the distro
1067 ;; ;; defines replacements for core packages like Perl.
1069 ;; (origin (package-cross-derivation %store dep target))
1071 ;; (package-cross-derivation %store new target)))
1072 ;; (package-grafts %store dummy #:target target))))
1074 (test-assert "package-grafts, indirect grafts, propagated inputs"
1075 (let* ((new (dummy-package "dep"
1076 (arguments '(#:implicit-inputs? #f))))
1077 (dep (package (inherit new) (version "0.0")))
1078 (dep* (package (inherit dep) (replacement new)))
1079 (prop (dummy-package "propagated"
1080 (propagated-inputs (list dep*))
1081 (arguments '(#:implicit-inputs? #f))))
1082 (dummy (dummy-package "dummy"
1083 (arguments '(#:implicit-inputs? #f))
1084 (inputs (list prop)))))
1085 (equal? (package-grafts %store dummy)
1087 (origin (package-derivation %store dep))
1088 (replacement (package-derivation %store new)))))))
1090 (test-assert "package-grafts, same replacement twice"
1091 (let* ((new (dummy-package "dep"
1093 (arguments '(#:implicit-inputs? #f))))
1094 (dep (package (inherit new) (version "0") (replacement new)))
1095 (p1 (dummy-package "intermediate1"
1096 (arguments '(#:implicit-inputs? #f))
1097 (inputs (list dep))))
1098 (p2 (dummy-package "intermediate2"
1099 (arguments '(#:implicit-inputs? #f))
1100 ;; Here we copy DEP to have an equivalent package that is not
1101 ;; 'eq?' to DEP. This is similar to what happens with
1102 ;; 'package-with-explicit-inputs' & co.
1103 (inputs (list (package (inherit dep))))))
1104 (p3 (dummy-package "final"
1105 (arguments '(#:implicit-inputs? #f))
1106 (inputs (list p1 p2)))))
1107 (equal? (package-grafts %store p3)
1109 (origin (package-derivation %store
1110 (package (inherit dep)
1112 (replacement (package-derivation %store new)))))))
1114 (test-assert "package-grafts, dependency on several outputs"
1115 ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
1116 (letrec* ((p0 (dummy-package "p0"
1119 (arguments '(#:implicit-inputs? #f))
1120 (outputs '("out" "lib"))))
1121 (p0* (package (inherit p0) (version "1.1")))
1122 (p1 (dummy-package "p1"
1123 (arguments '(#:implicit-inputs? #f))
1124 (inputs (list p0 `(,p0 "lib"))))))
1125 (lset= equal? (pk (package-grafts %store p1))
1127 (origin (package-derivation %store p0))
1128 (origin-output "out")
1129 (replacement (package-derivation %store p0*))
1130 (replacement-output "out"))
1132 (origin (package-derivation %store p0))
1133 (origin-output "lib")
1134 (replacement (package-derivation %store p0*))
1135 (replacement-output "lib"))))))
1137 (test-assert "replacement also grafted"
1138 ;; We build a DAG as below, where dotted arrows represent replacements and
1139 ;; solid arrows represent dependencies:
1141 ;; P1 ·············> P1R
1142 ;; |\__________________.
1144 ;; P2 ·············> P2R
1149 ;; We want to make sure that:
1150 ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
1152 ;; (A,B) is a graft to replace A by B
1153 ;; grafted(DRV,G) denoted DRV with graft G applied
1154 (let* ((p1r (dummy-package "P1"
1155 (build-system trivial-build-system)
1157 `(#:guile ,%bootstrap-guile
1158 #:builder (let ((out (assoc-ref %outputs "out")))
1160 (call-with-output-file
1161 (string-append out "/replacement")
1164 (inherit p1r) (name "p1") (replacement p1r)
1166 `(#:guile ,%bootstrap-guile
1168 (mkdir (assoc-ref %outputs "out"))
1170 (p2r (dummy-package "P2"
1171 (build-system trivial-build-system)
1174 `(#:guile ,%bootstrap-guile
1175 #:builder (let ((out (assoc-ref %outputs "out")))
1178 (symlink (assoc-ref %build-inputs "p1") "p1")
1179 (call-with-output-file (string-append out "/replacement")
1182 (inherit p2r) (name "p2") (replacement p2r)
1184 `(#:guile ,%bootstrap-guile
1185 #:builder (let ((out (assoc-ref %outputs "out")))
1188 (symlink (assoc-ref %build-inputs "p1")
1191 (p3 (dummy-package "p3"
1192 (build-system trivial-build-system)
1195 `(#:guile ,%bootstrap-guile
1196 #:builder (let ((out (assoc-ref %outputs "out")))
1199 (symlink (assoc-ref %build-inputs "p2")
1203 (package-grafts %store p3)
1205 (origin (package-derivation %store p1 #:graft? #f))
1206 (replacement (package-derivation %store p1r)))
1208 (origin (package-derivation %store p2 #:graft? #f))
1210 (package-derivation %store p2r #:graft? #t)))))))
1212 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
1213 ;;; find out about their run-time dependencies, so this test is no longer
1214 ;;; applicable since it would trigger a full rebuild.
1216 ;; (test-assert "package-derivation, indirect grafts"
1217 ;; (let* ((new (dummy-package "dep"
1218 ;; (arguments '(#:implicit-inputs? #f))))
1219 ;; (dep (package (inherit new) (version "0.0")))
1220 ;; (dep* (package (inherit dep) (replacement new)))
1221 ;; (dummy (dummy-package "dummy"
1222 ;; (arguments '(#:implicit-inputs? #f))
1223 ;; (inputs `(("dep" ,dep*)))))
1224 ;; (guile (package-derivation %store (canonical-package guile-2.0)
1226 ;; (equal? (package-derivation %store dummy)
1227 ;; (graft-derivation %store
1228 ;; (package-derivation %store dummy #:graft? #f)
1229 ;; (package-grafts %store dummy)
1231 ;; ;; Use the same Guile as 'package-derivation'.
1232 ;; #:guile guile))))
1234 (test-equal "package->bag"
1235 `("foo86-hurd" #f (,(package-source gnu-make))
1236 (,(canonical-package glibc)) (,(canonical-package coreutils)))
1237 (let ((bag (package->bag gnu-make "foo86-hurd")))
1238 (list (bag-system bag) (bag-target bag)
1239 (assoc-ref (bag-build-inputs bag) "source")
1240 (assoc-ref (bag-build-inputs bag) "libc")
1241 (assoc-ref (bag-build-inputs bag) "coreutils"))))
1243 (test-assert "package->bag, sensitivity to %current-target-system"
1244 ;; https://bugs.gnu.org/41713
1245 (let* ((lower (lambda* (name #:key system target inputs native-inputs
1248 (bag (name name) (system system) (target target)
1249 (build-inputs native-inputs)
1250 (host-inputs inputs)
1251 (build (lambda* (name inputs
1254 (gexp->derivation "foo"
1255 #~(mkdir #$output))))))))
1257 (name 'build-system-without-cross-compilation)
1258 (description "Does not support cross compilation.")
1260 (dep (dummy-package "dep" (build-system bs)))
1261 (pkg (dummy-package "example"
1262 (native-inputs (list dep))))
1263 (do-not-build (lambda (continue store lst . _) lst)))
1264 (equal? (with-build-handler do-not-build
1265 (parameterize ((%current-target-system "powerpc64le-linux-gnu")
1267 (package-cross-derivation %store pkg
1268 (%current-target-system)
1270 (with-build-handler do-not-build
1271 (package-cross-derivation %store
1272 (package (inherit pkg))
1273 "powerpc64le-linux-gnu"
1276 (test-equal "package->bag, cross-compilation"
1277 `(,(%current-system) "foo86-hurd"
1278 (,(package-source gnu-make))
1279 (,(canonical-package glibc)) (,(canonical-package coreutils)))
1280 (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
1281 (list (bag-system bag) (bag-target bag)
1282 (assoc-ref (bag-build-inputs bag) "source")
1283 (assoc-ref (bag-build-inputs bag) "libc")
1284 (assoc-ref (bag-build-inputs bag) "coreutils"))))
1286 (test-assert "package->bag, propagated inputs"
1287 (let* ((dep (dummy-package "dep"))
1288 (prop (dummy-package "prop"
1289 (propagated-inputs (list dep))))
1290 (dummy (dummy-package "dummy"
1291 (inputs (list prop))))
1292 (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
1293 (match (assoc "dep" inputs)
1295 (eq? package dep)))))
1297 (test-assert "package->bag, sensitivity to %current-system"
1298 (let* ((dep (dummy-package "dep"
1299 (propagated-inputs (if (string=? (%current-system)
1301 `(("libxml2" ,libxml2))
1303 (pkg (dummy-package "foo"
1304 (native-inputs (list dep))))
1305 (bag (package->bag pkg (%current-system) "i586-gnu")))
1306 (equal? (parameterize ((%current-system "x86_64-linux"))
1307 (bag-transitive-inputs bag))
1308 (parameterize ((%current-system "i586-gnu"))
1309 (bag-transitive-inputs bag)))))
1311 (test-assert "package->bag, sensitivity to %current-target-system"
1312 (let* ((dep (dummy-package "dep"
1313 (propagated-inputs (if (%current-target-system)
1314 `(("libxml2" ,libxml2))
1316 (pkg (dummy-package "foo"
1317 (native-inputs (list dep))))
1318 (bag (package->bag pkg (%current-system) "foo86-hurd")))
1319 (equal? (parameterize ((%current-target-system "foo64-gnu"))
1320 (bag-transitive-inputs bag))
1321 (parameterize ((%current-target-system #f))
1322 (bag-transitive-inputs bag)))))
1324 (test-assertm "bag->derivation"
1325 (parameterize ((%graft? #f))
1326 (let ((bag (package->bag gnu-make))
1327 (drv (package-derivation %store gnu-make)))
1328 (parameterize ((%current-system "foox86-hurd")) ;should have no effect
1329 (mlet %store-monad ((bag-drv (bag->derivation bag)))
1330 (return (equal? drv bag-drv)))))))
1332 (test-assert "bag->derivation, cross-compilation"
1333 (parameterize ((%graft? #f))
1334 (let* ((target "mips64el-linux-gnu")
1335 (bag (package->bag gnu-make (%current-system) target))
1336 (drv (package-cross-derivation %store gnu-make target)))
1337 (parameterize ((%current-system "foox86-hurd") ;should have no effect
1338 (%current-target-system "foo64-linux-gnu"))
1339 (mlet %store-monad ((bag-drv (bag->derivation bag)))
1340 (return (equal? drv bag-drv)))))))
1342 (when (or (not (network-reachable?)) (shebang-too-long?))
1344 (test-assert "GNU Make, bootstrap"
1345 ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the
1346 ;; test doesn't last for too long.
1347 (let ((gnu-make gnu-make-for-tests))
1348 (and (package? gnu-make)
1349 (or (location? (package-location gnu-make))
1350 (not (package-location gnu-make)))
1351 (let* ((drv (package-derivation %store gnu-make))
1352 (out (derivation->output-path drv)))
1353 (and (build-derivations %store (list drv))
1354 (file-exists? (string-append out "/bin/make")))))))
1356 (test-equal "package-mapping"
1358 (let* ((dep (dummy-package "chbouib"
1359 (native-inputs `(("x" ,grep)))))
1360 (p0 (dummy-package "example"
1362 (inputs `(("foo" ,coreutils)
1365 (transform (lambda (p)
1366 (package (inherit p) (source 42))))
1367 (rewrite (package-mapping transform))
1369 (bag0 (package->bag p0))
1370 (bag1 (package->bag p1)))
1371 (and (eq? p1 (rewrite p0))
1372 (eqv? 42 (package-source p1))
1374 ;; Implicit inputs should be left unchanged (skip "source", "foo",
1375 ;; "bar", and "baz" in this comparison).
1376 (equal? (drop (bag-direct-inputs bag0) 4)
1377 (drop (bag-direct-inputs bag1) 4))
1379 (match (package-inputs p1)
1380 ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1381 (and (eq? dep1 (rewrite coreutils)) ;memoization
1382 (eq? dep2 (rewrite grep))
1383 (eq? dep3 (rewrite dep))
1385 (package-source dep1) (package-source dep2)
1386 (package-source dep3))
1387 (match (package-native-inputs dep3)
1389 (and (eq? dep (rewrite grep))
1390 (package-source dep))))))))))
1392 (test-equal "package-mapping, deep"
1394 (let* ((p0 (dummy-package "example"
1395 (inputs `(("foo" ,coreutils)
1397 (transform (lambda (p)
1398 (package (inherit p) (source 42))))
1399 (rewrite (package-mapping transform #:deep? #t))
1401 (bag (package->bag p1)))
1402 (and (eq? p1 (rewrite p0))
1403 (match (bag-direct-inputs bag)
1404 ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1)
1405 (and (eq? dep1 (rewrite coreutils)) ;memoization
1406 (eq? dep2 (rewrite grep))
1407 (= 42 (package-source dep1))
1408 (= 42 (package-source dep2))
1410 ;; Check that implicit inputs of P0 also got rewritten.
1414 (package-source package)))
1417 (test-assert "package-input-rewriting"
1418 (let* ((dep (dummy-package "chbouib"
1419 (native-inputs `(("x" ,grep)))))
1420 (p0 (dummy-package "example"
1421 (inputs `(("foo" ,coreutils)
1424 (rewrite (package-input-rewriting `((,coreutils . ,sed)
1425 (,grep . ,findutils))
1426 (cut string-append "r-" <>)
1430 (and (not (eq? p1 p0))
1431 (eq? p1 p2) ;memoization
1432 (string=? "r-example" (package-name p1))
1433 (match (package-inputs p1)
1434 ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1436 (eq? dep2 findutils)
1437 (string=? (package-name dep3) "r-chbouib")
1438 (eq? dep3 (rewrite dep)) ;memoization
1439 (match (package-native-inputs dep3)
1441 (eq? dep findutils))))))
1443 ;; Make sure implicit inputs were left unchanged.
1444 (equal? (drop (bag-direct-inputs (package->bag p1)) 3)
1445 (drop (bag-direct-inputs (package->bag p0)) 3)))))
1447 (test-eq "package-input-rewriting, deep"
1448 (derivation-file-name (package-derivation %store sed))
1449 (let* ((p0 (dummy-package "chbouib"
1450 (build-system python-build-system)
1451 (arguments `(#:python ,python))))
1452 (rewrite (package-input-rewriting `((,python . ,sed))))
1454 (match (bag-direct-inputs (package->bag p1))
1455 ((("python" python) _ ...)
1456 (derivation-file-name (package-derivation %store python))))))
1458 (test-assert "package-input-rewriting/spec"
1459 (let* ((dep (dummy-package "chbouib"
1460 (native-inputs `(("x" ,grep)))))
1461 (p0 (dummy-package "example"
1462 (inputs `(("foo" ,coreutils)
1465 (rewrite (package-input-rewriting/spec
1466 `(("coreutils" . ,(const sed))
1467 ("grep" . ,(const findutils)))
1471 (and (not (eq? p1 p0))
1472 (eq? p1 p2) ;memoization
1473 (string=? "example" (package-name p1))
1474 (match (package-inputs p1)
1475 ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1476 (and (string=? (package-full-name dep1)
1477 (package-full-name sed))
1478 (string=? (package-full-name dep2)
1479 (package-full-name findutils))
1480 (string=? (package-name dep3) "chbouib")
1481 (eq? dep3 (rewrite dep)) ;memoization
1482 (match (package-native-inputs dep3)
1484 (string=? (package-full-name dep)
1485 (package-full-name findutils)))))))
1487 ;; Make sure implicit inputs were left unchanged.
1488 (equal? (drop (bag-direct-inputs (package->bag p1)) 3)
1489 (drop (bag-direct-inputs (package->bag p0)) 3)))))
1491 (test-assert "package-input-rewriting/spec, partial match"
1492 (let* ((dep (dummy-package "chbouib"
1494 (native-inputs `(("x" ,grep)))))
1495 (p0 (dummy-package "example"
1496 (inputs `(("foo" ,coreutils)
1498 (rewrite (package-input-rewriting/spec
1499 `(("chbouib@123" . ,(const sed)) ;not matched
1500 ("grep" . ,(const findutils)))
1503 (and (not (eq? p1 p0))
1504 (string=? "example" (package-name p1))
1505 (match (package-inputs p1)
1506 ((("foo" dep1) ("bar" dep2))
1507 (and (string=? (package-full-name dep1)
1508 (package-full-name coreutils))
1509 (eq? dep2 (rewrite dep)) ;memoization
1510 (match (package-native-inputs dep2)
1512 (string=? (package-full-name dep)
1513 (package-full-name findutils))))))))))
1515 (test-assert "package-input-rewriting/spec, deep"
1516 (let* ((dep (dummy-package "chbouib"))
1517 (p0 (dummy-package "example"
1518 (build-system gnu-build-system)
1519 (inputs `(("dep" ,dep)))))
1520 (rewrite (package-input-rewriting/spec
1521 `(("tar" . ,(const sed))
1522 ("gzip" . ,(const findutils)))))
1525 (and (not (eq? p1 p0))
1526 (eq? p1 p2) ;memoization
1527 (string=? "example" (package-name p1))
1528 (match (package-inputs p1)
1530 (and (string=? (package-full-name dep1)
1531 (package-full-name dep))
1532 (eq? dep1 (rewrite dep))))) ;memoization
1534 ;; Make sure implicit inputs were replaced.
1535 (match (bag-direct-inputs (package->bag p1))
1536 ((("dep" dep1) ("tar" tar) ("gzip" gzip) _ ...)
1537 (and (eq? dep1 (rewrite dep))
1538 (string=? (package-full-name tar)
1539 (package-full-name sed))
1540 (string=? (package-full-name gzip)
1541 (package-full-name findutils))))))))
1543 (test-assert "package-input-rewriting/spec, no duplicates"
1544 ;; Ensure that deep input rewriting does not forget implicit inputs. Doing
1545 ;; so could lead to duplicates in a package's inputs: in the example below,
1546 ;; P0's transitive inputs would contain one rewritten "python" and one
1547 ;; original "python". These two "python" packages are thus not 'eq?' but
1548 ;; they lower to the same derivation. See <https://bugs.gnu.org/42156>,
1549 ;; which can be reproduced by passing #:deep? #f.
1550 (let* ((dep0 (dummy-package "dep0"
1551 (build-system trivial-build-system)
1552 (propagated-inputs `(("python" ,python)))))
1553 (p0 (dummy-package "chbouib"
1554 (build-system python-build-system)
1555 (arguments `(#:python ,python))
1556 (inputs `(("dep0" ,dep0)))))
1557 (rewrite (package-input-rewriting/spec '() #:deep? #t))
1559 (bag1 (package->bag p1))
1560 (pythons (filter-map (match-lambda
1561 (("python" python) python)
1563 (bag-transitive-inputs bag1))))
1564 (match (delete-duplicates pythons eq?)
1565 ((p) (eq? p (rewrite python))))))
1567 (test-equal "package-input-rewriting/spec, graft"
1568 (derivation-file-name (package-derivation %store sed))
1570 ;; Make sure replacements are rewritten.
1571 (let* ((dep0 (dummy-package "dep"
1573 (build-system trivial-build-system)
1574 (inputs `(("coreutils" ,coreutils)))))
1575 (dep1 (dummy-package "dep"
1577 (build-system trivial-build-system)
1578 (replacement dep0)))
1579 (p0 (dummy-package "p"
1580 (build-system trivial-build-system)
1581 (inputs `(("dep" ,dep1)))))
1582 (rewrite (package-input-rewriting/spec
1583 `(("coreutils" . ,(const sed)))))
1585 (match (package-inputs p1)
1587 (match (package-inputs (package-replacement dep))
1588 ((("coreutils" coreutils))
1589 ;; COREUTILS is not 'eq?' to SED, so the most reliable way to check
1590 ;; for equality is to lower to a derivation.
1591 (derivation-file-name
1592 (package-derivation %store coreutils))))))))
1594 (test-assert "package-with-c-toolchain"
1595 (let* ((dep (dummy-package "chbouib"
1596 (build-system gnu-build-system)
1597 (native-inputs `(("x" ,grep)))))
1598 (p0 (dummy-package "thingie"
1599 (build-system gnu-build-system)
1600 (inputs `(("foo" ,grep)
1602 (tc (dummy-package "my-toolchain"))
1603 (p1 (package-with-c-toolchain p0 `(("toolchain" ,tc)))))
1604 (define toolchain-packages
1605 '("gcc" "binutils" "glibc" "ld-wrapper"))
1607 (match (bag-build-inputs (package->bag p1))
1608 ((("foo" foo) ("bar" bar) (_ (= package-name packages) . _) ...)
1609 (and (not (any (cut member <> packages) toolchain-packages))
1610 (member "my-toolchain" packages)
1614 (test-assert "package-input-rewriting/spec, identity"
1615 ;; Make sure that 'package-input-rewriting/spec' doesn't gratuitously
1616 ;; introduce variants. In this case, the LIBFFI propagated input should not
1617 ;; be duplicated when passing GOBJECT through REWRITE.
1618 ;; See <https://issues.guix.gnu.org/43890>.
1619 (let* ((libffi (dummy-package "libffi"
1620 (build-system trivial-build-system)))
1621 (glib (dummy-package "glib"
1622 (build-system trivial-build-system)
1623 (propagated-inputs (list libffi))))
1624 (gobject (dummy-package "gobject-introspection"
1625 (build-system trivial-build-system)
1626 (inputs (list glib))
1627 (propagated-inputs (list libffi))))
1628 (rewrite (package-input-rewriting/spec
1629 `(("glib" . ,identity)))))
1630 (and (= (length (package-transitive-inputs gobject))
1631 (length (package-transitive-inputs (rewrite gobject))))
1632 (string=? (derivation-file-name
1633 (package-derivation %store (rewrite gobject)))
1634 (derivation-file-name
1635 (package-derivation %store gobject))))))
1637 (test-assert "package-input-rewriting, identity"
1638 ;; Similar to the test above, but with 'package-input-rewriting'.
1639 ;; See <https://issues.guix.gnu.org/43890>.
1640 (let* ((libffi (dummy-package "libffi"
1641 (build-system trivial-build-system)))
1642 (glib (dummy-package "glib"
1643 (build-system trivial-build-system)
1644 (propagated-inputs (list libffi))))
1645 (gobject (dummy-package "gobject-introspection"
1646 (build-system trivial-build-system)
1647 (inputs (list glib))
1648 (propagated-inputs (list libffi))))
1649 (rewrite (package-input-rewriting `((,glib . ,glib)))))
1650 (and (= (length (package-transitive-inputs gobject))
1651 (length (package-transitive-inputs (rewrite gobject))))
1652 (string=? (derivation-file-name
1653 (package-derivation %store (rewrite gobject)))
1654 (derivation-file-name
1655 (package-derivation %store gobject))))))
1657 (test-equal "package-patched-vulnerabilities"
1659 ("CVE-2016-1234" "CVE-2018-4567")
1661 (let ((p1 (dummy-package "pi"
1662 (source (dummy-origin
1663 (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
1664 (p2 (dummy-package "pi"
1665 (source (dummy-origin
1667 "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
1668 (p3 (dummy-package "pi" (source (dummy-origin)))))
1669 (map package-patched-vulnerabilities
1672 (test-eq "fold-packages" hello
1673 (fold-packages (lambda (p r)
1674 (if (string=? (package-name p) "hello")
1679 (test-assert "fold-packages, hidden package"
1680 ;; There are two public variables providing "guile@2.0" ('guile-final' in
1681 ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
1683 (match (fold-packages (lambda (p r)
1684 (if (and (string=? (package-name p) "guile")
1685 (string-prefix? "2.0"
1686 (package-version p)))
1691 (eq? one guile-2.0))))
1693 (test-assert "fold-available-packages with/without cache"
1696 (fold-available-packages (lambda* (name version result #:rest rest)
1697 (cons (cons* name version rest)
1702 (call-with-temporary-directory
1704 (generate-package-cache cache)
1705 (mock ((guix describe) current-profile (const cache))
1706 (mock ((gnu packages) cache-is-authoritative? (const #t))
1707 (fold-available-packages (lambda* (name version result
1709 (cons (cons* name version rest)
1713 (define (list->set* lst)
1714 ;; Return two values: LST represented as a set and the list of
1715 ;; duplicates in LST.
1716 (let loop ((lst lst)
1721 (values seen duplicates))
1723 (if (set-contains? seen head)
1724 (loop tail (cons head duplicates) seen)
1725 (loop tail duplicates (set-insert head seen)))))))
1727 ;; Compare FROM-CACHE and NO-CACHE but avoid 'lset=', which exhibits
1728 ;; exponential behavior.
1729 (let ((set1 duplicates1 (list->set* from-cache))
1730 (set2 duplicates2 (list->set* no-cache)))
1731 (and (null? duplicates1) (null? duplicates2)
1732 (every (cut set-contains? set1 <>) no-cache)
1733 (every (cut set-contains? set2 <>) from-cache)))))
1735 (test-assert "find-packages-by-name"
1736 (match (find-packages-by-name "hello")
1737 (((? (cut eq? hello <>))) #t)
1738 (wrong (pk 'find-packages-by-name wrong #f))))
1740 (test-assert "find-packages-by-name with version"
1741 (match (find-packages-by-name "hello" (package-version hello))
1742 (((? (cut eq? hello <>))) #t)
1743 (wrong (pk 'find-packages-by-name wrong #f))))
1745 (test-equal "find-packages-by-name with cache"
1746 (find-packages-by-name "guile")
1747 (call-with-temporary-directory
1749 (generate-package-cache cache)
1750 (mock ((guix describe) current-profile (const cache))
1751 (mock ((gnu packages) cache-is-authoritative? (const #t))
1752 (find-packages-by-name "guile"))))))
1754 (test-equal "find-packages-by-name + version, with cache"
1755 (find-packages-by-name "guile" "2")
1756 (call-with-temporary-directory
1758 (generate-package-cache cache)
1759 (mock ((guix describe) current-profile (const cache))
1760 (mock ((gnu packages) cache-is-authoritative? (const #t))
1761 (find-packages-by-name "guile" "2"))))))
1763 (test-assert "--search-paths with pattern"
1764 ;; Make sure 'guix package --search-paths' correctly reports environment
1765 ;; variables when file patterns are used (in particular, it must follow
1766 ;; symlinks when looking for 'catalog.xml'.) To do that, we rely on the
1767 ;; libxml2 package specification, which contains such a definition.
1769 (name "foo") (version "0") (source #f)
1770 (build-system trivial-build-system)
1772 `(#:guile ,%bootstrap-guile
1773 #:modules ((guix build utils))
1775 (use-modules (guix build utils))
1776 (let ((out (assoc-ref %outputs "out")))
1777 (mkdir-p (string-append out "/xml/bar/baz"))
1778 (call-with-output-file
1779 (string-append out "/xml/bar/baz/catalog.xml")
1781 (display "xml? wat?!" port)))
1783 (synopsis #f) (description #f)
1784 (home-page #f) (license #f)))
1786 ;; Provide a fake libxml2 to avoid building the real one. This
1787 ;; is OK because 'guix package' gets search path specifications
1788 ;; from the same-named package found in the distro.
1789 (name "libxml2") (version "0.0.0") (source #f)
1790 (build-system trivial-build-system)
1792 `(#:guile ,%bootstrap-guile
1794 (mkdir (assoc-ref %outputs "out"))
1796 (native-search-paths (package-native-search-paths libxml2))
1797 (synopsis #f) (description #f)
1798 (home-page #f) (license #f)))
1799 (prof (run-with-store %store
1801 (manifest (map package->manifest-entry
1805 #:guile-for-build (%guile-for-build))))
1806 (build-derivations %store (list prof))
1807 (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
1808 (regexp-quote (derivation->output-path prof)))
1809 (with-output-to-string
1811 (guix-package "-p" (derivation->output-path prof)
1812 "--search-paths"))))))
1814 (test-assert "--search-paths with single-item search path"
1815 ;; Make sure 'guix package --search-paths' correctly reports environment
1816 ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
1817 ;; separator, meaning that the first match wins.
1818 (let* ((p1 (dummy-package "foo"
1819 (build-system trivial-build-system)
1821 `(#:guile ,%bootstrap-guile
1822 #:modules ((guix build utils))
1824 (use-modules (guix build utils))
1825 (let ((out (assoc-ref %outputs "out")))
1826 (mkdir-p (string-append out "/etc/ssl/certs"))
1827 (call-with-output-file
1829 out "/etc/ssl/certs/ca-certificates.crt")
1831 (p2 (package (inherit p1) (name "bar")))
1832 (p3 (dummy-package "git"
1833 ;; Provide a fake Git to avoid building the real one.
1834 (build-system trivial-build-system)
1836 `(#:guile ,%bootstrap-guile
1838 (mkdir (assoc-ref %outputs "out"))
1840 (native-search-paths (package-native-search-paths git))))
1841 (prof1 (run-with-store %store
1843 (packages->manifest (list p1 p3))
1846 #:guile-for-build (%guile-for-build)))
1847 (prof2 (run-with-store %store
1849 (packages->manifest (list p2 p3))
1852 #:guile-for-build (%guile-for-build))))
1853 (build-derivations %store (list prof1 prof2))
1854 (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
1855 (regexp-quote (derivation->output-path prof1)))
1856 (with-output-to-string
1858 (guix-package "-p" (derivation->output-path prof1)
1859 "-p" (derivation->output-path prof2)
1860 "--search-paths"))))))
1862 (test-equal "specification->package when not found"
1866 ;; This should call 'leave', producing an error message.
1867 (specification->package "this-package-does-not-exist"))
1868 (lambda (key . args)
1871 (test-equal "specification->package+output"
1872 `((,coreutils "out") (,coreutils "debug"))
1873 (list (call-with-values (lambda ()
1874 (specification->package+output "coreutils"))
1876 (call-with-values (lambda ()
1877 (specification->package+output "coreutils:debug"))
1880 (test-equal "specification->package+output invalid output"
1884 (specification->package+output "coreutils:does-not-exist"))
1888 (test-equal "specification->package+output no default output"
1892 (specification->package+output "coreutils" #f))
1895 (test-equal "specification->package+output invalid output, no default"
1899 (specification->package+output "coreutils:does-not-exist" #f))
1903 (test-equal "find-package-locations"
1904 (map (lambda (package)
1905 (cons (package-version package)
1906 (package-location package)))
1907 (find-packages-by-name "guile"))
1908 (find-package-locations "guile"))
1910 (test-equal "find-package-locations with cache"
1911 (map (lambda (package)
1912 (cons (package-version package)
1913 (package-location package)))
1914 (find-packages-by-name "guile"))
1915 (call-with-temporary-directory
1917 (generate-package-cache cache)
1918 (mock ((guix describe) current-profile (const cache))
1919 (mock ((gnu packages) cache-is-authoritative? (const #t))
1920 (find-package-locations "guile"))))))
1922 (test-equal "specification->location"
1923 (package-location (specification->package "guile@2"))
1924 (specification->location "guile@2"))
1926 (test-equal "package-unique-version-prefix, gcc@8"
1928 (let ((gcc (specification->package "gcc-toolchain@8")))
1929 (package-unique-version-prefix (package-name gcc)
1930 (package-version gcc))))
1932 (test-equal "package-unique-version-prefix, grep"
1934 (let ((grep (specification->package "grep")))
1935 (package-unique-version-prefix (package-name grep)
1936 (package-version grep))))
1939 (test-eq "this-package-input, exists"
1943 (inputs `(("hello" ,hello)))
1944 (arguments (this-package-input "hello")))))
1946 (test-eq "this-package-input, exists in propagated-inputs"
1950 (propagated-inputs `(("hello" ,hello)))
1951 (arguments (this-package-input "hello")))))
1953 (test-eq "this-package-input, does not exist"
1957 (arguments (this-package-input "hello")))))
1959 (test-eq "this-package-native-input, exists"
1963 (native-inputs `(("hello" ,hello)))
1964 (arguments (this-package-native-input "hello")))))
1966 (test-eq "this-package-native-input, does not exists"
1970 (arguments (this-package-native-input "hello")))))
1972 (test-eq "modify-inputs, replace"
1974 ;; Replace an input; notice that the label in unchanged.
1975 (let* ((p1 (dummy-package "p"
1976 (inputs (list hello))))
1980 (inputs (modify-inputs (package-inputs p1)
1981 (replace "hello" coreutils))))))
1982 (lookup-package-input p2 "hello")))
1984 (test-eq "modify-inputs, replace, change output"
1986 ;; Replace an input and choose a different output.
1987 (let* ((p1 (dummy-package "p"
1988 (inputs (list `(,coreutils "debug")))))
1992 (inputs (modify-inputs (package-inputs p1)
1993 (replace "coreutils" `(,guile-3.0 "out")))))))
1994 (match (package-inputs p2)
1995 ((("coreutils" input "out"))
1998 (test-eq "modify-inputs, replace, extra output"
2000 ;; Replace an input; notice that its output is preserved.
2001 ;; See <https://issues.guix.gnu.org/53915>.
2002 (let* ((p1 (dummy-package "p"
2003 (inputs (list `(,coreutils "debug")))))
2007 (inputs (modify-inputs (package-inputs p1)
2008 (replace "coreutils" guile-3.0))))))
2009 (match (package-inputs p2)
2010 ((("coreutils" input "debug"))
2013 (test-end "packages")
2015 ;;; Local Variables:
2016 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
2017 ;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1)