;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix monads)
#:use-module (guix grafts)
#:use-module ((guix gexp) #:select (local-file local-file-file))
- #:use-module ((guix utils)
+ #:use-module (guix utils)
+ #:use-module ((guix diagnostics)
;; Rename the 'location' binding to allow proper syntax
;; matching when setting the 'location' field of a package.
#:renamer (lambda (name)
(cond ((eq? name 'location) 'make-location)
(else name))))
- #:use-module (guix hash)
+ #:use-module ((gcrypt hash) #:prefix gcrypt:)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix grafts)
#:use-module (guix build-system)
#:use-module (guix build-system trivial)
#:use-module (guix build-system gnu)
+ #:use-module (guix memoization)
#:use-module (guix profiles)
#:use-module (guix scripts package)
#:use-module (gnu packages)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
+ #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (ice-9 vlist)
#:use-module (ice-9 regex)
(test-assert "transaction-upgrade-entry, zero upgrades"
(let* ((old (dummy-package "foo" (version "1")))
- (tx (mock ((gnu packages) find-newest-available-packages
- (const vlist-null))
- ((@@ (guix scripts package) transaction-upgrade-entry)
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const '()))
+ (transaction-upgrade-entry
+ #f ;no store access needed
(manifest-entry
(inherit (package->manifest-entry old))
(item (string-append (%store-prefix) "/"
(manifest-transaction)))))
(manifest-transaction-null? tx)))
+(test-assert "transaction-upgrade-entry, zero upgrades, equivalent package"
+ (let* ((old (dummy-package "foo" (version "1")))
+ (drv (package-derivation %store old))
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list old)))
+ (transaction-upgrade-entry
+ %store
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (derivation->output-path drv)))
+ (manifest-transaction)))))
+ (manifest-transaction-null? tx)))
+
+(test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs"
+ ;; Properly detect equivalent packages even when they have propagated
+ ;; inputs. See <https://bugs.gnu.org/35872>.
+ (let* ((dep (dummy-package "dep" (version "2")))
+ (old (dummy-package "foo" (version "1")
+ (propagated-inputs `(("dep" ,dep)))))
+ (drv (package-derivation %store old))
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list old)))
+ (transaction-upgrade-entry
+ %store
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (derivation->output-path drv))
+ (dependencies
+ (list (manifest-entry
+ (inherit (package->manifest-entry dep))
+ (item (derivation->output-path
+ (package-derivation %store dep)))))))
+ (manifest-transaction)))))
+ (manifest-transaction-null? tx)))
+
(test-assert "transaction-upgrade-entry, one upgrade"
(let* ((old (dummy-package "foo" (version "1")))
(new (dummy-package "foo" (version "2")))
- (tx (mock ((gnu packages) find-newest-available-packages
- (const (vhash-cons "foo" (list "2" new) vlist-null)))
- ((@@ (guix scripts package) transaction-upgrade-entry)
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list new)))
+ (transaction-upgrade-entry
+ #f ;no store access needed
(manifest-entry
(inherit (package->manifest-entry old))
(item (string-append (%store-prefix) "/"
(let* ((old (dummy-package "foo" (version "1")))
(new (dummy-package "bar" (version "2")))
(dep (deprecated-package "foo" new))
- (tx (mock ((gnu packages) find-newest-available-packages
- (const (vhash-cons "foo" (list "2" dep) vlist-null)))
- ((@@ (guix scripts package) transaction-upgrade-entry)
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list dep)))
+ (transaction-upgrade-entry
+ #f ;no store access needed
(manifest-entry
(inherit (package->manifest-entry old))
(item (string-append (%store-prefix) "/"
(string=? (manifest-pattern-version pattern) "1")
(string=? (manifest-pattern-output pattern) "out")))))))
+(test-assert "transaction-upgrade-entry, grafts"
+ ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't
+ ;; try to build stuff.
+ (with-build-handler (const 'failed!)
+ (parameterize ((%graft? #t))
+ (let* ((old (dummy-package "foo" (version "1")))
+ (bar (dummy-package "bar" (version "0")
+ (replacement old)))
+ (new (dummy-package "foo" (version "1")
+ (inputs `(("bar" ,bar)))))
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list new)))
+ (transaction-upgrade-entry
+ %store
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (string-append (%store-prefix) "/"
+ (make-string 32 #\e) "-foo-1")))
+ (manifest-transaction)))))
+ (and (match (manifest-transaction-install tx)
+ ((($ <manifest-entry> "foo" "1" "out" item))
+ (eq? item new)))
+ (null? (manifest-transaction-remove tx)))))))
+
(test-assert "package-field-location"
(let ()
(define (goto port line column)
(package-transitive-supported-systems d)
(package-transitive-supported-systems e))))
+(test-assert "package-closure"
+ (let-syntax ((dummy-package/no-implicit
+ (syntax-rules ()
+ ((_ name rest ...)
+ (package
+ (inherit (dummy-package name rest ...))
+ (build-system trivial-build-system))))))
+ (let* ((a (dummy-package/no-implicit "a"))
+ (b (dummy-package/no-implicit "b"
+ (propagated-inputs `(("a" ,a)))))
+ (c (dummy-package/no-implicit "c"
+ (inputs `(("a" ,a)))))
+ (d (dummy-package/no-implicit "d"
+ (native-inputs `(("b" ,b)))))
+ (e (dummy-package/no-implicit "e"
+ (inputs `(("c" ,c) ("d" ,d))))))
+ (lset= eq?
+ (list a b c d e)
+ (package-closure (list e))
+ (package-closure (list e d))
+ (package-closure (list e c b))))))
+
(test-equal "origin-actual-file-name"
"foo-1.tar.gz"
(let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
(test-equal "package-transitive-supported-systems, implicit inputs"
%supported-systems
+ ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
+ ;; %SUPPORTED-SYSTEMS. Thus the others must be ignored.
+ (let ((p (dummy-package "foo"
+ (build-system gnu-build-system)
+ (supported-systems
+ `("does-not-exist" "foobar" ,@%supported-systems)))))
+ (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture
+ (package-transitive-supported-systems p))))
+
+(test-equal "package-transitive-supported-systems: reduced binary seed, implicit inputs"
+ '("x86_64-linux" "i686-linux")
+
;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
;; %SUPPORTED-SYSTEMS. Thus the others must be ignored.
(let ((p (dummy-package "foo"
(build-system gnu-build-system)
(supported-systems
`("does-not-exist" "foobar" ,@%supported-systems)))))
- (package-transitive-supported-systems p)))
+ (parameterize ((%current-system "x86_64-linux"))
+ (package-transitive-supported-systems p))))
(test-assert "supported-package?"
- (let ((p (dummy-package "foo"
- (build-system gnu-build-system)
- (supported-systems '("x86_64-linux" "does-not-exist")))))
+ (let* ((d (dummy-package "dep"
+ (build-system trivial-build-system)
+ (supported-systems '("x86_64-linux"))))
+ (p (dummy-package "foo"
+ (build-system gnu-build-system)
+ (inputs `(("d" ,d)))
+ (supported-systems '("x86_64-linux" "armhf-linux")))))
+ (and (supported-package? p "x86_64-linux")
+ (not (supported-package? p "i686-linux"))
+ (not (supported-package? p "armhf-linux")))))
+
+(test-assert "supported-package? vs. system-dependent graph"
+ ;; The inputs of a package can depend on (%current-system). Thus,
+ ;; 'supported-package?' must make sure that it binds (%current-system)
+ ;; appropriately before traversing the dependency graph. In the example
+ ;; below, 'supported-package?' must thus return true for both systems.
+ (let* ((p0a (dummy-package "foo-arm"
+ (build-system trivial-build-system)
+ (supported-systems '("armhf-linux"))))
+ (p0b (dummy-package "foo-x86_64"
+ (build-system trivial-build-system)
+ (supported-systems '("x86_64-linux"))))
+ (p (dummy-package "bar"
+ (build-system trivial-build-system)
+ (inputs
+ (if (string=? (%current-system) "armhf-linux")
+ `(("foo" ,p0a))
+ `(("foo" ,p0b)))))))
(and (supported-package? p "x86_64-linux")
- (not (supported-package? p "does-not-exist"))
- (not (supported-package? p "i686-linux")))))
+ (supported-package? p "armhf-linux"))))
(test-skip (if (not %store) 8 0))
(search-path %load-path "guix/base32.scm")
get-bytevector-all)))))
+(test-equal "package-source-derivation, origin, sha512"
+ "hello"
+ (let* ((bash (search-bootstrap-binary "bash" (%current-system)))
+ (builder (add-text-to-store %store "my-fixed-builder.sh"
+ "echo -n hello > $out" '()))
+ (method (lambda* (url hash-algo hash #:optional name
+ #:rest rest)
+ (and (eq? hash-algo 'sha512)
+ (raw-derivation name bash (list builder)
+ #:sources (list builder)
+ #:hash hash
+ #:hash-algo hash-algo))))
+ (source (origin
+ (method method)
+ (uri "unused://")
+ (file-name "origin-sha512")
+ (hash (content-hash
+ (gcrypt:bytevector-hash (string->utf8 "hello")
+ (gcrypt:lookup-hash-algorithm
+ 'sha512))
+ sha512))))
+ (drv (package-source-derivation %store source))
+ (output (derivation->output-path drv)))
+ (build-derivations %store (list drv))
+ (call-with-input-file output get-string-all)))
+
+(test-equal "package-source-derivation, origin, sha3-512"
+ "hello, sha3"
+ (let* ((bash (search-bootstrap-binary "bash" (%current-system)))
+ (builder (add-text-to-store %store "my-fixed-builder.sh"
+ "echo -n hello, sha3 > $out" '()))
+ (method (lambda* (url hash-algo hash #:optional name
+ #:rest rest)
+ (and (eq? hash-algo 'sha3-512)
+ (raw-derivation name bash (list builder)
+ #:sources (list builder)
+ #:hash hash
+ #:hash-algo hash-algo))))
+ (source (origin
+ (method method)
+ (uri "unused://")
+ (file-name "origin-sha3")
+ (hash (content-hash
+ (gcrypt:bytevector-hash (string->utf8 "hello, sha3")
+ (gcrypt:lookup-hash-algorithm
+ 'sha3-512))
+ sha3-512))))
+ (drv (package-source-derivation %store source))
+ (output (derivation->output-path drv)))
+ (build-derivations %store (list drv))
+ (call-with-input-file output get-string-all)))
+
(unless (network-reachable?) (test-skip 1))
(test-equal "package-source-derivation, snippet"
"OK"
(string=? (derivation->output-path drv)
(package-output %store package "out")))))
-(test-assert "patch not found yields a run-time error"
- (guard (c ((condition-has-type? c &message)
- (and (string-contains (condition-message c)
- "does-not-exist.patch")
- (string-contains (condition-message c)
- "not found"))))
+(test-equal "patch not found yields a run-time error"
+ '("~a: patch not found\n" "does-not-exist.patch")
+ (guard (c ((formatted-message? c)
+ (cons (formatted-message-string c)
+ (formatted-message-arguments c))))
(let ((p (package
(inherit (dummy-package "p"))
(source (origin
(symlink %output (string-append %output "/self"))
#t)))))
(d (package-derivation %store p)))
- (guard (c ((nix-protocol-error? c) #t))
+ (guard (c ((store-protocol-error? c) #t))
(build-derivations %store (list d))
#f)))
(replacement #f))))
(replacement (package-derivation %store new)))))))
+(test-assert "package-grafts, dependency on several outputs"
+ ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
+ (letrec* ((p0 (dummy-package "p0"
+ (version "1.0")
+ (replacement p0*)
+ (arguments '(#:implicit-inputs? #f))
+ (outputs '("out" "lib"))))
+ (p0* (package (inherit p0) (version "1.1")))
+ (p1 (dummy-package "p1"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("p0" ,p0)
+ ("p0:lib" ,p0 "lib"))))))
+ (lset= equal? (pk (package-grafts %store p1))
+ (list (graft
+ (origin (package-derivation %store p0))
+ (origin-output "out")
+ (replacement (package-derivation %store p0*))
+ (replacement-output "out"))
+ (graft
+ (origin (package-derivation %store p0))
+ (origin-output "lib")
+ (replacement (package-derivation %store p0*))
+ (replacement-output "lib"))))))
+
(test-assert "replacement also grafted"
;; We build a DAG as below, where dotted arrows represent replacements and
;; solid arrows represent dependencies:
(assoc-ref (bag-build-inputs bag) "libc")
(assoc-ref (bag-build-inputs bag) "coreutils"))))
+(test-assert "package->bag, sensitivity to %current-target-system"
+ ;; https://bugs.gnu.org/41713
+ (let* ((lower (lambda* (name #:key system target inputs native-inputs
+ #:allow-other-keys)
+ (and (not target)
+ (bag (name name) (system system) (target target)
+ (build-inputs native-inputs)
+ (host-inputs inputs)
+ (build (lambda* (store name inputs
+ #:key system target
+ #:allow-other-keys)
+ (build-expression->derivation
+ store "foo" '(mkdir %output))))))))
+ (bs (build-system
+ (name 'build-system-without-cross-compilation)
+ (description "Does not support cross compilation.")
+ (lower lower)))
+ (dep (dummy-package "dep" (build-system bs)))
+ (pkg (dummy-package "example"
+ (native-inputs `(("dep" ,dep)))))
+ (do-not-build (lambda (continue store lst . _) lst)))
+ (equal? (with-build-handler do-not-build
+ (parameterize ((%current-target-system "powerpc64le-linux-gnu")
+ (%graft? #t))
+ (package-cross-derivation %store pkg
+ (%current-target-system)
+ #:graft? #t)))
+ (with-build-handler do-not-build
+ (package-cross-derivation %store
+ (package (inherit pkg))
+ "powerpc64le-linux-gnu"
+ #:graft? #t)))))
+
(test-equal "package->bag, cross-compilation"
`(,(%current-system) "foo86-hurd"
(,(package-source gnu-make))
(("dep" package)
(eq? package dep)))))
+(test-assert "package->bag, sensitivity to %current-system"
+ (let* ((dep (dummy-package "dep"
+ (propagated-inputs (if (string=? (%current-system)
+ "i586-gnu")
+ `(("libxml2" ,libxml2))
+ '()))))
+ (pkg (dummy-package "foo"
+ (native-inputs `(("dep" ,dep)))))
+ (bag (package->bag pkg (%current-system) "i586-gnu")))
+ (equal? (parameterize ((%current-system "x86_64-linux"))
+ (bag-transitive-inputs bag))
+ (parameterize ((%current-system "i586-gnu"))
+ (bag-transitive-inputs bag)))))
+
+(test-assert "package->bag, sensitivity to %current-target-system"
+ (let* ((dep (dummy-package "dep"
+ (propagated-inputs (if (%current-target-system)
+ `(("libxml2" ,libxml2))
+ '()))))
+ (pkg (dummy-package "foo"
+ (native-inputs `(("dep" ,dep)))))
+ (bag (package->bag pkg (%current-system) "foo86-hurd")))
+ (equal? (parameterize ((%current-target-system "foo64-gnu"))
+ (bag-transitive-inputs bag))
+ (parameterize ((%current-target-system #f))
+ (bag-transitive-inputs bag)))))
+
(test-assert "bag->derivation"
(parameterize ((%graft? #f))
(let ((bag (package->bag gnu-make))
(when (or (not (network-reachable?)) (shebang-too-long?))
(test-skip 1))
(test-assert "GNU Make, bootstrap"
- ;; GNU Make is the first program built during bootstrap; we choose it
- ;; here so that the test doesn't last for too long.
- (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0)))
+ ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the
+ ;; test doesn't last for too long.
+ (let ((gnu-make gnu-make-for-tests))
(and (package? gnu-make)
(or (location? (package-location gnu-make))
(not (package-location gnu-make)))
((("x" dep))
(eq? dep findutils)))))))))
+(test-assert "package-input-rewriting/spec"
+ (let* ((dep (dummy-package "chbouib"
+ (native-inputs `(("x" ,grep)))))
+ (p0 (dummy-package "example"
+ (inputs `(("foo" ,coreutils)
+ ("bar" ,grep)
+ ("baz" ,dep)))))
+ (rewrite (package-input-rewriting/spec
+ `(("coreutils" . ,(const sed))
+ ("grep" . ,(const findutils)))))
+ (p1 (rewrite p0))
+ (p2 (rewrite p0)))
+ (and (not (eq? p1 p0))
+ (eq? p1 p2) ;memoization
+ (string=? "example" (package-name p1))
+ (match (package-inputs p1)
+ ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+ (and (string=? (package-full-name dep1)
+ (package-full-name sed))
+ (string=? (package-full-name dep2)
+ (package-full-name findutils))
+ (string=? (package-name dep3) "chbouib")
+ (eq? dep3 (rewrite dep)) ;memoization
+ (match (package-native-inputs dep3)
+ ((("x" dep))
+ (string=? (package-full-name dep)
+ (package-full-name findutils))))))))))
+
+(test-assert "package-input-rewriting/spec, partial match"
+ (let* ((dep (dummy-package "chbouib"
+ (version "1")
+ (native-inputs `(("x" ,grep)))))
+ (p0 (dummy-package "example"
+ (inputs `(("foo" ,coreutils)
+ ("bar" ,dep)))))
+ (rewrite (package-input-rewriting/spec
+ `(("chbouib@123" . ,(const sed)) ;not matched
+ ("grep" . ,(const findutils)))))
+ (p1 (rewrite p0)))
+ (and (not (eq? p1 p0))
+ (string=? "example" (package-name p1))
+ (match (package-inputs p1)
+ ((("foo" dep1) ("bar" dep2))
+ (and (string=? (package-full-name dep1)
+ (package-full-name coreutils))
+ (eq? dep2 (rewrite dep)) ;memoization
+ (match (package-native-inputs dep2)
+ ((("x" dep))
+ (string=? (package-full-name dep)
+ (package-full-name findutils))))))))))
+
(test-equal "package-patched-vulnerabilities"
'(("CVE-2015-1234")
("CVE-2016-1234" "CVE-2018-4567")
((one)
(eq? one guile-2.0))))
+(test-assert "fold-available-packages with/without cache"
+ (let ()
+ (define no-cache
+ (fold-available-packages (lambda* (name version result #:rest rest)
+ (cons (cons* name version rest)
+ result))
+ '()))
+
+ (define from-cache
+ (call-with-temporary-directory
+ (lambda (cache)
+ (generate-package-cache cache)
+ (mock ((guix describe) current-profile (const cache))
+ (mock ((gnu packages) cache-is-authoritative? (const #t))
+ (fold-available-packages (lambda* (name version result
+ #:rest rest)
+ (cons (cons* name version rest)
+ result))
+ '()))))))
+
+ (define (find-duplicates l)
+ (match l
+ (() '())
+ ((head . tail)
+ (if (member head tail)
+ (cons head (find-duplicates tail))
+ (find-duplicates tail)))))
+
+ (pk (find-duplicates from-cache))
+ (and (equal? (delete-duplicates from-cache) from-cache)
+ (lset= equal? no-cache from-cache))))
+
(test-assert "find-packages-by-name"
(match (find-packages-by-name "hello")
(((? (cut eq? hello <>))) #t)
(((? (cut eq? hello <>))) #t)
(wrong (pk 'find-packages-by-name wrong #f))))
+(test-equal "find-packages-by-name with cache"
+ (find-packages-by-name "guile")
+ (call-with-temporary-directory
+ (lambda (cache)
+ (generate-package-cache cache)
+ (mock ((guix describe) current-profile (const cache))
+ (mock ((gnu packages) cache-is-authoritative? (const #t))
+ (find-packages-by-name "guile"))))))
+
+(test-equal "find-packages-by-name + version, with cache"
+ (find-packages-by-name "guile" "2")
+ (call-with-temporary-directory
+ (lambda (cache)
+ (generate-package-cache cache)
+ (mock ((guix describe) current-profile (const cache))
+ (mock ((gnu packages) cache-is-authoritative? (const #t))
+ (find-packages-by-name "guile" "2"))))))
+
(test-assert "--search-paths with pattern"
;; Make sure 'guix package --search-paths' correctly reports environment
;; variables when file patterns are used (in particular, it must follow
(lambda (key . args)
key)))
+(test-equal "specification->package+output"
+ `((,coreutils "out") (,coreutils "debug"))
+ (list (call-with-values (lambda ()
+ (specification->package+output "coreutils"))
+ list)
+ (call-with-values (lambda ()
+ (specification->package+output "coreutils:debug"))
+ list)))
+
+(test-equal "specification->package+output invalid output"
+ 'error
+ (catch 'quit
+ (lambda ()
+ (specification->package+output "coreutils:does-not-exist"))
+ (lambda _
+ 'error)))
+
+(test-equal "specification->package+output no default output"
+ `(,coreutils #f)
+ (call-with-values
+ (lambda ()
+ (specification->package+output "coreutils" #f))
+ list))
+
+(test-equal "specification->package+output invalid output, no default"
+ 'error
+ (catch 'quit
+ (lambda ()
+ (specification->package+output "coreutils:does-not-exist" #f))
+ (lambda _
+ 'error)))
+
+(test-equal "find-package-locations"
+ (map (lambda (package)
+ (cons (package-version package)
+ (package-location package)))
+ (find-packages-by-name "guile"))
+ (find-package-locations "guile"))
+
+(test-equal "find-package-locations with cache"
+ (map (lambda (package)
+ (cons (package-version package)
+ (package-location package)))
+ (find-packages-by-name "guile"))
+ (call-with-temporary-directory
+ (lambda (cache)
+ (generate-package-cache cache)
+ (mock ((guix describe) current-profile (const cache))
+ (mock ((gnu packages) cache-is-authoritative? (const #t))
+ (find-package-locations "guile"))))))
+
+(test-equal "specification->location"
+ (package-location (specification->package "guile@2"))
+ (specification->location "guile@2"))
+
(test-end "packages")
;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
+;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1)
;;; End: