;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 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.
;;;
#:use-module (guix tests)
#:use-module (guix store)
#: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.
#: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)
(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")
(test-assert "printer with location"
- (string-match "^#<package foo-0 foo.scm:42 [[:xdigit:]]+>$"
+ (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
(with-output-to-string
(lambda ()
(write
(location (make-location "foo.scm" 42 7))))))))
(test-assert "printer without location"
- (string-match "^#<package foo-0 [[:xdigit:]]+>$"
+ (string-match "^#<package foo@0 [[:xdigit:]]+>$"
(with-output-to-string
(lambda ()
(write
(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
(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
`("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"
(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* (url hash-algo hash
(chmod "." #o777)
(symlink "guile" "guile-rocks")
(copy-recursively "../share/guile/2.0/scripts"
- "scripts"))))))
+ "scripts")
+
+ ;; Make sure '.file_list' can be created.
+ (chmod ".." #o777))))))
(package (package (inherit (dummy-package "with-snippet"))
(source source)
(build-system trivial-build-system)
(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")))
(package-cross-derivation %store p "mips64el-linux-gnu")
#f)))
-(test-equal "package-derivation, direct graft"
- (package-derivation %store gnu-make)
- (let ((p (package (inherit coreutils)
- (replacement gnu-make))))
- (package-derivation %store p)))
+;; 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-cross-derivation, direct graft"
- (package-cross-derivation %store gnu-make "mips64el-linux-gnu")
- (let ((p (package (inherit coreutils)
- (replacement gnu-make))))
- (package-cross-derivation %store p "mips64el-linux-gnu")))
+;; (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))
(inputs `(("dep" ,dep*)))))
(target "mips64el-linux-gnu"))
- (equal? (package-grafts %store dummy #:target target)
- (list (graft
- (origin (package-cross-derivation %store dep target))
- (replacement
- (package-cross-derivation %store new target)))))))
+ ;; 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"
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
-(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 "dummy-0"
- (package-derivation %store dummy #:graft? #f)
- (package-grafts %store dummy)
+(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)))))))
- ;; Use the same Guile as 'package-derivation'.
- #:guile guile))))
+;;; 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))
(dummy (dummy-package "dummy"
(inputs `(("prop" ,prop)))))
(inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
- (match (assoc "prop/dep" inputs)
- (("prop/dep" package)
+ (match (assoc "dep" inputs)
+ (("dep" package)
(eq? package dep)))))
(test-assert "bag->derivation"
(profile-derivation
(manifest (map package->manifest-entry
(list p1 p2)))
- #:info-dir? #f
- #:ghc-package-cache? #f
- #:ca-certificate-bundle? #f)
+ #: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"
(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