tests/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-packages)
  21   #:use-module (guix tests)
  22   #:use-module (guix store)
  23   #:use-module (guix monads)
  24   #:use-module (guix grafts)
  25   #:use-module ((guix gexp) #:select (local-file local-file-file))
  26   #:use-module ((guix utils)
  27                 ;; Rename the 'location' binding to allow proper syntax
  28                 ;; matching when setting the 'location' field of a package.
  29                 #:renamer (lambda (name)
  30                             (cond ((eq? name 'location) 'make-location)
  31                                   (else name))))
  32   #:use-module (gcrypt hash)
  33   #:use-module (guix derivations)
  34   #:use-module (guix packages)
  35   #:use-module (guix grafts)
  36   #:use-module (guix search-paths)
  37   #:use-module (guix build-system)
  38   #:use-module (guix build-system trivial)
  39   #:use-module (guix build-system gnu)
  40   #:use-module (guix memoization)
  41   #:use-module (guix profiles)
  42   #:use-module (guix scripts package)
  43   #:use-module (gnu packages)
  44   #:use-module (gnu packages base)
  45   #:use-module (gnu packages guile)
  46   #:use-module (gnu packages bootstrap)
  47   #:use-module (gnu packages version-control)
  48   #:use-module (gnu packages xml)
  49   #:use-module (srfi srfi-1)
  50   #:use-module (srfi srfi-26)
  51   #:use-module (srfi srfi-34)
  52   #:use-module (srfi srfi-35)
  53   #:use-module (srfi srfi-64)
  54   #:use-module (rnrs io ports)
  55   #:use-module (ice-9 vlist)
  56   #:use-module (ice-9 regex)
  57   #:use-module (ice-9 match))
  58
  59 ;; Test the high-level packaging layer.
  60
  61 (define %store
  62   (open-connection-for-tests))
  63
  64 ;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
  65 ;; can trigger builds early.)
  66 (%graft? #f)
  67
  68 \f
  69 (test-begin "packages")
  70
  71 (test-assert "printer with location"
  72   (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
  73                 (with-output-to-string
  74                   (lambda ()
  75                     (write
  76                      (dummy-package "foo"
  77                        (location (make-location "foo.scm" 42 7))))))))
  78
  79 (test-assert "printer without location"
  80   (string-match "^#<package foo@0 [[:xdigit:]]+>$"
  81                 (with-output-to-string
  82                   (lambda ()
  83                     (write
  84                      (dummy-package "foo" (location #f)))))))
  85
  86 (test-assert "hidden-package"
  87   (and (hidden-package? (hidden-package (dummy-package "foo")))
  88        (not (hidden-package? (dummy-package "foo")))))
  89
  90 (test-assert "package-superseded"
  91   (let* ((new (dummy-package "bar"))
  92          (old (deprecated-package "foo" new)))
  93     (and (eq? (package-superseded old) new)
  94          (mock ((gnu packages) find-best-packages-by-name (const (list old)))
  95                (specification->package "foo")
  96                (and (eq? new (specification->package "foo"))
  97                     (eq? new (specification->package+output "foo")))))))
  98
  99 (test-assert "transaction-upgrade-entry, zero upgrades"
 100   (let* ((old (dummy-package "foo" (version "1")))
 101          (tx  (mock ((gnu packages) find-best-packages-by-name
 102                      (const '()))
 103                     ((@@ (guix scripts package) transaction-upgrade-entry)
 104                      (manifest-entry
 105                        (inherit (package->manifest-entry old))
 106                        (item (string-append (%store-prefix) "/"
 107                                             (make-string 32 #\e) "-foo-1")))
 108                      (manifest-transaction)))))
 109     (manifest-transaction-null? tx)))
 110
 111 (test-assert "transaction-upgrade-entry, one upgrade"
 112   (let* ((old (dummy-package "foo" (version "1")))
 113          (new (dummy-package "foo" (version "2")))
 114          (tx  (mock ((gnu packages) find-best-packages-by-name
 115                      (const (list new)))
 116                     ((@@ (guix scripts package) transaction-upgrade-entry)
 117                      (manifest-entry
 118                        (inherit (package->manifest-entry old))
 119                        (item (string-append (%store-prefix) "/"
 120                                             (make-string 32 #\e) "-foo-1")))
 121                      (manifest-transaction)))))
 122     (and (match (manifest-transaction-install tx)
 123            ((($ <manifest-entry> "foo" "2" "out" item))
 124             (eq? item new)))
 125          (null? (manifest-transaction-remove tx)))))
 126
 127 (test-assert "transaction-upgrade-entry, superseded package"
 128   (let* ((old (dummy-package "foo" (version "1")))
 129          (new (dummy-package "bar" (version "2")))
 130          (dep (deprecated-package "foo" new))
 131          (tx  (mock ((gnu packages) find-best-packages-by-name
 132                      (const (list dep)))
 133                     ((@@ (guix scripts package) transaction-upgrade-entry)
 134                      (manifest-entry
 135                        (inherit (package->manifest-entry old))
 136                        (item (string-append (%store-prefix) "/"
 137                                             (make-string 32 #\e) "-foo-1")))
 138                      (manifest-transaction)))))
 139     (and (match (manifest-transaction-install tx)
 140            ((($ <manifest-entry> "bar" "2" "out" item))
 141             (eq? item new)))
 142          (match (manifest-transaction-remove tx)
 143            (((? manifest-pattern? pattern))
 144             (and (string=? (manifest-pattern-name pattern) "foo")
 145                  (string=? (manifest-pattern-version pattern) "1")
 146                  (string=? (manifest-pattern-output pattern) "out")))))))
 147
 148 (test-assert "package-field-location"
 149   (let ()
 150     (define (goto port line column)
 151       (unless (and (= (port-column port) (- column 1))
 152                    (= (port-line port) (- line 1)))
 153         (unless (eof-object? (get-char port))
 154           (goto port line column))))
 155
 156     (define read-at
 157       (match-lambda
 158        (($ <location> file line column)
 159         (call-with-input-file (search-path %load-path file)
 160           (lambda (port)
 161             (goto port line column)
 162             (read port))))))
 163
 164     ;; Until Guile 2.0.6 included, source properties were added only to pairs.
 165     ;; Thus, check against both VALUE and (FIELD VALUE).
 166     (and (member (read-at (package-field-location %bootstrap-guile 'name))
 167                  (let ((name (package-name %bootstrap-guile)))
 168                    (list name `(name ,name))))
 169          (member (read-at (package-field-location %bootstrap-guile 'version))
 170                  (let ((version (package-version %bootstrap-guile)))
 171                    (list version `(version ,version))))
 172          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 173
 174 ;; Make sure we don't change the file name to an absolute file name.
 175 (test-equal "package-field-location, relative file name"
 176   (location-file (package-location %bootstrap-guile))
 177   (with-fluids ((%file-port-name-canonicalization 'absolute))
 178     (location-file (package-field-location %bootstrap-guile 'version))))
 179
 180 (test-assert "package-transitive-inputs"
 181   (let* ((a (dummy-package "a"))
 182          (b (dummy-package "b"
 183               (propagated-inputs `(("a" ,a)))))
 184          (c (dummy-package "c"
 185               (inputs `(("a" ,a)))))
 186          (d (dummy-package "d"
 187               (propagated-inputs `(("x" "something.drv")))))
 188          (e (dummy-package "e"
 189               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
 190     (and (null? (package-transitive-inputs a))
 191          (equal? `(("a" ,a)) (package-transitive-inputs b))
 192          (equal? `(("a" ,a)) (package-transitive-inputs c))
 193          (equal? (package-propagated-inputs d)
 194                  (package-transitive-inputs d))
 195          (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
 196                    ("a" ,a) ("x" "something.drv"))
 197                  (pk 'x (package-transitive-inputs e))))))
 198
 199 (test-assert "package-transitive-inputs, no duplicates"
 200   (let* ((a (dummy-package "a"))
 201          (b (dummy-package "b"
 202               (inputs `(("a+" ,a)))
 203               (native-inputs `(("a*" ,a)))
 204               (propagated-inputs `(("a" ,a)))))
 205          (c (dummy-package "c"
 206               (propagated-inputs `(("b" ,b)))))
 207          (d (dummy-package "d"
 208               (inputs `(("a" ,a) ("c" ,c)))))
 209          (e (dummy-package "e"
 210               (inputs `(("b" ,b) ("c" ,c))))))
 211     (and (null? (package-transitive-inputs a))
 212          (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a))   ;here duplicates are kept
 213                  (package-transitive-inputs b))
 214          (equal? `(("b" ,b) ("a" ,a))
 215                  (package-transitive-inputs c))
 216          (equal? `(("a" ,a) ("c" ,c) ("b" ,b))     ;duplicate A removed
 217                  (package-transitive-inputs d))
 218          (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
 219                  (package-transitive-inputs e))))) ;ditto
 220
 221 (test-equal "package-transitive-supported-systems"
 222   '(("x" "y" "z")                                 ;a
 223     ("x" "y")                                     ;b
 224     ("y")                                         ;c
 225     ("y")                                         ;d
 226     ("y"))                                        ;e
 227   ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
 228   ;; doesn't restrict the set of supported systems.
 229   (let* ((a (dummy-package "a"
 230               (build-system trivial-build-system)
 231               (supported-systems '("x" "y" "z"))))
 232          (b (dummy-package "b"
 233               (build-system trivial-build-system)
 234               (supported-systems '("x" "y"))
 235               (inputs `(("a" ,a)))))
 236          (c (dummy-package "c"
 237               (build-system trivial-build-system)
 238               (supported-systems '("y" "z"))
 239               (inputs `(("b" ,b)))))
 240          (d (dummy-package "d"
 241               (build-system trivial-build-system)
 242               (supported-systems '("x" "y" "z"))
 243               (inputs `(("b" ,b) ("c" ,c)))))
 244          (e (dummy-package "e"
 245               (build-system trivial-build-system)
 246               (supported-systems '("x" "y" "z"))
 247               (inputs `(("d" ,d))))))
 248     (list (package-transitive-supported-systems a)
 249           (package-transitive-supported-systems b)
 250           (package-transitive-supported-systems c)
 251           (package-transitive-supported-systems d)
 252           (package-transitive-supported-systems e))))
 253
 254 (test-assert "package-closure"
 255   (let-syntax ((dummy-package/no-implicit
 256                 (syntax-rules ()
 257                   ((_ name rest ...)
 258                    (package
 259                      (inherit (dummy-package name rest ...))
 260                      (build-system trivial-build-system))))))
 261     (let* ((a (dummy-package/no-implicit "a"))
 262            (b (dummy-package/no-implicit "b"
 263                 (propagated-inputs `(("a" ,a)))))
 264            (c (dummy-package/no-implicit "c"
 265                 (inputs `(("a" ,a)))))
 266            (d (dummy-package/no-implicit "d"
 267                 (native-inputs `(("b" ,b)))))
 268            (e (dummy-package/no-implicit "e"
 269                 (inputs `(("c" ,c) ("d" ,d))))))
 270       (lset= eq?
 271              (list a b c d e)
 272              (package-closure (list e))
 273              (package-closure (list e d))
 274              (package-closure (list e c b))))))
 275
 276 (test-equal "origin-actual-file-name"
 277   "foo-1.tar.gz"
 278   (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
 279     (origin-actual-file-name o)))
 280
 281 (test-equal "origin-actual-file-name, file-name"
 282   "foo-1.tar.gz"
 283   (let ((o (dummy-origin
 284             (uri "http://www.example.com/tarball")
 285             (file-name "foo-1.tar.gz"))))
 286     (origin-actual-file-name o)))
 287
 288 (let* ((o (dummy-origin))
 289        (u (dummy-origin))
 290        (i (dummy-origin))
 291        (a (dummy-package "a"))
 292        (b (dummy-package "b"
 293             (inputs `(("a" ,a) ("i" ,i)))))
 294        (c (package (inherit b) (source o)))
 295        (d (dummy-package "d"
 296             (build-system trivial-build-system)
 297             (source u) (inputs `(("c" ,c))))))
 298   (test-assert "package-direct-sources, no source"
 299     (null? (package-direct-sources a)))
 300   (test-equal "package-direct-sources, #f source"
 301     (list i)
 302     (package-direct-sources b))
 303   (test-equal "package-direct-sources, not input source"
 304     (list u)
 305     (package-direct-sources d))
 306   (test-assert "package-direct-sources"
 307     (let ((s (package-direct-sources c)))
 308       (and (= (length (pk 's-sources s)) 2)
 309            (member o s)
 310            (member i s))))
 311   (test-assert "package-transitive-sources"
 312     (let ((s (package-transitive-sources d)))
 313       (and (= (length (pk 'd-sources s)) 3)
 314            (member o s)
 315            (member i s)
 316            (member u s)))))
 317
 318 (test-assert "transitive-input-references"
 319   (let* ((a (dummy-package "a"))
 320          (b (dummy-package "b"))
 321          (c (dummy-package "c"
 322               (inputs `(("a" ,a)))
 323               (propagated-inputs `(("boo" ,b)))))
 324          (d (dummy-package "d"
 325               (inputs `(("c*" ,c)))))
 326          (keys (map (match-lambda
 327                       (('assoc-ref 'l key)
 328                        key))
 329                     (pk 'refs (transitive-input-references
 330                                'l (package-inputs d))))))
 331     (and (= (length keys) 2)
 332          (member "c*" keys)
 333          (member "boo" keys))))
 334
 335 (test-equal "package-transitive-supported-systems, implicit inputs"
 336   %supported-systems
 337
 338   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 339   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 340   (let ((p (dummy-package "foo"
 341                (build-system gnu-build-system)
 342                (supported-systems
 343                 `("does-not-exist" "foobar" ,@%supported-systems)))))
 344     (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture
 345       (package-transitive-supported-systems p))))
 346
 347 (test-equal "package-transitive-supported-systems: reduced binary seed, implicit inputs"
 348   '("x86_64-linux" "i686-linux")
 349
 350   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 351   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 352   (let ((p (dummy-package "foo"
 353              (build-system gnu-build-system)
 354              (supported-systems
 355               `("does-not-exist" "foobar" ,@%supported-systems)))))
 356     (parameterize ((%current-system "x86_64-linux"))
 357       (package-transitive-supported-systems p))))
 358
 359 (test-assert "supported-package?"
 360   (let* ((d (dummy-package "dep"
 361               (build-system trivial-build-system)
 362               (supported-systems '("x86_64-linux"))))
 363          (p (dummy-package "foo"
 364               (build-system gnu-build-system)
 365               (inputs `(("d" ,d)))
 366               (supported-systems '("x86_64-linux" "armhf-linux")))))
 367     (and (supported-package? p "x86_64-linux")
 368          (not (supported-package? p "i686-linux"))
 369          (not (supported-package? p "armhf-linux")))))
 370
 371 (test-assert "supported-package? vs. system-dependent graph"
 372   ;; The inputs of a package can depend on (%current-system).  Thus,
 373   ;; 'supported-package?' must make sure that it binds (%current-system)
 374   ;; appropriately before traversing the dependency graph.  In the example
 375   ;; below, 'supported-package?' must thus return true for both systems.
 376   (let* ((p0a (dummy-package "foo-arm"
 377                 (build-system trivial-build-system)
 378                 (supported-systems '("armhf-linux"))))
 379          (p0b (dummy-package "foo-x86_64"
 380                 (build-system trivial-build-system)
 381                 (supported-systems '("x86_64-linux"))))
 382          (p   (dummy-package "bar"
 383                 (build-system trivial-build-system)
 384                 (inputs
 385                  (if (string=? (%current-system) "armhf-linux")
 386                      `(("foo" ,p0a))
 387                      `(("foo" ,p0b)))))))
 388     (and (supported-package? p "x86_64-linux")
 389          (supported-package? p "armhf-linux"))))
 390
 391 (test-skip (if (not %store) 8 0))
 392
 393 (test-assert "package-source-derivation, file"
 394   (let* ((file    (search-path %load-path "guix.scm"))
 395          (package (package (inherit (dummy-package "p"))
 396                     (source file)))
 397          (source  (package-source-derivation %store
 398                                              (package-source package))))
 399     (and (store-path? source)
 400          (valid-path? %store source)
 401          (equal? (call-with-input-file source get-bytevector-all)
 402                  (call-with-input-file file get-bytevector-all)))))
 403
 404 (test-assert "package-source-derivation, store path"
 405   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 406                                 (search-path %load-path "guix.scm")))
 407          (package (package (inherit (dummy-package "p"))
 408                     (source file)))
 409          (source  (package-source-derivation %store
 410                                              (package-source package))))
 411     (string=? file source)))
 412
 413 (test-assert "package-source-derivation, indirect store path"
 414   (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
 415                                 (dirname (search-path %load-path
 416                                                       "guix/build/utils.scm"))))
 417          (package (package (inherit (dummy-package "p"))
 418                     (source (string-append dir "/utils.scm"))))
 419          (source  (package-source-derivation %store
 420                                              (package-source package))))
 421     (and (direct-store-path? source)
 422          (string-suffix? "utils.scm" source))))
 423
 424 (test-assert "package-source-derivation, local-file"
 425   (let* ((file    (local-file "../guix/base32.scm"))
 426          (package (package (inherit (dummy-package "p"))
 427                     (source file)))
 428          (source  (package-source-derivation %store
 429                                              (package-source package))))
 430     (and (store-path? source)
 431          (string-suffix? "base32.scm" source)
 432          (valid-path? %store source)
 433          (equal? (call-with-input-file source get-bytevector-all)
 434                  (call-with-input-file
 435                      (search-path %load-path "guix/base32.scm")
 436                    get-bytevector-all)))))
 437
 438 (unless (network-reachable?) (test-skip 1))
 439 (test-equal "package-source-derivation, snippet"
 440   "OK"
 441   (let* ((source (bootstrap-origin
 442                   (origin
 443                     (inherit (bootstrap-guile-origin (%current-system)))
 444                     (patch-inputs
 445                      `(("tar" ,%bootstrap-coreutils&co)
 446                        ("xz" ,%bootstrap-coreutils&co)
 447                        ("patch" ,%bootstrap-coreutils&co)))
 448                     (patch-guile %bootstrap-guile)
 449                     (modules '((guix build utils)))
 450                     (snippet '(begin
 451                                 ;; We end up in 'bin', because it's the first
 452                                 ;; directory, alphabetically.  Not a very good
 453                                 ;; example but hey.
 454                                 (chmod "." #o777)
 455                                 (symlink "guile" "guile-rocks")
 456                                 (copy-recursively "../share/guile/2.0/scripts"
 457                                                   "scripts")
 458
 459                                 ;; Make sure '.file_list' can be created.
 460                                 (chmod ".." #o777))))))
 461          (package (package (inherit (dummy-package "with-snippet"))
 462                     (source source)
 463                     (build-system trivial-build-system)
 464                     (inputs
 465                      `(("tar" ,(search-bootstrap-binary "tar"
 466                                                         (%current-system)))
 467                        ("xz"  ,(search-bootstrap-binary "xz"
 468                                                         (%current-system)))))
 469                     (arguments
 470                      `(#:guile ,%bootstrap-guile
 471                        #:modules ((guix build utils))
 472                        #:builder
 473                        (begin
 474                          (use-modules (guix build utils))
 475                          (let ((tar    (assoc-ref %build-inputs "tar"))
 476                                (xz     (assoc-ref %build-inputs "xz"))
 477                                (source (assoc-ref %build-inputs "source")))
 478                            (invoke tar "xvf" source
 479                                    "--use-compress-program" xz)
 480                            (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
 481                                         (file-exists? "bin/scripts/compile.scm"))
 482                              (error "the snippet apparently failed"))
 483                            (let ((out (assoc-ref %outputs "out")))
 484                              (call-with-output-file out
 485                                (lambda (p)
 486                                  (display "OK" p))))
 487                            #t))))))
 488          (drv    (package-derivation %store package))
 489          (out    (derivation->output-path drv)))
 490     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 491          (call-with-input-file out get-string-all))))
 492
 493 (test-assert "return value"
 494   (let ((drv (package-derivation %store (dummy-package "p"))))
 495     (and (derivation? drv)
 496          (file-exists? (derivation-file-name drv)))))
 497
 498 (test-assert "package-output"
 499   (let* ((package  (dummy-package "p"))
 500          (drv      (package-derivation %store package)))
 501     (and (derivation? drv)
 502          (string=? (derivation->output-path drv)
 503                    (package-output %store package "out")))))
 504
 505 (test-assert "patch not found yields a run-time error"
 506   (guard (c ((condition-has-type? c &message)
 507              (and (string-contains (condition-message c)
 508                                    "does-not-exist.patch")
 509                   (string-contains (condition-message c)
 510                                    "not found"))))
 511     (let ((p (package
 512                (inherit (dummy-package "p"))
 513                (source (origin
 514                          (method (const #f))
 515                          (uri "http://whatever")
 516                          (patches
 517                           (list (search-patch "does-not-exist.patch")))
 518                          (sha256
 519                           (base32
 520                            "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
 521       (package-derivation %store p)
 522       #f)))
 523
 524 (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
 525   (test-equal "&package-input-error"
 526     (list dummy (current-module))
 527     (guard (c ((package-input-error? c)
 528                (list (package-error-package c)
 529                      (package-error-invalid-input c))))
 530       (package-derivation %store dummy))))
 531
 532 (test-assert "reference to non-existent output"
 533   ;; See <http://bugs.gnu.org/19630>.
 534   (parameterize ((%graft? #f))
 535     (let* ((dep (dummy-package "dep"))
 536            (p   (dummy-package "p"
 537                   (inputs `(("dep" ,dep "non-existent"))))))
 538       (guard (c ((derivation-missing-output-error? c)
 539                  (and (string=? (derivation-missing-output c) "non-existent")
 540                       (equal? (package-derivation %store dep)
 541                               (derivation-error-derivation c)))))
 542         (package-derivation %store p)))))
 543
 544 (test-assert "trivial"
 545   (let* ((p (package (inherit (dummy-package "trivial"))
 546               (build-system trivial-build-system)
 547               (source #f)
 548               (arguments
 549                `(#:guile ,%bootstrap-guile
 550                  #:builder
 551                  (begin
 552                    (mkdir %output)
 553                    (call-with-output-file (string-append %output "/test")
 554                      (lambda (p)
 555                        (display '(hello guix) p)))
 556                    #t)))))
 557          (d (package-derivation %store p)))
 558     (and (build-derivations %store (list d))
 559          (let ((p (pk 'drv d (derivation->output-path d))))
 560            (equal? '(hello guix)
 561                    (call-with-input-file (string-append p "/test") read))))))
 562
 563 (test-assert "trivial with local file as input"
 564   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 565          (p (package (inherit (dummy-package "trivial-with-input-file"))
 566               (build-system trivial-build-system)
 567               (source #f)
 568               (arguments
 569                `(#:guile ,%bootstrap-guile
 570                  #:builder (begin
 571                              (copy-file (assoc-ref %build-inputs "input")
 572                                         %output)
 573                              #t)))
 574               (inputs `(("input" ,i)))))
 575          (d (package-derivation %store p)))
 576     (and (build-derivations %store (list d))
 577          (let ((p (pk 'drv d (derivation->output-path d))))
 578            (equal? (call-with-input-file p get-bytevector-all)
 579                    (call-with-input-file i get-bytevector-all))))))
 580
 581 (test-assert "trivial with source"
 582   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 583          (p (package (inherit (dummy-package "trivial-with-source"))
 584               (build-system trivial-build-system)
 585               (source i)
 586               (arguments
 587                `(#:guile ,%bootstrap-guile
 588                  #:builder (begin
 589                              (copy-file (assoc-ref %build-inputs "source")
 590                                         %output)
 591                              #t)))))
 592          (d (package-derivation %store p)))
 593     (and (build-derivations %store (list d))
 594          (let ((p (derivation->output-path d)))
 595            (equal? (call-with-input-file p get-bytevector-all)
 596                    (call-with-input-file i get-bytevector-all))))))
 597
 598 (test-assert "trivial with system-dependent input"
 599   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 600               (build-system trivial-build-system)
 601               (source #f)
 602               (arguments
 603                `(#:guile ,%bootstrap-guile
 604                  #:modules ((guix build utils))
 605                  #:builder
 606                  (begin
 607                    (use-modules (guix build utils))
 608                    (let ((out  (assoc-ref %outputs "out"))
 609                          (bash (assoc-ref %build-inputs "bash")))
 610                      (invoke bash "-c"
 611                              (format #f "echo hello > ~a" out))))))
 612               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 613                                                           (%current-system)))))))
 614          (d (package-derivation %store p)))
 615     (and (build-derivations %store (list d))
 616          (let ((p (pk 'drv d (derivation->output-path d))))
 617            (eq? 'hello (call-with-input-file p read))))))
 618
 619 (test-assert "trivial with #:allowed-references"
 620   (let* ((p (package
 621               (inherit (dummy-package "trivial"))
 622               (build-system trivial-build-system)
 623               (arguments
 624                `(#:guile ,%bootstrap-guile
 625                  #:allowed-references (,%bootstrap-guile)
 626                  #:builder
 627                  (begin
 628                    (mkdir %output)
 629                    ;; The reference to itself isn't allowed so building it
 630                    ;; should fail.
 631                    (symlink %output (string-append %output "/self"))
 632                    #t)))))
 633          (d (package-derivation %store p)))
 634     (guard (c ((store-protocol-error? c) #t))
 635       (build-derivations %store (list d))
 636       #f)))
 637
 638 (test-assert "search paths"
 639   (let* ((p (make-prompt-tag "return-search-paths"))
 640          (s (build-system
 641              (name 'raw)
 642              (description "Raw build system with direct store access")
 643              (lower (lambda* (name #:key source inputs system target
 644                                    #:allow-other-keys)
 645                       (bag
 646                         (name name)
 647                         (system system) (target target)
 648                         (build-inputs inputs)
 649                         (build
 650                          (lambda* (store name inputs
 651                                          #:key outputs system search-paths)
 652                            search-paths)))))))
 653          (x (list (search-path-specification
 654                    (variable "GUILE_LOAD_PATH")
 655                    (files '("share/guile/site/2.0")))
 656                   (search-path-specification
 657                    (variable "GUILE_LOAD_COMPILED_PATH")
 658                    (files '("share/guile/site/2.0")))))
 659          (a (package (inherit (dummy-package "guile"))
 660               (build-system s)
 661               (native-search-paths x)))
 662          (b (package (inherit (dummy-package "guile-foo"))
 663               (build-system s)
 664               (inputs `(("guile" ,a)))))
 665          (c (package (inherit (dummy-package "guile-bar"))
 666               (build-system s)
 667               (inputs `(("guile" ,a)
 668                         ("guile-foo" ,b))))))
 669     (let-syntax ((collect (syntax-rules ()
 670                             ((_ body ...)
 671                              (call-with-prompt p
 672                                (lambda ()
 673                                  body ...)
 674                                (lambda (k search-paths)
 675                                  search-paths))))))
 676       (and (null? (collect (package-derivation %store a)))
 677            (equal? x (collect (package-derivation %store b)))
 678            (equal? x (collect (package-derivation %store c)))))))
 679
 680 (test-assert "package-transitive-native-search-paths"
 681   (let* ((sp (lambda (name)
 682                (list (search-path-specification
 683                       (variable name)
 684                       (files '("foo/bar"))))))
 685          (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
 686          (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
 687          (p2 (dummy-package "p2"
 688                (native-search-paths (sp "PATH2"))
 689                (inputs `(("p0" ,p0)))
 690                (propagated-inputs `(("p1" ,p1)))))
 691          (p3 (dummy-package "p3"
 692                (native-search-paths (sp "PATH3"))
 693                (native-inputs `(("p0" ,p0)))
 694                (propagated-inputs `(("p2" ,p2))))))
 695     (lset= string=?
 696            '("PATH1" "PATH2" "PATH3")
 697            (map search-path-specification-variable
 698                 (package-transitive-native-search-paths p3)))))
 699
 700 (test-assert "package-cross-derivation"
 701   (let ((drv (package-cross-derivation %store (dummy-package "p")
 702                                        "mips64el-linux-gnu")))
 703     (and (derivation? drv)
 704          (file-exists? (derivation-file-name drv)))))
 705
 706 (test-assert "package-cross-derivation, trivial-build-system"
 707   (let ((p (package (inherit (dummy-package "p"))
 708              (build-system trivial-build-system)
 709              (arguments '(#:builder (exit 1))))))
 710     (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
 711       (derivation? drv))))
 712
 713 (test-assert "package-cross-derivation, no cross builder"
 714   (let* ((b (build-system (inherit trivial-build-system)
 715               (lower (const #f))))
 716          (p (package (inherit (dummy-package "p"))
 717               (build-system b))))
 718     (guard (c ((package-cross-build-system-error? c)
 719                (eq? (package-error-package c) p)))
 720       (package-cross-derivation %store p "mips64el-linux-gnu")
 721       #f)))
 722
 723 ;; XXX: The next two tests can trigger builds when the distro defines
 724 ;; replacements on core packages, so they're disable for lack of a better
 725 ;; solution.
 726
 727 ;; (test-equal "package-derivation, direct graft"
 728 ;;   (package-derivation %store gnu-make #:graft? #f)
 729 ;;   (let ((p (package (inherit coreutils)
 730 ;;              (replacement gnu-make))))
 731 ;;     (package-derivation %store p #:graft? #t)))
 732
 733 ;; (test-equal "package-cross-derivation, direct graft"
 734 ;;   (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
 735 ;;                             #:graft? #f)
 736 ;;   (let ((p (package (inherit coreutils)
 737 ;;              (replacement gnu-make))))
 738 ;;     (package-cross-derivation %store p "mips64el-linux-gnu"
 739 ;;                               #:graft? #t)))
 740
 741 (test-assert "package-grafts, indirect grafts"
 742   (let* ((new   (dummy-package "dep"
 743                   (arguments '(#:implicit-inputs? #f))))
 744          (dep   (package (inherit new) (version "0.0")))
 745          (dep*  (package (inherit dep) (replacement new)))
 746          (dummy (dummy-package "dummy"
 747                   (arguments '(#:implicit-inputs? #f))
 748                   (inputs `(("dep" ,dep*))))))
 749     (equal? (package-grafts %store dummy)
 750             (list (graft
 751                     (origin (package-derivation %store dep))
 752                     (replacement (package-derivation %store new)))))))
 753
 754 ;; XXX: This test would require building the cross toolchain just to see if it
 755 ;; needs grafting, which is obviously too expensive, and thus disabled.
 756 ;;
 757 ;; (test-assert "package-grafts, indirect grafts, cross"
 758 ;;   (let* ((new    (dummy-package "dep"
 759 ;;                    (arguments '(#:implicit-inputs? #f))))
 760 ;;          (dep    (package (inherit new) (version "0.0")))
 761 ;;          (dep*   (package (inherit dep) (replacement new)))
 762 ;;          (dummy  (dummy-package "dummy"
 763 ;;                    (arguments '(#:implicit-inputs? #f))
 764 ;;                    (inputs `(("dep" ,dep*)))))
 765 ;;          (target "mips64el-linux-gnu"))
 766 ;;     ;; XXX: There might be additional grafts, for instance if the distro
 767 ;;     ;; defines replacements for core packages like Perl.
 768 ;;     (member (graft
 769 ;;               (origin (package-cross-derivation %store dep target))
 770 ;;               (replacement
 771 ;;                (package-cross-derivation %store new target)))
 772 ;;             (package-grafts %store dummy #:target target))))
 773
 774 (test-assert "package-grafts, indirect grafts, propagated inputs"
 775   (let* ((new   (dummy-package "dep"
 776                   (arguments '(#:implicit-inputs? #f))))
 777          (dep   (package (inherit new) (version "0.0")))
 778          (dep*  (package (inherit dep) (replacement new)))
 779          (prop  (dummy-package "propagated"
 780                   (propagated-inputs `(("dep" ,dep*)))
 781                   (arguments '(#:implicit-inputs? #f))))
 782          (dummy (dummy-package "dummy"
 783                   (arguments '(#:implicit-inputs? #f))
 784                   (inputs `(("prop" ,prop))))))
 785     (equal? (package-grafts %store dummy)
 786             (list (graft
 787                     (origin (package-derivation %store dep))
 788                     (replacement (package-derivation %store new)))))))
 789
 790 (test-assert "package-grafts, same replacement twice"
 791   (let* ((new  (dummy-package "dep"
 792                  (version "1")
 793                  (arguments '(#:implicit-inputs? #f))))
 794          (dep  (package (inherit new) (version "0") (replacement new)))
 795          (p1   (dummy-package "intermediate1"
 796                  (arguments '(#:implicit-inputs? #f))
 797                  (inputs `(("dep" ,dep)))))
 798          (p2   (dummy-package "intermediate2"
 799                  (arguments '(#:implicit-inputs? #f))
 800                  ;; Here we copy DEP to have an equivalent package that is not
 801                  ;; 'eq?' to DEP.  This is similar to what happens with
 802                  ;; 'package-with-explicit-inputs' & co.
 803                  (inputs `(("dep" ,(package (inherit dep)))))))
 804          (p3   (dummy-package "final"
 805                  (arguments '(#:implicit-inputs? #f))
 806                  (inputs `(("p1" ,p1) ("p2" ,p2))))))
 807     (equal? (package-grafts %store p3)
 808             (list (graft
 809                     (origin (package-derivation %store
 810                                                 (package (inherit dep)
 811                                                          (replacement #f))))
 812                     (replacement (package-derivation %store new)))))))
 813
 814 (test-assert "replacement also grafted"
 815   ;; We build a DAG as below, where dotted arrows represent replacements and
 816   ;; solid arrows represent dependencies:
 817   ;;
 818   ;;  P1  ·············>  P1R
 819   ;;  |\__________________.
 820   ;;  v                   v
 821   ;;  P2  ·············>  P2R
 822   ;;  |
 823   ;;  v
 824   ;;  P3
 825   ;;
 826   ;; We want to make sure that:
 827   ;;   grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
 828   ;; where:
 829   ;;   (A,B) is a graft to replace A by B
 830   ;;   grafted(DRV,G) denoted DRV with graft G applied
 831   (let* ((p1r (dummy-package "P1"
 832                 (build-system trivial-build-system)
 833                 (arguments
 834                  `(#:guile ,%bootstrap-guile
 835                    #:builder (let ((out (assoc-ref %outputs "out")))
 836                                (mkdir out)
 837                                (call-with-output-file
 838                                    (string-append out "/replacement")
 839                                  (const #t)))))))
 840          (p1  (package
 841                 (inherit p1r) (name "p1") (replacement p1r)
 842                 (arguments
 843                  `(#:guile ,%bootstrap-guile
 844                    #:builder (begin
 845                                (mkdir (assoc-ref %outputs "out"))
 846                                #t)))))
 847          (p2r (dummy-package "P2"
 848                 (build-system trivial-build-system)
 849                 (inputs `(("p1" ,p1)))
 850                 (arguments
 851                  `(#:guile ,%bootstrap-guile
 852                    #:builder (let ((out (assoc-ref %outputs "out")))
 853                                (mkdir out)
 854                                (chdir out)
 855                                (symlink (assoc-ref %build-inputs "p1") "p1")
 856                                (call-with-output-file (string-append out "/replacement")
 857                                  (const #t)))))))
 858          (p2  (package
 859                 (inherit p2r) (name "p2") (replacement p2r)
 860                 (arguments
 861                  `(#:guile ,%bootstrap-guile
 862                    #:builder (let ((out (assoc-ref %outputs "out")))
 863                                (mkdir out)
 864                                (chdir out)
 865                                (symlink (assoc-ref %build-inputs "p1")
 866                                         "p1")
 867                                #t)))))
 868          (p3  (dummy-package "p3"
 869                 (build-system trivial-build-system)
 870                 (inputs `(("p2" ,p2)))
 871                 (arguments
 872                  `(#:guile ,%bootstrap-guile
 873                    #:builder (let ((out (assoc-ref %outputs "out")))
 874                                (mkdir out)
 875                                (chdir out)
 876                                (symlink (assoc-ref %build-inputs "p2")
 877                                         "p2")
 878                                #t))))))
 879     (lset= equal?
 880            (package-grafts %store p3)
 881            (list (graft
 882                    (origin (package-derivation %store p1 #:graft? #f))
 883                    (replacement (package-derivation %store p1r)))
 884                  (graft
 885                    (origin (package-derivation %store p2 #:graft? #f))
 886                    (replacement
 887                     (package-derivation %store p2r #:graft? #t)))))))
 888
 889 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
 890 ;;; find out about their run-time dependencies, so this test is no longer
 891 ;;; applicable since it would trigger a full rebuild.
 892 ;;
 893 ;; (test-assert "package-derivation, indirect grafts"
 894 ;;   (let* ((new   (dummy-package "dep"
 895 ;;                   (arguments '(#:implicit-inputs? #f))))
 896 ;;          (dep   (package (inherit new) (version "0.0")))
 897 ;;          (dep*  (package (inherit dep) (replacement new)))
 898 ;;          (dummy (dummy-package "dummy"
 899 ;;                   (arguments '(#:implicit-inputs? #f))
 900 ;;                   (inputs `(("dep" ,dep*)))))
 901 ;;          (guile (package-derivation %store (canonical-package guile-2.0)
 902 ;;                                     #:graft? #f)))
 903 ;;     (equal? (package-derivation %store dummy)
 904 ;;             (graft-derivation %store
 905 ;;                               (package-derivation %store dummy #:graft? #f)
 906 ;;                               (package-grafts %store dummy)
 907
 908 ;;                               ;; Use the same Guile as 'package-derivation'.
 909 ;;                               #:guile guile))))
 910
 911 (test-equal "package->bag"
 912   `("foo86-hurd" #f (,(package-source gnu-make))
 913     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 914   (let ((bag (package->bag gnu-make "foo86-hurd")))
 915     (list (bag-system bag) (bag-target bag)
 916           (assoc-ref (bag-build-inputs bag) "source")
 917           (assoc-ref (bag-build-inputs bag) "libc")
 918           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 919
 920 (test-equal "package->bag, cross-compilation"
 921   `(,(%current-system) "foo86-hurd"
 922     (,(package-source gnu-make))
 923     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 924   (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
 925     (list (bag-system bag) (bag-target bag)
 926           (assoc-ref (bag-build-inputs bag) "source")
 927           (assoc-ref (bag-build-inputs bag) "libc")
 928           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 929
 930 (test-assert "package->bag, propagated inputs"
 931   (let* ((dep    (dummy-package "dep"))
 932          (prop   (dummy-package "prop"
 933                    (propagated-inputs `(("dep" ,dep)))))
 934          (dummy  (dummy-package "dummy"
 935                    (inputs `(("prop" ,prop)))))
 936          (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
 937     (match (assoc "dep" inputs)
 938       (("dep" package)
 939        (eq? package dep)))))
 940
 941 (test-assert "bag->derivation"
 942   (parameterize ((%graft? #f))
 943     (let ((bag (package->bag gnu-make))
 944           (drv (package-derivation %store gnu-make)))
 945       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
 946         (equal? drv (bag->derivation %store bag))))))
 947
 948 (test-assert "bag->derivation, cross-compilation"
 949   (parameterize ((%graft? #f))
 950     (let* ((target "mips64el-linux-gnu")
 951            (bag    (package->bag gnu-make (%current-system) target))
 952            (drv    (package-cross-derivation %store gnu-make target)))
 953       (parameterize ((%current-system "foox86-hurd") ;should have no effect
 954                      (%current-target-system "foo64-linux-gnu"))
 955         (equal? drv (bag->derivation %store bag))))))
 956
 957 (when (or (not (network-reachable?)) (shebang-too-long?))
 958   (test-skip 1))
 959 (test-assert "GNU Make, bootstrap"
 960   ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the
 961   ;; test doesn't last for too long.
 962   (let ((gnu-make gnu-make-for-tests))
 963     (and (package? gnu-make)
 964          (or (location? (package-location gnu-make))
 965              (not (package-location gnu-make)))
 966          (let* ((drv (package-derivation %store gnu-make))
 967                 (out (derivation->output-path drv)))
 968            (and (build-derivations %store (list drv))
 969                 (file-exists? (string-append out "/bin/make")))))))
 970
 971 (test-equal "package-mapping"
 972   42
 973   (let* ((dep       (dummy-package "chbouib"
 974                       (native-inputs `(("x" ,grep)))))
 975          (p0        (dummy-package "example"
 976                       (inputs `(("foo" ,coreutils)
 977                                 ("bar" ,grep)
 978                                 ("baz" ,dep)))))
 979          (transform (lambda (p)
 980                       (package (inherit p) (source 42))))
 981          (rewrite   (package-mapping transform))
 982          (p1        (rewrite p0)))
 983     (and (eq? p1 (rewrite p0))
 984          (eqv? 42 (package-source p1))
 985          (match (package-inputs p1)
 986            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 987             (and (eq? dep1 (rewrite coreutils))   ;memoization
 988                  (eq? dep2 (rewrite grep))
 989                  (eq? dep3 (rewrite dep))
 990                  (eqv? 42
 991                        (package-source dep1) (package-source dep2)
 992                        (package-source dep3))
 993                  (match (package-native-inputs dep3)
 994                    ((("x" dep))
 995                     (and (eq? dep (rewrite grep))
 996                          (package-source dep))))))))))
 997
 998 (test-assert "package-input-rewriting"
 999   (let* ((dep     (dummy-package "chbouib"
1000                     (native-inputs `(("x" ,grep)))))
1001          (p0      (dummy-package "example"
1002                     (inputs `(("foo" ,coreutils)
1003                               ("bar" ,grep)
1004                               ("baz" ,dep)))))
1005          (rewrite (package-input-rewriting `((,coreutils . ,sed)
1006                                              (,grep . ,findutils))
1007                                            (cut string-append "r-" <>)))
1008          (p1      (rewrite p0))
1009          (p2      (rewrite p0)))
1010     (and (not (eq? p1 p0))
1011          (eq? p1 p2)                              ;memoization
1012          (string=? "r-example" (package-name p1))
1013          (match (package-inputs p1)
1014            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1015             (and (eq? dep1 sed)
1016                  (eq? dep2 findutils)
1017                  (string=? (package-name dep3) "r-chbouib")
1018                  (eq? dep3 (rewrite dep))         ;memoization
1019                  (match (package-native-inputs dep3)
1020                    ((("x" dep))
1021                     (eq? dep findutils)))))))))
1022
1023 (test-assert "package-input-rewriting/spec"
1024   (let* ((dep     (dummy-package "chbouib"
1025                     (native-inputs `(("x" ,grep)))))
1026          (p0      (dummy-package "example"
1027                     (inputs `(("foo" ,coreutils)
1028                               ("bar" ,grep)
1029                               ("baz" ,dep)))))
1030          (rewrite (package-input-rewriting/spec
1031                    `(("coreutils" . ,(const sed))
1032                      ("grep" . ,(const findutils)))))
1033          (p1      (rewrite p0))
1034          (p2      (rewrite p0)))
1035     (and (not (eq? p1 p0))
1036          (eq? p1 p2)                              ;memoization
1037          (string=? "example" (package-name p1))
1038          (match (package-inputs p1)
1039            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1040             (and (string=? (package-full-name dep1)
1041                            (package-full-name sed))
1042                  (string=? (package-full-name dep2)
1043                            (package-full-name findutils))
1044                  (string=? (package-name dep3) "chbouib")
1045                  (eq? dep3 (rewrite dep))         ;memoization
1046                  (match (package-native-inputs dep3)
1047                    ((("x" dep))
1048                     (string=? (package-full-name dep)
1049                               (package-full-name findutils))))))))))
1050
1051 (test-assert "package-input-rewriting/spec, partial match"
1052   (let* ((dep     (dummy-package "chbouib"
1053                     (version "1")
1054                     (native-inputs `(("x" ,grep)))))
1055          (p0      (dummy-package "example"
1056                     (inputs `(("foo" ,coreutils)
1057                               ("bar" ,dep)))))
1058          (rewrite (package-input-rewriting/spec
1059                    `(("chbouib@123" . ,(const sed)) ;not matched
1060                      ("grep" . ,(const findutils)))))
1061          (p1      (rewrite p0)))
1062     (and (not (eq? p1 p0))
1063          (string=? "example" (package-name p1))
1064          (match (package-inputs p1)
1065            ((("foo" dep1) ("bar" dep2))
1066             (and (string=? (package-full-name dep1)
1067                            (package-full-name coreutils))
1068                  (eq? dep2 (rewrite dep))         ;memoization
1069                  (match (package-native-inputs dep2)
1070                    ((("x" dep))
1071                     (string=? (package-full-name dep)
1072                               (package-full-name findutils))))))))))
1073
1074 (test-equal "package-patched-vulnerabilities"
1075   '(("CVE-2015-1234")
1076     ("CVE-2016-1234" "CVE-2018-4567")
1077     ())
1078   (let ((p1 (dummy-package "pi"
1079               (source (dummy-origin
1080                        (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
1081         (p2 (dummy-package "pi"
1082               (source (dummy-origin
1083                        (patches (list
1084                                  "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
1085         (p3 (dummy-package "pi" (source (dummy-origin)))))
1086     (map package-patched-vulnerabilities
1087          (list p1 p2 p3))))
1088
1089 (test-eq "fold-packages" hello
1090   (fold-packages (lambda (p r)
1091                    (if (string=? (package-name p) "hello")
1092                        p
1093                        r))
1094                  #f))
1095
1096 (test-assert "fold-packages, hidden package"
1097   ;; There are two public variables providing "guile@2.0" ('guile-final' in
1098   ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
1099   ;; should show up.
1100   (match (fold-packages (lambda (p r)
1101                           (if (and (string=? (package-name p) "guile")
1102                                    (string-prefix? "2.0"
1103                                                    (package-version p)))
1104                               (cons p r)
1105                               r))
1106                         '())
1107     ((one)
1108      (eq? one guile-2.0))))
1109
1110 (test-assert "fold-available-packages with/without cache"
1111   (let ()
1112     (define no-cache
1113       (fold-available-packages (lambda* (name version result #:rest rest)
1114                                  (cons (cons* name version rest)
1115                                        result))
1116                                '()))
1117
1118     (define from-cache
1119       (call-with-temporary-directory
1120        (lambda (cache)
1121          (generate-package-cache cache)
1122          (mock ((guix describe) current-profile (const cache))
1123                (mock ((gnu packages) cache-is-authoritative? (const #t))
1124                      (fold-available-packages (lambda* (name version result
1125                                                              #:rest rest)
1126                                                 (cons (cons* name version rest)
1127                                                       result))
1128                                               '()))))))
1129
1130     (and (equal? (delete-duplicates from-cache) from-cache)
1131          (lset= equal? no-cache from-cache))))
1132
1133 (test-assert "find-packages-by-name"
1134   (match (find-packages-by-name "hello")
1135     (((? (cut eq? hello <>))) #t)
1136     (wrong (pk 'find-packages-by-name wrong #f))))
1137
1138 (test-assert "find-packages-by-name with version"
1139   (match (find-packages-by-name "hello" (package-version hello))
1140     (((? (cut eq? hello <>))) #t)
1141     (wrong (pk 'find-packages-by-name wrong #f))))
1142
1143 (test-equal "find-packages-by-name with cache"
1144   (find-packages-by-name "guile")
1145   (call-with-temporary-directory
1146    (lambda (cache)
1147      (generate-package-cache cache)
1148      (mock ((guix describe) current-profile (const cache))
1149            (mock ((gnu packages) cache-is-authoritative? (const #t))
1150                  (find-packages-by-name "guile"))))))
1151
1152 (test-equal "find-packages-by-name + version, with cache"
1153   (find-packages-by-name "guile" "2")
1154   (call-with-temporary-directory
1155    (lambda (cache)
1156      (generate-package-cache cache)
1157      (mock ((guix describe) current-profile (const cache))
1158            (mock ((gnu packages) cache-is-authoritative? (const #t))
1159                  (find-packages-by-name "guile" "2"))))))
1160
1161 (test-assert "--search-paths with pattern"
1162   ;; Make sure 'guix package --search-paths' correctly reports environment
1163   ;; variables when file patterns are used (in particular, it must follow
1164   ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
1165   ;; libxml2 package specification, which contains such a definition.
1166   (let* ((p1 (package
1167                (name "foo") (version "0") (source #f)
1168                (build-system trivial-build-system)
1169                (arguments
1170                 `(#:guile ,%bootstrap-guile
1171                   #:modules ((guix build utils))
1172                   #:builder (begin
1173                               (use-modules (guix build utils))
1174                               (let ((out (assoc-ref %outputs "out")))
1175                                 (mkdir-p (string-append out "/xml/bar/baz"))
1176                                 (call-with-output-file
1177                                     (string-append out "/xml/bar/baz/catalog.xml")
1178                                   (lambda (port)
1179                                     (display "xml? wat?!" port)))
1180                                 #t))))
1181                (synopsis #f) (description #f)
1182                (home-page #f) (license #f)))
1183          (p2 (package
1184                ;; Provide a fake libxml2 to avoid building the real one.  This
1185                ;; is OK because 'guix package' gets search path specifications
1186                ;; from the same-named package found in the distro.
1187                (name "libxml2") (version "0.0.0") (source #f)
1188                (build-system trivial-build-system)
1189                (arguments
1190                 `(#:guile ,%bootstrap-guile
1191                   #:builder (begin
1192                               (mkdir (assoc-ref %outputs "out"))
1193                               #t)))
1194                (native-search-paths (package-native-search-paths libxml2))
1195                (synopsis #f) (description #f)
1196                (home-page #f) (license #f)))
1197          (prof (run-with-store %store
1198                  (profile-derivation
1199                   (manifest (map package->manifest-entry
1200                                  (list p1 p2)))
1201                   #:hooks '()
1202                   #:locales? #f)
1203                  #:guile-for-build (%guile-for-build))))
1204     (build-derivations %store (list prof))
1205     (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
1206                           (regexp-quote (derivation->output-path prof)))
1207                   (with-output-to-string
1208                     (lambda ()
1209                       (guix-package "-p" (derivation->output-path prof)
1210                                     "--search-paths"))))))
1211
1212 (test-assert "--search-paths with single-item search path"
1213   ;; Make sure 'guix package --search-paths' correctly reports environment
1214   ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
1215   ;; separator, meaning that the first match wins.
1216   (let* ((p1 (dummy-package "foo"
1217                (build-system trivial-build-system)
1218                (arguments
1219                 `(#:guile ,%bootstrap-guile
1220                   #:modules ((guix build utils))
1221                   #:builder (begin
1222                               (use-modules (guix build utils))
1223                               (let ((out (assoc-ref %outputs "out")))
1224                                 (mkdir-p (string-append out "/etc/ssl/certs"))
1225                                 (call-with-output-file
1226                                     (string-append
1227                                      out "/etc/ssl/certs/ca-certificates.crt")
1228                                   (const #t))))))))
1229          (p2 (package (inherit p1) (name "bar")))
1230          (p3 (dummy-package "git"
1231                ;; Provide a fake Git to avoid building the real one.
1232                (build-system trivial-build-system)
1233                (arguments
1234                 `(#:guile ,%bootstrap-guile
1235                   #:builder (begin
1236                               (mkdir (assoc-ref %outputs "out"))
1237                               #t)))
1238                (native-search-paths (package-native-search-paths git))))
1239          (prof1 (run-with-store %store
1240                   (profile-derivation
1241                    (packages->manifest (list p1 p3))
1242                    #:hooks '()
1243                    #:locales? #f)
1244                   #:guile-for-build (%guile-for-build)))
1245          (prof2 (run-with-store %store
1246                   (profile-derivation
1247                    (packages->manifest (list p2 p3))
1248                    #:hooks '()
1249                    #:locales? #f)
1250                   #:guile-for-build (%guile-for-build))))
1251     (build-derivations %store (list prof1 prof2))
1252     (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
1253                           (regexp-quote (derivation->output-path prof1)))
1254                   (with-output-to-string
1255                     (lambda ()
1256                       (guix-package "-p" (derivation->output-path prof1)
1257                                     "-p" (derivation->output-path prof2)
1258                                     "--search-paths"))))))
1259
1260 (test-equal "specification->package when not found"
1261   'quit
1262   (catch 'quit
1263     (lambda ()
1264       ;; This should call 'leave', producing an error message.
1265       (specification->package "this-package-does-not-exist"))
1266     (lambda (key . args)
1267       key)))
1268
1269 (test-equal "specification->package+output"
1270   `((,coreutils "out") (,coreutils "debug"))
1271   (list (call-with-values (lambda ()
1272                             (specification->package+output "coreutils"))
1273           list)
1274         (call-with-values (lambda ()
1275                             (specification->package+output "coreutils:debug"))
1276           list)))
1277
1278 (test-equal "specification->package+output invalid output"
1279   'error
1280   (catch 'quit
1281     (lambda ()
1282       (specification->package+output "coreutils:does-not-exist"))
1283     (lambda _
1284       'error)))
1285
1286 (test-equal "specification->package+output no default output"
1287   `(,coreutils #f)
1288   (call-with-values
1289     (lambda ()
1290       (specification->package+output "coreutils" #f))
1291     list))
1292
1293 (test-equal "specification->package+output invalid output, no default"
1294   'error
1295   (catch 'quit
1296     (lambda ()
1297       (specification->package+output "coreutils:does-not-exist" #f))
1298     (lambda _
1299       'error)))
1300
1301 (test-equal "find-package-locations"
1302   (map (lambda (package)
1303          (cons (package-version package)
1304                (package-location package)))
1305        (find-packages-by-name "guile"))
1306   (find-package-locations "guile"))
1307
1308 (test-equal "find-package-locations with cache"
1309   (map (lambda (package)
1310          (cons (package-version package)
1311                (package-location package)))
1312        (find-packages-by-name "guile"))
1313   (call-with-temporary-directory
1314    (lambda (cache)
1315      (generate-package-cache cache)
1316      (mock ((guix describe) current-profile (const cache))
1317            (mock ((gnu packages) cache-is-authoritative? (const #t))
1318                  (find-package-locations "guile"))))))
1319
1320 (test-equal "specification->location"
1321   (package-location (specification->package "guile@2"))
1322   (specification->location "guile@2"))
1323
1324 (test-end "packages")
1325
1326 ;;; Local Variables:
1327 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
1328 ;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1)
1329 ;;; End: