;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (test-packages)
#:use-module (guix tests)
#:use-module (guix store)
- #:use-module (guix utils)
+ #:use-module (guix monads)
+ #:use-module (guix grafts)
+ #:use-module ((guix utils)
+ ;; 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 (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix grafts)
+ #:use-module (guix search-paths)
#:use-module (guix build-system)
#:use-module (guix build-system trivial)
#:use-module (guix build-system gnu)
+ #:use-module (guix profiles)
+ #:use-module (guix scripts package)
#:use-module (gnu packages)
#:use-module (gnu packages base)
+ #:use-module (gnu packages guile)
#:use-module (gnu packages bootstrap)
- #:use-module (srfi srfi-11)
+ #:use-module (gnu packages xml)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports)
+ #:use-module (ice-9 regex)
#:use-module (ice-9 match))
;; Test the high-level packaging layer.
(define %store
(open-connection-for-tests))
+;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
+;; can trigger builds early.)
+(%graft? #f)
\f
(test-begin "packages")
-(define-syntax-rule (dummy-package name* extra-fields ...)
- (package (name name*) (version "0") (source #f)
- (build-system gnu-build-system)
- (synopsis #f) (description #f)
- (home-page #f) (license #f)
- extra-fields ...))
+(test-assert "printer with location"
+ (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
+ (with-output-to-string
+ (lambda ()
+ (write
+ (dummy-package "foo"
+ (location (make-location "foo.scm" 42 7))))))))
+
+(test-assert "printer without location"
+ (string-match "^#<package foo@0 [[:xdigit:]]+>$"
+ (with-output-to-string
+ (lambda ()
+ (write
+ (dummy-package "foo" (location #f)))))))
(test-assert "package-field-location"
(let ()
(equal? `(("a" ,a)) (package-transitive-inputs c))
(equal? (package-propagated-inputs d)
(package-transitive-inputs d))
- (equal? `(("b" ,b) ("b/a" ,a) ("c" ,c)
- ("d" ,d) ("d/x" "something.drv"))
+ (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
+ ("a" ,a) ("x" "something.drv"))
(pk 'x (package-transitive-inputs e))))))
+(test-assert "package-transitive-inputs, no duplicates"
+ (let* ((a (dummy-package "a"))
+ (b (dummy-package "b"
+ (inputs `(("a+" ,a)))
+ (native-inputs `(("a*" ,a)))
+ (propagated-inputs `(("a" ,a)))))
+ (c (dummy-package "c"
+ (propagated-inputs `(("b" ,b)))))
+ (d (dummy-package "d"
+ (inputs `(("a" ,a) ("c" ,c)))))
+ (e (dummy-package "e"
+ (inputs `(("b" ,b) ("c" ,c))))))
+ (and (null? (package-transitive-inputs a))
+ (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a)) ;here duplicates are kept
+ (package-transitive-inputs b))
+ (equal? `(("b" ,b) ("a" ,a))
+ (package-transitive-inputs c))
+ (equal? `(("a" ,a) ("c" ,c) ("b" ,b)) ;duplicate A removed
+ (package-transitive-inputs d))
+ (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
+ (package-transitive-inputs e))))) ;ditto
+
+(test-equal "package-transitive-supported-systems"
+ '(("x" "y" "z") ;a
+ ("x" "y") ;b
+ ("y") ;c
+ ("y") ;d
+ ("y")) ;e
+ ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
+ ;; doesn't restrict the set of supported systems.
+ (let* ((a (dummy-package "a"
+ (build-system trivial-build-system)
+ (supported-systems '("x" "y" "z"))))
+ (b (dummy-package "b"
+ (build-system trivial-build-system)
+ (supported-systems '("x" "y"))
+ (inputs `(("a" ,a)))))
+ (c (dummy-package "c"
+ (build-system trivial-build-system)
+ (supported-systems '("y" "z"))
+ (inputs `(("b" ,b)))))
+ (d (dummy-package "d"
+ (build-system trivial-build-system)
+ (supported-systems '("x" "y" "z"))
+ (inputs `(("b" ,b) ("c" ,c)))))
+ (e (dummy-package "e"
+ (build-system trivial-build-system)
+ (supported-systems '("x" "y" "z"))
+ (inputs `(("d" ,d))))))
+ (list (package-transitive-supported-systems a)
+ (package-transitive-supported-systems b)
+ (package-transitive-supported-systems c)
+ (package-transitive-supported-systems d)
+ (package-transitive-supported-systems e))))
+
+(test-equal "origin-actual-file-name"
+ "foo-1.tar.gz"
+ (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
+ (origin-actual-file-name o)))
+
+(test-equal "origin-actual-file-name, file-name"
+ "foo-1.tar.gz"
+ (let ((o (dummy-origin
+ (uri "http://www.example.com/tarball")
+ (file-name "foo-1.tar.gz"))))
+ (origin-actual-file-name o)))
+
+(let* ((o (dummy-origin))
+ (u (dummy-origin))
+ (i (dummy-origin))
+ (a (dummy-package "a"))
+ (b (dummy-package "b"
+ (inputs `(("a" ,a) ("i" ,i)))))
+ (c (package (inherit b) (source o)))
+ (d (dummy-package "d"
+ (build-system trivial-build-system)
+ (source u) (inputs `(("c" ,c))))))
+ (test-assert "package-direct-sources, no source"
+ (null? (package-direct-sources a)))
+ (test-equal "package-direct-sources, #f source"
+ (list i)
+ (package-direct-sources b))
+ (test-equal "package-direct-sources, not input source"
+ (list u)
+ (package-direct-sources d))
+ (test-assert "package-direct-sources"
+ (let ((s (package-direct-sources c)))
+ (and (= (length (pk 's-sources s)) 2)
+ (member o s)
+ (member i s))))
+ (test-assert "package-transitive-sources"
+ (let ((s (package-transitive-sources d)))
+ (and (= (length (pk 'd-sources s)) 3)
+ (member o s)
+ (member i s)
+ (member u s)))))
+
+(test-assert "transitive-input-references"
+ (let* ((a (dummy-package "a"))
+ (b (dummy-package "b"))
+ (c (dummy-package "c"
+ (inputs `(("a" ,a)))
+ (propagated-inputs `(("boo" ,b)))))
+ (d (dummy-package "d"
+ (inputs `(("c*" ,c)))))
+ (keys (map (match-lambda
+ (('assoc-ref 'l key)
+ key))
+ (pk 'refs (transitive-input-references
+ 'l (package-inputs d))))))
+ (and (= (length keys) 2)
+ (member "c*" keys)
+ (member "boo" keys))))
+
+(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)))))
+ (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")))))
+ (and (supported-package? p "x86_64-linux")
+ (not (supported-package? p "does-not-exist"))
+ (not (supported-package? p "i686-linux")))))
+
(test-skip (if (not %store) 8 0))
(test-assert "package-source-derivation, file"
(and (direct-store-path? source)
(string-suffix? "utils.scm" source))))
-(unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
- (test-skip 1))
+(unless (network-reachable?) (test-skip 1))
(test-equal "package-source-derivation, snippet"
"OK"
- (let* ((file (search-bootstrap-binary "guile-2.0.9.tar.xz"
+ (let* ((file (search-bootstrap-binary (match (%current-system)
+ ("armhf-linux"
+ "guile-2.0.11.tar.xz")
+ (_
+ "guile-2.0.9.tar.xz"))
(%current-system)))
(sha256 (call-with-input-file file port-sha256))
- (fetch (lambda* (store url hash-algo hash
+ (fetch (lambda* (url hash-algo hash
#:optional name #:key system)
(pk 'fetch url hash-algo hash name system)
- (add-to-store store (basename url) #f "sha256" url)))
+ (interned-file url)))
(source (bootstrap-origin
(origin
(method fetch)
(copy-recursively "../share/guile/2.0/scripts"
"scripts")
- ;; These variables must exist.
- (pk %build-inputs %outputs))))))
+ ;; Make sure '.file_list' can be created.
+ (chmod ".." #o777))))))
(package (package (inherit (dummy-package "with-snippet"))
(source source)
(build-system trivial-build-system)
(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"))))
+ (let ((p (package
+ (inherit (dummy-package "p"))
+ (source (origin
+ (method (const #f))
+ (uri "http://whatever")
+ (patches
+ (list (search-patch "does-not-exist.patch")))
+ (sha256
+ (base32
+ "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
+ (package-derivation %store p)
+ #f)))
+
+(test-assert "reference to non-existent output"
+ ;; See <http://bugs.gnu.org/19630>.
+ (parameterize ((%graft? #f))
+ (let* ((dep (dummy-package "dep"))
+ (p (dummy-package "p"
+ (inputs `(("dep" ,dep "non-existent"))))))
+ (guard (c ((derivation-missing-output-error? c)
+ (and (string=? (derivation-missing-output c) "non-existent")
+ (equal? (package-derivation %store dep)
+ (derivation-error-derivation c)))))
+ (package-derivation %store p)))))
+
(test-assert "trivial"
(let* ((p (package (inherit (dummy-package "trivial"))
(build-system trivial-build-system)
(test-assert "search paths"
(let* ((p (make-prompt-tag "return-search-paths"))
(s (build-system
- (name "raw")
+ (name 'raw)
(description "Raw build system with direct store access")
- (build (lambda* (store name source inputs
- #:key outputs system search-paths)
- search-paths))))
+ (lower (lambda* (name #:key source inputs system target
+ #:allow-other-keys)
+ (bag
+ (name name)
+ (system system) (target target)
+ (build-inputs inputs)
+ (build
+ (lambda* (store name inputs
+ #:key outputs system search-paths)
+ search-paths)))))))
(x (list (search-path-specification
(variable "GUILE_LOAD_PATH")
- (directories '("share/guile/site/2.0")))
+ (files '("share/guile/site/2.0")))
(search-path-specification
(variable "GUILE_LOAD_COMPILED_PATH")
- (directories '("share/guile/site/2.0")))))
+ (files '("share/guile/site/2.0")))))
(a (package (inherit (dummy-package "guile"))
(build-system s)
(native-search-paths x)))
(equal? x (collect (package-derivation %store b)))
(equal? x (collect (package-derivation %store c)))))))
+(test-assert "package-transitive-native-search-paths"
+ (let* ((sp (lambda (name)
+ (list (search-path-specification
+ (variable name)
+ (files '("foo/bar"))))))
+ (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
+ (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
+ (p2 (dummy-package "p2"
+ (native-search-paths (sp "PATH2"))
+ (inputs `(("p0" ,p0)))
+ (propagated-inputs `(("p1" ,p1)))))
+ (p3 (dummy-package "p3"
+ (native-search-paths (sp "PATH3"))
+ (native-inputs `(("p0" ,p0)))
+ (propagated-inputs `(("p2" ,p2))))))
+ (lset= string=?
+ '("PATH1" "PATH2" "PATH3")
+ (map search-path-specification-variable
+ (package-transitive-native-search-paths p3)))))
+
(test-assert "package-cross-derivation"
(let ((drv (package-cross-derivation %store (dummy-package "p")
"mips64el-linux-gnu")))
(test-assert "package-cross-derivation, no cross builder"
(let* ((b (build-system (inherit trivial-build-system)
- (cross-build #f)))
+ (lower (const #f))))
(p (package (inherit (dummy-package "p"))
(build-system b))))
(guard (c ((package-cross-build-system-error? c)
(package-cross-derivation %store p "mips64el-linux-gnu")
#f)))
-(unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
+;; XXX: The next two tests can trigger builds when the distro defines
+;; replacements on core packages, so they're disable for lack of a better
+;; solution.
+
+;; (test-equal "package-derivation, direct graft"
+;; (package-derivation %store gnu-make #:graft? #f)
+;; (let ((p (package (inherit coreutils)
+;; (replacement gnu-make))))
+;; (package-derivation %store p #:graft? #t)))
+
+;; (test-equal "package-cross-derivation, direct graft"
+;; (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
+;; #:graft? #f)
+;; (let ((p (package (inherit coreutils)
+;; (replacement gnu-make))))
+;; (package-cross-derivation %store p "mips64el-linux-gnu"
+;; #:graft? #t)))
+
+(test-assert "package-grafts, indirect grafts"
+ (let* ((new (dummy-package "dep"
+ (arguments '(#:implicit-inputs? #f))))
+ (dep (package (inherit new) (version "0.0")))
+ (dep* (package (inherit dep) (replacement new)))
+ (dummy (dummy-package "dummy"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("dep" ,dep*))))))
+ (equal? (package-grafts %store dummy)
+ (list (graft
+ (origin (package-derivation %store dep))
+ (replacement (package-derivation %store new)))))))
+
+(test-assert "package-grafts, indirect grafts, cross"
+ (let* ((new (dummy-package "dep"
+ (arguments '(#:implicit-inputs? #f))))
+ (dep (package (inherit new) (version "0.0")))
+ (dep* (package (inherit dep) (replacement new)))
+ (dummy (dummy-package "dummy"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("dep" ,dep*)))))
+ (target "mips64el-linux-gnu"))
+ ;; XXX: There might be additional grafts, for instance if the distro
+ ;; defines replacements for core packages like Perl.
+ (member (graft
+ (origin (package-cross-derivation %store dep target))
+ (replacement
+ (package-cross-derivation %store new target)))
+ (package-grafts %store dummy #:target target))))
+
+(test-assert "package-grafts, indirect grafts, propagated inputs"
+ (let* ((new (dummy-package "dep"
+ (arguments '(#:implicit-inputs? #f))))
+ (dep (package (inherit new) (version "0.0")))
+ (dep* (package (inherit dep) (replacement new)))
+ (prop (dummy-package "propagated"
+ (propagated-inputs `(("dep" ,dep*)))
+ (arguments '(#:implicit-inputs? #f))))
+ (dummy (dummy-package "dummy"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("prop" ,prop))))))
+ (equal? (package-grafts %store dummy)
+ (list (graft
+ (origin (package-derivation %store dep))
+ (replacement (package-derivation %store new)))))))
+
+(test-assert "package-grafts, same replacement twice"
+ (let* ((new (dummy-package "dep"
+ (version "1")
+ (arguments '(#:implicit-inputs? #f))))
+ (dep (package (inherit new) (version "0") (replacement new)))
+ (p1 (dummy-package "intermediate1"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("dep" ,dep)))))
+ (p2 (dummy-package "intermediate2"
+ (arguments '(#:implicit-inputs? #f))
+ ;; Here we copy DEP to have an equivalent package that is not
+ ;; 'eq?' to DEP. This is similar to what happens with
+ ;; 'package-with-explicit-inputs' & co.
+ (inputs `(("dep" ,(package (inherit dep)))))))
+ (p3 (dummy-package "final"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("p1" ,p1) ("p2" ,p2))))))
+ (equal? (package-grafts %store p3)
+ (list (graft
+ (origin (package-derivation %store
+ (package (inherit dep)
+ (replacement #f))))
+ (replacement (package-derivation %store new)))))))
+
+;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
+;;; find out about their run-time dependencies, so this test is no longer
+;;; applicable since it would trigger a full rebuild.
+;;
+;; (test-assert "package-derivation, indirect grafts"
+;; (let* ((new (dummy-package "dep"
+;; (arguments '(#:implicit-inputs? #f))))
+;; (dep (package (inherit new) (version "0.0")))
+;; (dep* (package (inherit dep) (replacement new)))
+;; (dummy (dummy-package "dummy"
+;; (arguments '(#:implicit-inputs? #f))
+;; (inputs `(("dep" ,dep*)))))
+;; (guile (package-derivation %store (canonical-package guile-2.0)
+;; #:graft? #f)))
+;; (equal? (package-derivation %store dummy)
+;; (graft-derivation %store
+;; (package-derivation %store dummy #:graft? #f)
+;; (package-grafts %store dummy)
+
+;; ;; Use the same Guile as 'package-derivation'.
+;; #:guile guile))))
+
+(test-equal "package->bag"
+ `("foo86-hurd" #f (,(package-source gnu-make))
+ (,(canonical-package glibc)) (,(canonical-package coreutils)))
+ (let ((bag (package->bag gnu-make "foo86-hurd")))
+ (list (bag-system bag) (bag-target bag)
+ (assoc-ref (bag-build-inputs bag) "source")
+ (assoc-ref (bag-build-inputs bag) "libc")
+ (assoc-ref (bag-build-inputs bag) "coreutils"))))
+
+(test-equal "package->bag, cross-compilation"
+ `(,(%current-system) "foo86-hurd"
+ (,(package-source gnu-make))
+ (,(canonical-package glibc)) (,(canonical-package coreutils)))
+ (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
+ (list (bag-system bag) (bag-target bag)
+ (assoc-ref (bag-build-inputs bag) "source")
+ (assoc-ref (bag-build-inputs bag) "libc")
+ (assoc-ref (bag-build-inputs bag) "coreutils"))))
+
+(test-assert "package->bag, propagated inputs"
+ (let* ((dep (dummy-package "dep"))
+ (prop (dummy-package "prop"
+ (propagated-inputs `(("dep" ,dep)))))
+ (dummy (dummy-package "dummy"
+ (inputs `(("prop" ,prop)))))
+ (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
+ (match (assoc "dep" inputs)
+ (("dep" package)
+ (eq? package dep)))))
+
+(test-assert "bag->derivation"
+ (parameterize ((%graft? #f))
+ (let ((bag (package->bag gnu-make))
+ (drv (package-derivation %store gnu-make)))
+ (parameterize ((%current-system "foox86-hurd")) ;should have no effect
+ (equal? drv (bag->derivation %store bag))))))
+
+(test-assert "bag->derivation, cross-compilation"
+ (parameterize ((%graft? #f))
+ (let* ((target "mips64el-linux-gnu")
+ (bag (package->bag gnu-make (%current-system) target))
+ (drv (package-cross-derivation %store gnu-make target)))
+ (parameterize ((%current-system "foox86-hurd") ;should have no effect
+ (%current-target-system "foo64-linux-gnu"))
+ (equal? drv (bag->derivation %store bag))))))
+
+(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 base) gnu-make-boot0)))
+ (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0)))
(and (package? gnu-make)
(or (location? (package-location gnu-make))
(not (package-location gnu-make)))
(((? (cut eq? hello <>))) #t)
(wrong (pk 'find-packages-by-name wrong #f))))
+(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
+ ;; symlinks when looking for 'catalog.xml'.) To do that, we rely on the
+ ;; libxml2 package specification, which contains such a definition.
+ (let* ((p1 (package
+ (name "foo") (version "0") (source #f)
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:modules ((guix build utils))
+ #:builder (begin
+ (use-modules (guix build utils))
+ (let ((out (assoc-ref %outputs "out")))
+ (mkdir-p (string-append out "/xml/bar/baz"))
+ (call-with-output-file
+ (string-append out "/xml/bar/baz/catalog.xml")
+ (lambda (port)
+ (display "xml? wat?!" port)))))))
+ (synopsis #f) (description #f)
+ (home-page #f) (license #f)))
+ (p2 (package
+ ;; Provide a fake libxml2 to avoid building the real one. This
+ ;; is OK because 'guix package' gets search path specifications
+ ;; from the same-named package found in the distro.
+ (name "libxml2") (version "0.0.0") (source #f)
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (mkdir (assoc-ref %outputs "out"))))
+ (native-search-paths (package-native-search-paths libxml2))
+ (synopsis #f) (description #f)
+ (home-page #f) (license #f)))
+ (prof (run-with-store %store
+ (profile-derivation
+ (manifest (map package->manifest-entry
+ (list p1 p2)))
+ #:hooks '())
+ #:guile-for-build (%guile-for-build))))
+ (build-derivations %store (list prof))
+ (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
+ (derivation->output-path prof))
+ (with-output-to-string
+ (lambda ()
+ (guix-package "-p" (derivation->output-path prof)
+ "--search-paths"))))))
+
+(test-equal "specification->package when not found"
+ 'quit
+ (catch 'quit
+ (lambda ()
+ ;; This should call 'leave', producing an error message.
+ (specification->package "this-package-does-not-exist"))
+ (lambda (key . args)
+ key)))
+
(test-end "packages")
\f
HCoop / jackhill / guix / guix.git / blobdiff