;;; 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.
;;;
#:renamer (lambda (name)
(cond ((eq? name 'location) 'make-location)
(else name))))
- #:use-module (guix hash)
+ #:use-module (gcrypt hash)
#: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)
(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 "does-not-exist"))
- (not (supported-package? p "i686-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")
+ (supported-package? p "armhf-linux"))))
(test-skip (if (not %store) 8 0))
(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)))
(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")
+ ())
+ (let ((p1 (dummy-package "pi"
+ (source (dummy-origin
+ (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
+ (p2 (dummy-package "pi"
+ (source (dummy-origin
+ (patches (list
+ "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
+ (p3 (dummy-package "pi" (source (dummy-origin)))))
+ (map package-patched-vulnerabilities
+ (list p1 p2 p3))))
+
(test-eq "fold-packages" hello
(fold-packages (lambda (p r)
(if (string=? (package-name p) "hello")
((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))
+ '()))))))
+
+ (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:
HCoop / jackhill / guix / guix.git / blobdiff