tests/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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   #:use-module ((guix diagnostics)
  28                 ;; Rename the 'location' binding to allow proper syntax
  29                 ;; matching when setting the 'location' field of a package.
  30                 #:renamer (lambda (name)
  31                             (cond ((eq? name 'location) 'make-location)
  32                                   (else name))))
  33   #:use-module ((gcrypt hash) #:prefix gcrypt:)
  34   #:use-module (guix derivations)
  35   #:use-module (guix packages)
  36   #:use-module (guix grafts)
  37   #:use-module (guix search-paths)
  38   #:use-module (guix build-system)
  39   #:use-module (guix build-system trivial)
  40   #:use-module (guix build-system gnu)
  41   #:use-module (guix build-system python)
  42   #:use-module (guix memoization)
  43   #:use-module (guix profiles)
  44   #:use-module (guix scripts package)
  45   #:use-module (gnu packages)
  46   #:use-module (gnu packages base)
  47   #:use-module (gnu packages guile)
  48   #:use-module (gnu packages bootstrap)
  49   #:use-module (gnu packages python)
  50   #:use-module (gnu packages version-control)
  51   #:use-module (gnu packages xml)
  52   #:use-module (srfi srfi-1)
  53   #:use-module (srfi srfi-26)
  54   #:use-module (srfi srfi-34)
  55   #:use-module (srfi srfi-35)
  56   #:use-module (srfi srfi-64)
  57   #:use-module (rnrs bytevectors)
  58   #:use-module (rnrs io ports)
  59   #:use-module (ice-9 vlist)
  60   #:use-module (ice-9 regex)
  61   #:use-module (ice-9 match))
  62
  63 ;; Test the high-level packaging layer.
  64
  65 (define %store
  66   (open-connection-for-tests))
  67
  68 ;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
  69 ;; can trigger builds early.)
  70 (%graft? #f)
  71
  72 \f
  73 (test-begin "packages")
  74
  75 (test-assert "printer with location"
  76   (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
  77                 (with-output-to-string
  78                   (lambda ()
  79                     (write
  80                      (dummy-package "foo"
  81                        (location (make-location "foo.scm" 42 7))))))))
  82
  83 (test-assert "printer without location"
  84   (string-match "^#<package foo@0 [[:xdigit:]]+>$"
  85                 (with-output-to-string
  86                   (lambda ()
  87                     (write
  88                      (dummy-package "foo" (location #f)))))))
  89
  90 (test-assert "hidden-package"
  91   (and (hidden-package? (hidden-package (dummy-package "foo")))
  92        (not (hidden-package? (dummy-package "foo")))))
  93
  94 (test-assert "package-superseded"
  95   (let* ((new (dummy-package "bar"))
  96          (old (deprecated-package "foo" new)))
  97     (and (eq? (package-superseded old) new)
  98          (mock ((gnu packages) find-best-packages-by-name (const (list old)))
  99                (specification->package "foo")
 100                (and (eq? new (specification->package "foo"))
 101                     (eq? new (specification->package+output "foo")))))))
 102
 103 (test-assert "transaction-upgrade-entry, zero upgrades"
 104   (let* ((old (dummy-package "foo" (version "1")))
 105          (tx  (mock ((gnu packages) find-best-packages-by-name
 106                      (const '()))
 107                     (transaction-upgrade-entry
 108                      #f                           ;no store access needed
 109                      (manifest-entry
 110                        (inherit (package->manifest-entry old))
 111                        (item (string-append (%store-prefix) "/"
 112                                             (make-string 32 #\e) "-foo-1")))
 113                      (manifest-transaction)))))
 114     (manifest-transaction-null? tx)))
 115
 116 (test-assert "transaction-upgrade-entry, zero upgrades, equivalent package"
 117   (let* ((old (dummy-package "foo" (version "1")))
 118          (drv (package-derivation %store old))
 119          (tx  (mock ((gnu packages) find-best-packages-by-name
 120                      (const (list old)))
 121                     (transaction-upgrade-entry
 122                      %store
 123                      (manifest-entry
 124                        (inherit (package->manifest-entry old))
 125                        (item (derivation->output-path drv)))
 126                      (manifest-transaction)))))
 127     (manifest-transaction-null? tx)))
 128
 129 (test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs"
 130   ;; Properly detect equivalent packages even when they have propagated
 131   ;; inputs.  See <https://bugs.gnu.org/35872>.
 132   (let* ((dep (dummy-package "dep" (version "2")))
 133          (old (dummy-package "foo" (version "1")
 134                              (propagated-inputs `(("dep" ,dep)))))
 135          (drv (package-derivation %store old))
 136          (tx  (mock ((gnu packages) find-best-packages-by-name
 137                      (const (list old)))
 138                     (transaction-upgrade-entry
 139                      %store
 140                      (manifest-entry
 141                        (inherit (package->manifest-entry old))
 142                        (item (derivation->output-path drv))
 143                        (dependencies
 144                         (list (manifest-entry
 145                                 (inherit (package->manifest-entry dep))
 146                                 (item (derivation->output-path
 147                                        (package-derivation %store dep)))))))
 148                      (manifest-transaction)))))
 149     (manifest-transaction-null? tx)))
 150
 151 (test-assert "transaction-upgrade-entry, one upgrade"
 152   (let* ((old (dummy-package "foo" (version "1")))
 153          (new (dummy-package "foo" (version "2")))
 154          (tx  (mock ((gnu packages) find-best-packages-by-name
 155                      (const (list new)))
 156                     (transaction-upgrade-entry
 157                      #f                           ;no store access needed
 158                      (manifest-entry
 159                        (inherit (package->manifest-entry old))
 160                        (item (string-append (%store-prefix) "/"
 161                                             (make-string 32 #\e) "-foo-1")))
 162                      (manifest-transaction)))))
 163     (and (match (manifest-transaction-install tx)
 164            ((($ <manifest-entry> "foo" "2" "out" item))
 165             (eq? item new)))
 166          (null? (manifest-transaction-remove tx)))))
 167
 168 (test-assert "transaction-upgrade-entry, superseded package"
 169   (let* ((old (dummy-package "foo" (version "1")))
 170          (new (dummy-package "bar" (version "2")))
 171          (dep (deprecated-package "foo" new))
 172          (tx  (mock ((gnu packages) find-best-packages-by-name
 173                      (const (list dep)))
 174                     (transaction-upgrade-entry
 175                      #f                           ;no store access needed
 176                      (manifest-entry
 177                        (inherit (package->manifest-entry old))
 178                        (item (string-append (%store-prefix) "/"
 179                                             (make-string 32 #\e) "-foo-1")))
 180                      (manifest-transaction)))))
 181     (and (match (manifest-transaction-install tx)
 182            ((($ <manifest-entry> "bar" "2" "out" item))
 183             (eq? item new)))
 184          (match (manifest-transaction-remove tx)
 185            (((? manifest-pattern? pattern))
 186             (and (string=? (manifest-pattern-name pattern) "foo")
 187                  (string=? (manifest-pattern-version pattern) "1")
 188                  (string=? (manifest-pattern-output pattern) "out")))))))
 189
 190 (test-equal "transaction-upgrade-entry, transformation options preserved"
 191   (derivation-file-name (package-derivation %store grep))
 192
 193   (let* ((old   (dummy-package "emacs" (version "1")))
 194          (props '((transformations . ((with-input . "emacs=grep")))))
 195          (tx    (transaction-upgrade-entry
 196                  %store
 197                  (manifest-entry
 198                    (inherit (package->manifest-entry old))
 199                    (properties props)
 200                    (item (string-append (%store-prefix) "/"
 201                                         (make-string 32 #\e) "-foo-1")))
 202                  (manifest-transaction))))
 203     (match (manifest-transaction-install tx)
 204       (((? manifest-entry? entry))
 205        (and (string=? (manifest-entry-version entry)
 206                       (package-version grep))
 207             (string=? (manifest-entry-name entry)
 208                       (package-name grep))
 209             (equal? (manifest-entry-properties entry) props)
 210             (derivation-file-name
 211              (package-derivation %store (manifest-entry-item entry))))))))
 212
 213 (test-assert "transaction-upgrade-entry, grafts"
 214   ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't
 215   ;; try to build stuff.
 216   (with-build-handler (const 'failed!)
 217     (parameterize ((%graft? #t))
 218       (let* ((old (dummy-package "foo" (version "1")))
 219              (bar (dummy-package "bar" (version "0")
 220                                  (replacement old)))
 221              (new (dummy-package "foo" (version "1")
 222                                  (inputs `(("bar" ,bar)))))
 223              (tx  (mock ((gnu packages) find-best-packages-by-name
 224                          (const (list new)))
 225                         (transaction-upgrade-entry
 226                          %store
 227                          (manifest-entry
 228                            (inherit (package->manifest-entry old))
 229                            (item (string-append (%store-prefix) "/"
 230                                                 (make-string 32 #\e) "-foo-1")))
 231                          (manifest-transaction)))))
 232         (and (match (manifest-transaction-install tx)
 233                ((($ <manifest-entry> "foo" "1" "out" item))
 234                 (eq? item new)))
 235              (null? (manifest-transaction-remove tx)))))))
 236
 237 (test-assert "package-field-location"
 238   (let ()
 239     (define (goto port line column)
 240       (unless (and (= (port-column port) (- column 1))
 241                    (= (port-line port) (- line 1)))
 242         (unless (eof-object? (get-char port))
 243           (goto port line column))))
 244
 245     (define read-at
 246       (match-lambda
 247        (($ <location> file line column)
 248         (call-with-input-file (search-path %load-path file)
 249           (lambda (port)
 250             (goto port line column)
 251             (read port))))))
 252
 253     ;; Until Guile 2.0.6 included, source properties were added only to pairs.
 254     ;; Thus, check against both VALUE and (FIELD VALUE).
 255     (and (member (read-at (package-field-location %bootstrap-guile 'name))
 256                  (let ((name (package-name %bootstrap-guile)))
 257                    (list name `(name ,name))))
 258          (member (read-at (package-field-location %bootstrap-guile 'version))
 259                  (let ((version (package-version %bootstrap-guile)))
 260                    (list version `(version ,version))))
 261          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 262
 263 ;; Make sure we don't change the file name to an absolute file name.
 264 (test-equal "package-field-location, relative file name"
 265   (location-file (package-location %bootstrap-guile))
 266   (with-fluids ((%file-port-name-canonicalization 'absolute))
 267     (location-file (package-field-location %bootstrap-guile 'version))))
 268
 269 (test-assert "package-transitive-inputs"
 270   (let* ((a (dummy-package "a"))
 271          (b (dummy-package "b"
 272               (propagated-inputs `(("a" ,a)))))
 273          (c (dummy-package "c"
 274               (inputs `(("a" ,a)))))
 275          (d (dummy-package "d"
 276               (propagated-inputs `(("x" "something.drv")))))
 277          (e (dummy-package "e"
 278               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
 279     (and (null? (package-transitive-inputs a))
 280          (equal? `(("a" ,a)) (package-transitive-inputs b))
 281          (equal? `(("a" ,a)) (package-transitive-inputs c))
 282          (equal? (package-propagated-inputs d)
 283                  (package-transitive-inputs d))
 284          (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
 285                    ("a" ,a) ("x" "something.drv"))
 286                  (pk 'x (package-transitive-inputs e))))))
 287
 288 (test-assert "package-transitive-inputs, no duplicates"
 289   (let* ((a (dummy-package "a"))
 290          (b (dummy-package "b"
 291               (inputs `(("a+" ,a)))
 292               (native-inputs `(("a*" ,a)))
 293               (propagated-inputs `(("a" ,a)))))
 294          (c (dummy-package "c"
 295               (propagated-inputs `(("b" ,b)))))
 296          (d (dummy-package "d"
 297               (inputs `(("a" ,a) ("c" ,c)))))
 298          (e (dummy-package "e"
 299               (inputs `(("b" ,b) ("c" ,c))))))
 300     (and (null? (package-transitive-inputs a))
 301          (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a))   ;here duplicates are kept
 302                  (package-transitive-inputs b))
 303          (equal? `(("b" ,b) ("a" ,a))
 304                  (package-transitive-inputs c))
 305          (equal? `(("a" ,a) ("c" ,c) ("b" ,b))     ;duplicate A removed
 306                  (package-transitive-inputs d))
 307          (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
 308                  (package-transitive-inputs e))))) ;ditto
 309
 310 (test-equal "package-transitive-supported-systems"
 311   '(("x" "y" "z")                                 ;a
 312     ("x" "y")                                     ;b
 313     ("y")                                         ;c
 314     ("y")                                         ;d
 315     ("y"))                                        ;e
 316   ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
 317   ;; doesn't restrict the set of supported systems.
 318   (let* ((a (dummy-package "a"
 319               (build-system trivial-build-system)
 320               (supported-systems '("x" "y" "z"))))
 321          (b (dummy-package "b"
 322               (build-system trivial-build-system)
 323               (supported-systems '("x" "y"))
 324               (inputs `(("a" ,a)))))
 325          (c (dummy-package "c"
 326               (build-system trivial-build-system)
 327               (supported-systems '("y" "z"))
 328               (inputs `(("b" ,b)))))
 329          (d (dummy-package "d"
 330               (build-system trivial-build-system)
 331               (supported-systems '("x" "y" "z"))
 332               (inputs `(("b" ,b) ("c" ,c)))))
 333          (e (dummy-package "e"
 334               (build-system trivial-build-system)
 335               (supported-systems '("x" "y" "z"))
 336               (inputs `(("d" ,d))))))
 337     (list (package-transitive-supported-systems a)
 338           (package-transitive-supported-systems b)
 339           (package-transitive-supported-systems c)
 340           (package-transitive-supported-systems d)
 341           (package-transitive-supported-systems e))))
 342
 343 (test-assert "package-closure"
 344   (let-syntax ((dummy-package/no-implicit
 345                 (syntax-rules ()
 346                   ((_ name rest ...)
 347                    (package
 348                      (inherit (dummy-package name rest ...))
 349                      (build-system trivial-build-system))))))
 350     (let* ((a (dummy-package/no-implicit "a"))
 351            (b (dummy-package/no-implicit "b"
 352                 (propagated-inputs `(("a" ,a)))))
 353            (c (dummy-package/no-implicit "c"
 354                 (inputs `(("a" ,a)))))
 355            (d (dummy-package/no-implicit "d"
 356                 (native-inputs `(("b" ,b)))))
 357            (e (dummy-package/no-implicit "e"
 358                 (inputs `(("c" ,c) ("d" ,d))))))
 359       (lset= eq?
 360              (list a b c d e)
 361              (package-closure (list e))
 362              (package-closure (list e d))
 363              (package-closure (list e c b))))))
 364
 365 (test-equal "origin-actual-file-name"
 366   "foo-1.tar.gz"
 367   (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
 368     (origin-actual-file-name o)))
 369
 370 (test-equal "origin-actual-file-name, file-name"
 371   "foo-1.tar.gz"
 372   (let ((o (dummy-origin
 373             (uri "http://www.example.com/tarball")
 374             (file-name "foo-1.tar.gz"))))
 375     (origin-actual-file-name o)))
 376
 377 (let* ((o (dummy-origin))
 378        (u (dummy-origin))
 379        (i (dummy-origin))
 380        (a (dummy-package "a"))
 381        (b (dummy-package "b"
 382             (inputs `(("a" ,a) ("i" ,i)))))
 383        (c (package (inherit b) (source o)))
 384        (d (dummy-package "d"
 385             (build-system trivial-build-system)
 386             (source u) (inputs `(("c" ,c))))))
 387   (test-assert "package-direct-sources, no source"
 388     (null? (package-direct-sources a)))
 389   (test-equal "package-direct-sources, #f source"
 390     (list i)
 391     (package-direct-sources b))
 392   (test-equal "package-direct-sources, not input source"
 393     (list u)
 394     (package-direct-sources d))
 395   (test-assert "package-direct-sources"
 396     (let ((s (package-direct-sources c)))
 397       (and (= (length (pk 's-sources s)) 2)
 398            (member o s)
 399            (member i s))))
 400   (test-assert "package-transitive-sources"
 401     (let ((s (package-transitive-sources d)))
 402       (and (= (length (pk 'd-sources s)) 3)
 403            (member o s)
 404            (member i s)
 405            (member u s)))))
 406
 407 (test-assert "transitive-input-references"
 408   (let* ((a (dummy-package "a"))
 409          (b (dummy-package "b"))
 410          (c (dummy-package "c"
 411               (inputs `(("a" ,a)))
 412               (propagated-inputs `(("boo" ,b)))))
 413          (d (dummy-package "d"
 414               (inputs `(("c*" ,c)))))
 415          (keys (map (match-lambda
 416                       (('assoc-ref 'l key)
 417                        key))
 418                     (pk 'refs (transitive-input-references
 419                                'l (package-inputs d))))))
 420     (and (= (length keys) 2)
 421          (member "c*" keys)
 422          (member "boo" keys))))
 423
 424 (test-equal "package-transitive-supported-systems, implicit inputs"
 425   %supported-systems
 426
 427   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 428   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 429   (let ((p (dummy-package "foo"
 430                (build-system gnu-build-system)
 431                (supported-systems
 432                 `("does-not-exist" "foobar" ,@%supported-systems)))))
 433     (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture
 434       (package-transitive-supported-systems p))))
 435
 436 (test-equal "package-transitive-supported-systems: reduced binary seed, implicit inputs"
 437   '("x86_64-linux" "i686-linux")
 438
 439   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 440   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 441   (let ((p (dummy-package "foo"
 442              (build-system gnu-build-system)
 443              (supported-systems
 444               `("does-not-exist" "foobar" ,@%supported-systems)))))
 445     (parameterize ((%current-system "x86_64-linux"))
 446       (package-transitive-supported-systems p))))
 447
 448 (test-assert "supported-package?"
 449   (let* ((d (dummy-package "dep"
 450               (build-system trivial-build-system)
 451               (supported-systems '("x86_64-linux"))))
 452          (p (dummy-package "foo"
 453               (build-system gnu-build-system)
 454               (inputs `(("d" ,d)))
 455               (supported-systems '("x86_64-linux" "armhf-linux")))))
 456     (and (supported-package? p "x86_64-linux")
 457          (not (supported-package? p "i686-linux"))
 458          (not (supported-package? p "armhf-linux")))))
 459
 460 (test-assert "supported-package? vs. system-dependent graph"
 461   ;; The inputs of a package can depend on (%current-system).  Thus,
 462   ;; 'supported-package?' must make sure that it binds (%current-system)
 463   ;; appropriately before traversing the dependency graph.  In the example
 464   ;; below, 'supported-package?' must thus return true for both systems.
 465   (let* ((p0a (dummy-package "foo-arm"
 466                 (build-system trivial-build-system)
 467                 (supported-systems '("armhf-linux"))))
 468          (p0b (dummy-package "foo-x86_64"
 469                 (build-system trivial-build-system)
 470                 (supported-systems '("x86_64-linux"))))
 471          (p   (dummy-package "bar"
 472                 (build-system trivial-build-system)
 473                 (inputs
 474                  (if (string=? (%current-system) "armhf-linux")
 475                      `(("foo" ,p0a))
 476                      `(("foo" ,p0b)))))))
 477     (and (supported-package? p "x86_64-linux")
 478          (supported-package? p "armhf-linux"))))
 479
 480 (test-skip (if (not %store) 8 0))
 481
 482 (test-assert "package-source-derivation, file"
 483   (let* ((file    (search-path %load-path "guix.scm"))
 484          (package (package (inherit (dummy-package "p"))
 485                     (source file)))
 486          (source  (package-source-derivation %store
 487                                              (package-source package))))
 488     (and (store-path? source)
 489          (valid-path? %store source)
 490          (equal? (call-with-input-file source get-bytevector-all)
 491                  (call-with-input-file file get-bytevector-all)))))
 492
 493 (test-assert "package-source-derivation, store path"
 494   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 495                                 (search-path %load-path "guix.scm")))
 496          (package (package (inherit (dummy-package "p"))
 497                     (source file)))
 498          (source  (package-source-derivation %store
 499                                              (package-source package))))
 500     (string=? file source)))
 501
 502 (test-assert "package-source-derivation, indirect store path"
 503   (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
 504                                 (dirname (search-path %load-path
 505                                                       "guix/build/utils.scm"))))
 506          (package (package (inherit (dummy-package "p"))
 507                     (source (string-append dir "/utils.scm"))))
 508          (source  (package-source-derivation %store
 509                                              (package-source package))))
 510     (and (direct-store-path? source)
 511          (string-suffix? "utils.scm" source))))
 512
 513 (test-assert "package-source-derivation, local-file"
 514   (let* ((file    (local-file "../guix/base32.scm"))
 515          (package (package (inherit (dummy-package "p"))
 516                     (source file)))
 517          (source  (package-source-derivation %store
 518                                              (package-source package))))
 519     (and (store-path? source)
 520          (string-suffix? "base32.scm" source)
 521          (valid-path? %store source)
 522          (equal? (call-with-input-file source get-bytevector-all)
 523                  (call-with-input-file
 524                      (search-path %load-path "guix/base32.scm")
 525                    get-bytevector-all)))))
 526
 527 (test-equal "package-source-derivation, origin, sha512"
 528   "hello"
 529   (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
 530          (builder (add-text-to-store %store "my-fixed-builder.sh"
 531                                      "echo -n hello > $out" '()))
 532          (method  (lambda* (url hash-algo hash #:optional name
 533                                 #:rest rest)
 534                     (and (eq? hash-algo 'sha512)
 535                          (raw-derivation name bash (list builder)
 536                                          #:sources (list builder)
 537                                          #:hash hash
 538                                          #:hash-algo hash-algo))))
 539          (source  (origin
 540                     (method method)
 541                     (uri "unused://")
 542                     (file-name "origin-sha512")
 543                     (hash (content-hash
 544                            (gcrypt:bytevector-hash (string->utf8 "hello")
 545                                                    (gcrypt:lookup-hash-algorithm
 546                                                     'sha512))
 547                            sha512))))
 548          (drv    (package-source-derivation %store source))
 549          (output (derivation->output-path drv)))
 550     (build-derivations %store (list drv))
 551     (call-with-input-file output get-string-all)))
 552
 553 (test-equal "package-source-derivation, origin, sha3-512"
 554   "hello, sha3"
 555   (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
 556          (builder (add-text-to-store %store "my-fixed-builder.sh"
 557                                      "echo -n hello, sha3 > $out" '()))
 558          (method  (lambda* (url hash-algo hash #:optional name
 559                                 #:rest rest)
 560                     (and (eq? hash-algo 'sha3-512)
 561                          (raw-derivation name bash (list builder)
 562                                          #:sources (list builder)
 563                                          #:hash hash
 564                                          #:hash-algo hash-algo))))
 565          (source  (origin
 566                     (method method)
 567                     (uri "unused://")
 568                     (file-name "origin-sha3")
 569                     (hash (content-hash
 570                            (gcrypt:bytevector-hash (string->utf8 "hello, sha3")
 571                                                    (gcrypt:lookup-hash-algorithm
 572                                                     'sha3-512))
 573                            sha3-512))))
 574          (drv    (package-source-derivation %store source))
 575          (output (derivation->output-path drv)))
 576     (build-derivations %store (list drv))
 577     (call-with-input-file output get-string-all)))
 578
 579 (unless (network-reachable?) (test-skip 1))
 580 (test-equal "package-source-derivation, snippet"
 581   "OK"
 582   (let* ((source (bootstrap-origin
 583                   (origin
 584                     (inherit (bootstrap-guile-origin (%current-system)))
 585                     (patch-inputs
 586                      `(("tar" ,%bootstrap-coreutils&co)
 587                        ("xz" ,%bootstrap-coreutils&co)
 588                        ("patch" ,%bootstrap-coreutils&co)))
 589                     (patch-guile %bootstrap-guile)
 590                     (modules '((guix build utils)))
 591                     (snippet '(begin
 592                                 ;; We end up in 'bin', because it's the first
 593                                 ;; directory, alphabetically.  Not a very good
 594                                 ;; example but hey.
 595                                 (chmod "." #o777)
 596                                 (symlink "guile" "guile-rocks")
 597                                 (copy-recursively "../share/guile/2.0/scripts"
 598                                                   "scripts")
 599
 600                                 ;; Make sure '.file_list' can be created.
 601                                 (chmod ".." #o777))))))
 602          (package (package (inherit (dummy-package "with-snippet"))
 603                     (source source)
 604                     (build-system trivial-build-system)
 605                     (inputs
 606                      `(("tar" ,(search-bootstrap-binary "tar"
 607                                                         (%current-system)))
 608                        ("xz"  ,(search-bootstrap-binary "xz"
 609                                                         (%current-system)))))
 610                     (arguments
 611                      `(#:guile ,%bootstrap-guile
 612                        #:modules ((guix build utils))
 613                        #:builder
 614                        (begin
 615                          (use-modules (guix build utils))
 616                          (let ((tar    (assoc-ref %build-inputs "tar"))
 617                                (xz     (assoc-ref %build-inputs "xz"))
 618                                (source (assoc-ref %build-inputs "source")))
 619                            (invoke tar "xvf" source
 620                                    "--use-compress-program" xz)
 621                            (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
 622                                         (file-exists? "bin/scripts/compile.scm"))
 623                              (error "the snippet apparently failed"))
 624                            (let ((out (assoc-ref %outputs "out")))
 625                              (call-with-output-file out
 626                                (lambda (p)
 627                                  (display "OK" p))))
 628                            #t))))))
 629          (drv    (package-derivation %store package))
 630          (out    (derivation->output-path drv)))
 631     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 632          (call-with-input-file out get-string-all))))
 633
 634 (test-assert "return value"
 635   (let ((drv (package-derivation %store (dummy-package "p"))))
 636     (and (derivation? drv)
 637          (file-exists? (derivation-file-name drv)))))
 638
 639 (test-assert "package-output"
 640   (let* ((package  (dummy-package "p"))
 641          (drv      (package-derivation %store package)))
 642     (and (derivation? drv)
 643          (string=? (derivation->output-path drv)
 644                    (package-output %store package "out")))))
 645
 646 (test-equal "patch not found yields a run-time error"
 647   '("~a: patch not found\n" "does-not-exist.patch")
 648   (guard (c ((formatted-message? c)
 649              (cons (formatted-message-string c)
 650                    (formatted-message-arguments c))))
 651     (let ((p (package
 652                (inherit (dummy-package "p"))
 653                (source (origin
 654                          (method (const #f))
 655                          (uri "http://whatever")
 656                          (patches
 657                           (list (search-patch "does-not-exist.patch")))
 658                          (sha256
 659                           (base32
 660                            "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
 661       (package-derivation %store p)
 662       #f)))
 663
 664 (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
 665   (test-equal "&package-input-error"
 666     (list dummy (current-module))
 667     (guard (c ((package-input-error? c)
 668                (list (package-error-package c)
 669                      (package-error-invalid-input c))))
 670       (package-derivation %store dummy))))
 671
 672 (test-assert "reference to non-existent output"
 673   ;; See <http://bugs.gnu.org/19630>.
 674   (parameterize ((%graft? #f))
 675     (let* ((dep (dummy-package "dep"))
 676            (p   (dummy-package "p"
 677                   (inputs `(("dep" ,dep "non-existent"))))))
 678       (guard (c ((derivation-missing-output-error? c)
 679                  (and (string=? (derivation-missing-output c) "non-existent")
 680                       (equal? (package-derivation %store dep)
 681                               (derivation-error-derivation c)))))
 682         (package-derivation %store p)))))
 683
 684 (test-assert "trivial"
 685   (let* ((p (package (inherit (dummy-package "trivial"))
 686               (build-system trivial-build-system)
 687               (source #f)
 688               (arguments
 689                `(#:guile ,%bootstrap-guile
 690                  #:builder
 691                  (begin
 692                    (mkdir %output)
 693                    (call-with-output-file (string-append %output "/test")
 694                      (lambda (p)
 695                        (display '(hello guix) p)))
 696                    #t)))))
 697          (d (package-derivation %store p)))
 698     (and (build-derivations %store (list d))
 699          (let ((p (pk 'drv d (derivation->output-path d))))
 700            (equal? '(hello guix)
 701                    (call-with-input-file (string-append p "/test") read))))))
 702
 703 (test-assert "trivial with local file as input"
 704   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 705          (p (package (inherit (dummy-package "trivial-with-input-file"))
 706               (build-system trivial-build-system)
 707               (source #f)
 708               (arguments
 709                `(#:guile ,%bootstrap-guile
 710                  #:builder (begin
 711                              (copy-file (assoc-ref %build-inputs "input")
 712                                         %output)
 713                              #t)))
 714               (inputs `(("input" ,i)))))
 715          (d (package-derivation %store p)))
 716     (and (build-derivations %store (list d))
 717          (let ((p (pk 'drv d (derivation->output-path d))))
 718            (equal? (call-with-input-file p get-bytevector-all)
 719                    (call-with-input-file i get-bytevector-all))))))
 720
 721 (test-assert "trivial with source"
 722   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 723          (p (package (inherit (dummy-package "trivial-with-source"))
 724               (build-system trivial-build-system)
 725               (source i)
 726               (arguments
 727                `(#:guile ,%bootstrap-guile
 728                  #:builder (begin
 729                              (copy-file (assoc-ref %build-inputs "source")
 730                                         %output)
 731                              #t)))))
 732          (d (package-derivation %store p)))
 733     (and (build-derivations %store (list d))
 734          (let ((p (derivation->output-path d)))
 735            (equal? (call-with-input-file p get-bytevector-all)
 736                    (call-with-input-file i get-bytevector-all))))))
 737
 738 (test-assert "trivial with system-dependent input"
 739   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 740               (build-system trivial-build-system)
 741               (source #f)
 742               (arguments
 743                `(#:guile ,%bootstrap-guile
 744                  #:modules ((guix build utils))
 745                  #:builder
 746                  (begin
 747                    (use-modules (guix build utils))
 748                    (let ((out  (assoc-ref %outputs "out"))
 749                          (bash (assoc-ref %build-inputs "bash")))
 750                      (invoke bash "-c"
 751                              (format #f "echo hello > ~a" out))))))
 752               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 753                                                           (%current-system)))))))
 754          (d (package-derivation %store p)))
 755     (and (build-derivations %store (list d))
 756          (let ((p (pk 'drv d (derivation->output-path d))))
 757            (eq? 'hello (call-with-input-file p read))))))
 758
 759 (test-assert "trivial with #:allowed-references"
 760   (let* ((p (package
 761               (inherit (dummy-package "trivial"))
 762               (build-system trivial-build-system)
 763               (arguments
 764                `(#:guile ,%bootstrap-guile
 765                  #:allowed-references (,%bootstrap-guile)
 766                  #:builder
 767                  (begin
 768                    (mkdir %output)
 769                    ;; The reference to itself isn't allowed so building it
 770                    ;; should fail.
 771                    (symlink %output (string-append %output "/self"))
 772                    #t)))))
 773          (d (package-derivation %store p)))
 774     (guard (c ((store-protocol-error? c) #t))
 775       (build-derivations %store (list d))
 776       #f)))
 777
 778 (test-assert "search paths"
 779   (let* ((p (make-prompt-tag "return-search-paths"))
 780          (s (build-system
 781              (name 'raw)
 782              (description "Raw build system with direct store access")
 783              (lower (lambda* (name #:key source inputs system target
 784                                    #:allow-other-keys)
 785                       (bag
 786                         (name name)
 787                         (system system) (target target)
 788                         (build-inputs inputs)
 789                         (build
 790                          (lambda* (store name inputs
 791                                          #:key outputs system search-paths)
 792                            search-paths)))))))
 793          (x (list (search-path-specification
 794                    (variable "GUILE_LOAD_PATH")
 795                    (files '("share/guile/site/2.0")))
 796                   (search-path-specification
 797                    (variable "GUILE_LOAD_COMPILED_PATH")
 798                    (files '("share/guile/site/2.0")))))
 799          (a (package (inherit (dummy-package "guile"))
 800               (build-system s)
 801               (native-search-paths x)))
 802          (b (package (inherit (dummy-package "guile-foo"))
 803               (build-system s)
 804               (inputs `(("guile" ,a)))))
 805          (c (package (inherit (dummy-package "guile-bar"))
 806               (build-system s)
 807               (inputs `(("guile" ,a)
 808                         ("guile-foo" ,b))))))
 809     (let-syntax ((collect (syntax-rules ()
 810                             ((_ body ...)
 811                              (call-with-prompt p
 812                                (lambda ()
 813                                  body ...)
 814                                (lambda (k search-paths)
 815                                  search-paths))))))
 816       (and (null? (collect (package-derivation %store a)))
 817            (equal? x (collect (package-derivation %store b)))
 818            (equal? x (collect (package-derivation %store c)))))))
 819
 820 (test-assert "package-transitive-native-search-paths"
 821   (let* ((sp (lambda (name)
 822                (list (search-path-specification
 823                       (variable name)
 824                       (files '("foo/bar"))))))
 825          (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
 826          (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
 827          (p2 (dummy-package "p2"
 828                (native-search-paths (sp "PATH2"))
 829                (inputs `(("p0" ,p0)))
 830                (propagated-inputs `(("p1" ,p1)))))
 831          (p3 (dummy-package "p3"
 832                (native-search-paths (sp "PATH3"))
 833                (native-inputs `(("p0" ,p0)))
 834                (propagated-inputs `(("p2" ,p2))))))
 835     (lset= string=?
 836            '("PATH1" "PATH2" "PATH3")
 837            (map search-path-specification-variable
 838                 (package-transitive-native-search-paths p3)))))
 839
 840 (test-assert "package-cross-derivation"
 841   (let ((drv (package-cross-derivation %store (dummy-package "p")
 842                                        "mips64el-linux-gnu")))
 843     (and (derivation? drv)
 844          (file-exists? (derivation-file-name drv)))))
 845
 846 (test-assert "package-cross-derivation, trivial-build-system"
 847   (let ((p (package (inherit (dummy-package "p"))
 848              (build-system trivial-build-system)
 849              (arguments '(#:builder (exit 1))))))
 850     (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
 851       (derivation? drv))))
 852
 853 (test-assert "package-cross-derivation, no cross builder"
 854   (let* ((b (build-system (inherit trivial-build-system)
 855               (lower (const #f))))
 856          (p (package (inherit (dummy-package "p"))
 857               (build-system b))))
 858     (guard (c ((package-cross-build-system-error? c)
 859                (eq? (package-error-package c) p)))
 860       (package-cross-derivation %store p "mips64el-linux-gnu")
 861       #f)))
 862
 863 ;; XXX: The next two tests can trigger builds when the distro defines
 864 ;; replacements on core packages, so they're disable for lack of a better
 865 ;; solution.
 866
 867 ;; (test-equal "package-derivation, direct graft"
 868 ;;   (package-derivation %store gnu-make #:graft? #f)
 869 ;;   (let ((p (package (inherit coreutils)
 870 ;;              (replacement gnu-make))))
 871 ;;     (package-derivation %store p #:graft? #t)))
 872
 873 ;; (test-equal "package-cross-derivation, direct graft"
 874 ;;   (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
 875 ;;                             #:graft? #f)
 876 ;;   (let ((p (package (inherit coreutils)
 877 ;;              (replacement gnu-make))))
 878 ;;     (package-cross-derivation %store p "mips64el-linux-gnu"
 879 ;;                               #:graft? #t)))
 880
 881 (test-assert "package-grafts, indirect grafts"
 882   (let* ((new   (dummy-package "dep"
 883                   (arguments '(#:implicit-inputs? #f))))
 884          (dep   (package (inherit new) (version "0.0")))
 885          (dep*  (package (inherit dep) (replacement new)))
 886          (dummy (dummy-package "dummy"
 887                   (arguments '(#:implicit-inputs? #f))
 888                   (inputs `(("dep" ,dep*))))))
 889     (equal? (package-grafts %store dummy)
 890             (list (graft
 891                     (origin (package-derivation %store dep))
 892                     (replacement (package-derivation %store new)))))))
 893
 894 ;; XXX: This test would require building the cross toolchain just to see if it
 895 ;; needs grafting, which is obviously too expensive, and thus disabled.
 896 ;;
 897 ;; (test-assert "package-grafts, indirect grafts, cross"
 898 ;;   (let* ((new    (dummy-package "dep"
 899 ;;                    (arguments '(#:implicit-inputs? #f))))
 900 ;;          (dep    (package (inherit new) (version "0.0")))
 901 ;;          (dep*   (package (inherit dep) (replacement new)))
 902 ;;          (dummy  (dummy-package "dummy"
 903 ;;                    (arguments '(#:implicit-inputs? #f))
 904 ;;                    (inputs `(("dep" ,dep*)))))
 905 ;;          (target "mips64el-linux-gnu"))
 906 ;;     ;; XXX: There might be additional grafts, for instance if the distro
 907 ;;     ;; defines replacements for core packages like Perl.
 908 ;;     (member (graft
 909 ;;               (origin (package-cross-derivation %store dep target))
 910 ;;               (replacement
 911 ;;                (package-cross-derivation %store new target)))
 912 ;;             (package-grafts %store dummy #:target target))))
 913
 914 (test-assert "package-grafts, indirect grafts, propagated inputs"
 915   (let* ((new   (dummy-package "dep"
 916                   (arguments '(#:implicit-inputs? #f))))
 917          (dep   (package (inherit new) (version "0.0")))
 918          (dep*  (package (inherit dep) (replacement new)))
 919          (prop  (dummy-package "propagated"
 920                   (propagated-inputs `(("dep" ,dep*)))
 921                   (arguments '(#:implicit-inputs? #f))))
 922          (dummy (dummy-package "dummy"
 923                   (arguments '(#:implicit-inputs? #f))
 924                   (inputs `(("prop" ,prop))))))
 925     (equal? (package-grafts %store dummy)
 926             (list (graft
 927                     (origin (package-derivation %store dep))
 928                     (replacement (package-derivation %store new)))))))
 929
 930 (test-assert "package-grafts, same replacement twice"
 931   (let* ((new  (dummy-package "dep"
 932                  (version "1")
 933                  (arguments '(#:implicit-inputs? #f))))
 934          (dep  (package (inherit new) (version "0") (replacement new)))
 935          (p1   (dummy-package "intermediate1"
 936                  (arguments '(#:implicit-inputs? #f))
 937                  (inputs `(("dep" ,dep)))))
 938          (p2   (dummy-package "intermediate2"
 939                  (arguments '(#:implicit-inputs? #f))
 940                  ;; Here we copy DEP to have an equivalent package that is not
 941                  ;; 'eq?' to DEP.  This is similar to what happens with
 942                  ;; 'package-with-explicit-inputs' & co.
 943                  (inputs `(("dep" ,(package (inherit dep)))))))
 944          (p3   (dummy-package "final"
 945                  (arguments '(#:implicit-inputs? #f))
 946                  (inputs `(("p1" ,p1) ("p2" ,p2))))))
 947     (equal? (package-grafts %store p3)
 948             (list (graft
 949                     (origin (package-derivation %store
 950                                                 (package (inherit dep)
 951                                                          (replacement #f))))
 952                     (replacement (package-derivation %store new)))))))
 953
 954 (test-assert "package-grafts, dependency on several outputs"
 955   ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
 956   (letrec* ((p0  (dummy-package "p0"
 957                    (version "1.0")
 958                    (replacement p0*)
 959                    (arguments '(#:implicit-inputs? #f))
 960                    (outputs '("out" "lib"))))
 961             (p0* (package (inherit p0) (version "1.1")))
 962             (p1  (dummy-package "p1"
 963                    (arguments '(#:implicit-inputs? #f))
 964                    (inputs `(("p0" ,p0)
 965                              ("p0:lib" ,p0 "lib"))))))
 966     (lset= equal? (pk (package-grafts %store p1))
 967            (list (graft
 968                    (origin (package-derivation %store p0))
 969                    (origin-output "out")
 970                    (replacement (package-derivation %store p0*))
 971                    (replacement-output "out"))
 972                  (graft
 973                    (origin (package-derivation %store p0))
 974                    (origin-output "lib")
 975                    (replacement (package-derivation %store p0*))
 976                    (replacement-output "lib"))))))
 977
 978 (test-assert "replacement also grafted"
 979   ;; We build a DAG as below, where dotted arrows represent replacements and
 980   ;; solid arrows represent dependencies:
 981   ;;
 982   ;;  P1  ·············>  P1R
 983   ;;  |\__________________.
 984   ;;  v                   v
 985   ;;  P2  ·············>  P2R
 986   ;;  |
 987   ;;  v
 988   ;;  P3
 989   ;;
 990   ;; We want to make sure that:
 991   ;;   grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
 992   ;; where:
 993   ;;   (A,B) is a graft to replace A by B
 994   ;;   grafted(DRV,G) denoted DRV with graft G applied
 995   (let* ((p1r (dummy-package "P1"
 996                 (build-system trivial-build-system)
 997                 (arguments
 998                  `(#:guile ,%bootstrap-guile
 999                    #:builder (let ((out (assoc-ref %outputs "out")))
1000                                (mkdir out)
1001                                (call-with-output-file
1002                                    (string-append out "/replacement")
1003                                  (const #t)))))))
1004          (p1  (package
1005                 (inherit p1r) (name "p1") (replacement p1r)
1006                 (arguments
1007                  `(#:guile ,%bootstrap-guile
1008                    #:builder (begin
1009                                (mkdir (assoc-ref %outputs "out"))
1010                                #t)))))
1011          (p2r (dummy-package "P2"
1012                 (build-system trivial-build-system)
1013                 (inputs `(("p1" ,p1)))
1014                 (arguments
1015                  `(#:guile ,%bootstrap-guile
1016                    #:builder (let ((out (assoc-ref %outputs "out")))
1017                                (mkdir out)
1018                                (chdir out)
1019                                (symlink (assoc-ref %build-inputs "p1") "p1")
1020                                (call-with-output-file (string-append out "/replacement")
1021                                  (const #t)))))))
1022          (p2  (package
1023                 (inherit p2r) (name "p2") (replacement p2r)
1024                 (arguments
1025                  `(#:guile ,%bootstrap-guile
1026                    #:builder (let ((out (assoc-ref %outputs "out")))
1027                                (mkdir out)
1028                                (chdir out)
1029                                (symlink (assoc-ref %build-inputs "p1")
1030                                         "p1")
1031                                #t)))))
1032          (p3  (dummy-package "p3"
1033                 (build-system trivial-build-system)
1034                 (inputs `(("p2" ,p2)))
1035                 (arguments
1036                  `(#:guile ,%bootstrap-guile
1037                    #:builder (let ((out (assoc-ref %outputs "out")))
1038                                (mkdir out)
1039                                (chdir out)
1040                                (symlink (assoc-ref %build-inputs "p2")
1041                                         "p2")
1042                                #t))))))
1043     (lset= equal?
1044            (package-grafts %store p3)
1045            (list (graft
1046                    (origin (package-derivation %store p1 #:graft? #f))
1047                    (replacement (package-derivation %store p1r)))
1048                  (graft
1049                    (origin (package-derivation %store p2 #:graft? #f))
1050                    (replacement
1051                     (package-derivation %store p2r #:graft? #t)))))))
1052
1053 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
1054 ;;; find out about their run-time dependencies, so this test is no longer
1055 ;;; applicable since it would trigger a full rebuild.
1056 ;;
1057 ;; (test-assert "package-derivation, indirect grafts"
1058 ;;   (let* ((new   (dummy-package "dep"
1059 ;;                   (arguments '(#:implicit-inputs? #f))))
1060 ;;          (dep   (package (inherit new) (version "0.0")))
1061 ;;          (dep*  (package (inherit dep) (replacement new)))
1062 ;;          (dummy (dummy-package "dummy"
1063 ;;                   (arguments '(#:implicit-inputs? #f))
1064 ;;                   (inputs `(("dep" ,dep*)))))
1065 ;;          (guile (package-derivation %store (canonical-package guile-2.0)
1066 ;;                                     #:graft? #f)))
1067 ;;     (equal? (package-derivation %store dummy)
1068 ;;             (graft-derivation %store
1069 ;;                               (package-derivation %store dummy #:graft? #f)
1070 ;;                               (package-grafts %store dummy)
1071
1072 ;;                               ;; Use the same Guile as 'package-derivation'.
1073 ;;                               #:guile guile))))
1074
1075 (test-equal "package->bag"
1076   `("foo86-hurd" #f (,(package-source gnu-make))
1077     (,(canonical-package glibc)) (,(canonical-package coreutils)))
1078   (let ((bag (package->bag gnu-make "foo86-hurd")))
1079     (list (bag-system bag) (bag-target bag)
1080           (assoc-ref (bag-build-inputs bag) "source")
1081           (assoc-ref (bag-build-inputs bag) "libc")
1082           (assoc-ref (bag-build-inputs bag) "coreutils"))))
1083
1084 (test-assert "package->bag, sensitivity to %current-target-system"
1085   ;; https://bugs.gnu.org/41713
1086   (let* ((lower (lambda* (name #:key system target inputs native-inputs
1087                                #:allow-other-keys)
1088                   (and (not target)
1089                        (bag (name name) (system system) (target target)
1090                             (build-inputs native-inputs)
1091                             (host-inputs inputs)
1092                             (build (lambda* (store name inputs
1093                                                    #:key system target
1094                                                    #:allow-other-keys)
1095                                      (build-expression->derivation
1096                                       store "foo" '(mkdir %output))))))))
1097          (bs    (build-system
1098                   (name 'build-system-without-cross-compilation)
1099                   (description "Does not support cross compilation.")
1100                   (lower lower)))
1101          (dep   (dummy-package "dep" (build-system bs)))
1102          (pkg   (dummy-package "example"
1103                   (native-inputs `(("dep" ,dep)))))
1104          (do-not-build (lambda (continue store lst . _) lst)))
1105     (equal? (with-build-handler do-not-build
1106               (parameterize ((%current-target-system "powerpc64le-linux-gnu")
1107                              (%graft? #t))
1108                 (package-cross-derivation %store pkg
1109                                           (%current-target-system)
1110                                           #:graft? #t)))
1111             (with-build-handler do-not-build
1112               (package-cross-derivation %store
1113                                         (package (inherit pkg))
1114                                         "powerpc64le-linux-gnu"
1115                                         #:graft? #t)))))
1116
1117 (test-equal "package->bag, cross-compilation"
1118   `(,(%current-system) "foo86-hurd"
1119     (,(package-source gnu-make))
1120     (,(canonical-package glibc)) (,(canonical-package coreutils)))
1121   (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
1122     (list (bag-system bag) (bag-target bag)
1123           (assoc-ref (bag-build-inputs bag) "source")
1124           (assoc-ref (bag-build-inputs bag) "libc")
1125           (assoc-ref (bag-build-inputs bag) "coreutils"))))
1126
1127 (test-assert "package->bag, propagated inputs"
1128   (let* ((dep    (dummy-package "dep"))
1129          (prop   (dummy-package "prop"
1130                    (propagated-inputs `(("dep" ,dep)))))
1131          (dummy  (dummy-package "dummy"
1132                    (inputs `(("prop" ,prop)))))
1133          (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
1134     (match (assoc "dep" inputs)
1135       (("dep" package)
1136        (eq? package dep)))))
1137
1138 (test-assert "package->bag, sensitivity to %current-system"
1139   (let* ((dep (dummy-package "dep"
1140                 (propagated-inputs (if (string=? (%current-system)
1141                                                  "i586-gnu")
1142                                        `(("libxml2" ,libxml2))
1143                                        '()))))
1144          (pkg (dummy-package "foo"
1145                 (native-inputs `(("dep" ,dep)))))
1146          (bag (package->bag pkg (%current-system) "i586-gnu")))
1147     (equal? (parameterize ((%current-system "x86_64-linux"))
1148               (bag-transitive-inputs bag))
1149             (parameterize ((%current-system "i586-gnu"))
1150               (bag-transitive-inputs bag)))))
1151
1152 (test-assert "package->bag, sensitivity to %current-target-system"
1153   (let* ((dep (dummy-package "dep"
1154                 (propagated-inputs (if (%current-target-system)
1155                                        `(("libxml2" ,libxml2))
1156                                        '()))))
1157          (pkg (dummy-package "foo"
1158                 (native-inputs `(("dep" ,dep)))))
1159          (bag (package->bag pkg (%current-system) "foo86-hurd")))
1160     (equal? (parameterize ((%current-target-system "foo64-gnu"))
1161               (bag-transitive-inputs bag))
1162             (parameterize ((%current-target-system #f))
1163               (bag-transitive-inputs bag)))))
1164
1165 (test-assert "bag->derivation"
1166   (parameterize ((%graft? #f))
1167     (let ((bag (package->bag gnu-make))
1168           (drv (package-derivation %store gnu-make)))
1169       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
1170         (equal? drv (bag->derivation %store bag))))))
1171
1172 (test-assert "bag->derivation, cross-compilation"
1173   (parameterize ((%graft? #f))
1174     (let* ((target "mips64el-linux-gnu")
1175            (bag    (package->bag gnu-make (%current-system) target))
1176            (drv    (package-cross-derivation %store gnu-make target)))
1177       (parameterize ((%current-system "foox86-hurd") ;should have no effect
1178                      (%current-target-system "foo64-linux-gnu"))
1179         (equal? drv (bag->derivation %store bag))))))
1180
1181 (when (or (not (network-reachable?)) (shebang-too-long?))
1182   (test-skip 1))
1183 (test-assert "GNU Make, bootstrap"
1184   ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the
1185   ;; test doesn't last for too long.
1186   (let ((gnu-make gnu-make-for-tests))
1187     (and (package? gnu-make)
1188          (or (location? (package-location gnu-make))
1189              (not (package-location gnu-make)))
1190          (let* ((drv (package-derivation %store gnu-make))
1191                 (out (derivation->output-path drv)))
1192            (and (build-derivations %store (list drv))
1193                 (file-exists? (string-append out "/bin/make")))))))
1194
1195 (test-equal "package-mapping"
1196   42
1197   (let* ((dep       (dummy-package "chbouib"
1198                       (native-inputs `(("x" ,grep)))))
1199          (p0        (dummy-package "example"
1200                       (source 77)
1201                       (inputs `(("foo" ,coreutils)
1202                                 ("bar" ,grep)
1203                                 ("baz" ,dep)))))
1204          (transform (lambda (p)
1205                       (package (inherit p) (source 42))))
1206          (rewrite   (package-mapping transform))
1207          (p1        (rewrite p0))
1208          (bag0      (package->bag p0))
1209          (bag1      (package->bag p1)))
1210     (and (eq? p1 (rewrite p0))
1211          (eqv? 42 (package-source p1))
1212
1213          ;; Implicit inputs should be left unchanged (skip "source", "foo",
1214          ;; "bar", and "baz" in this comparison).
1215          (equal? (drop (bag-direct-inputs bag0) 4)
1216                  (drop (bag-direct-inputs bag1) 4))
1217
1218          (match (package-inputs p1)
1219            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1220             (and (eq? dep1 (rewrite coreutils))   ;memoization
1221                  (eq? dep2 (rewrite grep))
1222                  (eq? dep3 (rewrite dep))
1223                  (eqv? 42
1224                        (package-source dep1) (package-source dep2)
1225                        (package-source dep3))
1226                  (match (package-native-inputs dep3)
1227                    ((("x" dep))
1228                     (and (eq? dep (rewrite grep))
1229                          (package-source dep))))))))))
1230
1231 (test-equal "package-mapping, deep"
1232   '(42)
1233   (let* ((p0        (dummy-package "example"
1234                       (inputs `(("foo" ,coreutils)
1235                                 ("bar" ,grep)))))
1236          (transform (lambda (p)
1237                       (package (inherit p) (source 42))))
1238          (rewrite   (package-mapping transform #:deep? #t))
1239          (p1        (rewrite p0))
1240          (bag       (package->bag p1)))
1241     (and (eq? p1 (rewrite p0))
1242          (match (bag-direct-inputs bag)
1243            ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1)
1244             (and (eq? dep1 (rewrite coreutils))   ;memoization
1245                  (eq? dep2 (rewrite grep))
1246                  (= 42 (package-source dep1))
1247                  (= 42 (package-source dep2))
1248
1249                  ;; Check that implicit inputs of P0 also got rewritten.
1250                  (delete-duplicates
1251                   (map (match-lambda
1252                          ((_ package . _)
1253                           (package-source package)))
1254                        rest))))))))
1255
1256 (test-assert "package-input-rewriting"
1257   (let* ((dep     (dummy-package "chbouib"
1258                     (native-inputs `(("x" ,grep)))))
1259          (p0      (dummy-package "example"
1260                     (inputs `(("foo" ,coreutils)
1261                               ("bar" ,grep)
1262                               ("baz" ,dep)))))
1263          (rewrite (package-input-rewriting `((,coreutils . ,sed)
1264                                              (,grep . ,findutils))
1265                                            (cut string-append "r-" <>)
1266                                            #:deep? #f))
1267          (p1      (rewrite p0))
1268          (p2      (rewrite p0)))
1269     (and (not (eq? p1 p0))
1270          (eq? p1 p2)                              ;memoization
1271          (string=? "r-example" (package-name p1))
1272          (match (package-inputs p1)
1273            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1274             (and (eq? dep1 sed)
1275                  (eq? dep2 findutils)
1276                  (string=? (package-name dep3) "r-chbouib")
1277                  (eq? dep3 (rewrite dep))         ;memoization
1278                  (match (package-native-inputs dep3)
1279                    ((("x" dep))
1280                     (eq? dep findutils))))))
1281
1282          ;; Make sure implicit inputs were left unchanged.
1283          (equal? (drop (bag-direct-inputs (package->bag p1)) 3)
1284                  (drop (bag-direct-inputs (package->bag p0)) 3)))))
1285
1286 (test-eq "package-input-rewriting, deep"
1287   (derivation-file-name (package-derivation %store sed))
1288   (let* ((p0      (dummy-package "chbouib"
1289                     (build-system python-build-system)
1290                     (arguments `(#:python ,python))))
1291          (rewrite (package-input-rewriting `((,python . ,sed))))
1292          (p1      (rewrite p0)))
1293     (match (bag-direct-inputs (package->bag p1))
1294       ((("python" python) _ ...)
1295        (derivation-file-name (package-derivation %store python))))))
1296
1297 (test-assert "package-input-rewriting/spec"
1298   (let* ((dep     (dummy-package "chbouib"
1299                     (native-inputs `(("x" ,grep)))))
1300          (p0      (dummy-package "example"
1301                     (inputs `(("foo" ,coreutils)
1302                               ("bar" ,grep)
1303                               ("baz" ,dep)))))
1304          (rewrite (package-input-rewriting/spec
1305                    `(("coreutils" . ,(const sed))
1306                      ("grep" . ,(const findutils)))
1307                    #:deep? #f))
1308          (p1      (rewrite p0))
1309          (p2      (rewrite p0)))
1310     (and (not (eq? p1 p0))
1311          (eq? p1 p2)                              ;memoization
1312          (string=? "example" (package-name p1))
1313          (match (package-inputs p1)
1314            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1315             (and (string=? (package-full-name dep1)
1316                            (package-full-name sed))
1317                  (string=? (package-full-name dep2)
1318                            (package-full-name findutils))
1319                  (string=? (package-name dep3) "chbouib")
1320                  (eq? dep3 (rewrite dep))         ;memoization
1321                  (match (package-native-inputs dep3)
1322                    ((("x" dep))
1323                     (string=? (package-full-name dep)
1324                               (package-full-name findutils)))))))
1325
1326          ;; Make sure implicit inputs were left unchanged.
1327          (equal? (drop (bag-direct-inputs (package->bag p1)) 3)
1328                  (drop (bag-direct-inputs (package->bag p0)) 3)))))
1329
1330 (test-assert "package-input-rewriting/spec, partial match"
1331   (let* ((dep     (dummy-package "chbouib"
1332                     (version "1")
1333                     (native-inputs `(("x" ,grep)))))
1334          (p0      (dummy-package "example"
1335                     (inputs `(("foo" ,coreutils)
1336                               ("bar" ,dep)))))
1337          (rewrite (package-input-rewriting/spec
1338                    `(("chbouib@123" . ,(const sed)) ;not matched
1339                      ("grep" . ,(const findutils)))
1340                    #:deep? #f))
1341          (p1      (rewrite p0)))
1342     (and (not (eq? p1 p0))
1343          (string=? "example" (package-name p1))
1344          (match (package-inputs p1)
1345            ((("foo" dep1) ("bar" dep2))
1346             (and (string=? (package-full-name dep1)
1347                            (package-full-name coreutils))
1348                  (eq? dep2 (rewrite dep))         ;memoization
1349                  (match (package-native-inputs dep2)
1350                    ((("x" dep))
1351                     (string=? (package-full-name dep)
1352                               (package-full-name findutils))))))))))
1353
1354 (test-assert "package-input-rewriting/spec, deep"
1355   (let* ((dep     (dummy-package "chbouib"))
1356          (p0      (dummy-package "example"
1357                     (build-system gnu-build-system)
1358                     (inputs `(("dep" ,dep)))))
1359          (rewrite (package-input-rewriting/spec
1360                    `(("tar"  . ,(const sed))
1361                      ("gzip" . ,(const findutils)))))
1362          (p1      (rewrite p0))
1363          (p2      (rewrite p0)))
1364     (and (not (eq? p1 p0))
1365          (eq? p1 p2)                              ;memoization
1366          (string=? "example" (package-name p1))
1367          (match (package-inputs p1)
1368            ((("dep" dep1))
1369             (and (string=? (package-full-name dep1)
1370                            (package-full-name dep))
1371                  (eq? dep1 (rewrite dep)))))      ;memoization
1372
1373          ;; Make sure implicit inputs were replaced.
1374          (match (bag-direct-inputs (package->bag p1))
1375            ((("dep" dep1) ("tar" tar) ("gzip" gzip) _ ...)
1376             (and (eq? dep1 (rewrite dep))
1377                  (string=? (package-full-name tar)
1378                            (package-full-name sed))
1379                  (string=? (package-full-name gzip)
1380                            (package-full-name findutils))))))))
1381
1382 (test-assert "package-input-rewriting/spec, no duplicates"
1383   ;; Ensure that deep input rewriting does not forget implicit inputs.  Doing
1384   ;; so could lead to duplicates in a package's inputs: in the example below,
1385   ;; P0's transitive inputs would contain one rewritten "python" and one
1386   ;; original "python".  These two "python" packages are thus not 'eq?' but
1387   ;; they lower to the same derivation.  See <https://bugs.gnu.org/42156>,
1388   ;; which can be reproduced by passing #:deep? #f.
1389   (let* ((dep0    (dummy-package "dep0"
1390                     (build-system trivial-build-system)
1391                     (propagated-inputs `(("python" ,python)))))
1392          (p0      (dummy-package "chbouib"
1393                     (build-system python-build-system)
1394                     (arguments `(#:python ,python))
1395                     (inputs `(("dep0" ,dep0)))))
1396          (rewrite (package-input-rewriting/spec '() #:deep? #t))
1397          (p1      (rewrite p0))
1398          (bag1    (package->bag p1))
1399          (pythons (filter-map (match-lambda
1400                                 (("python" python) python)
1401                                 (_ #f))
1402                               (bag-transitive-inputs bag1))))
1403     (match (delete-duplicates pythons eq?)
1404       ((p) (eq? p (rewrite python))))))
1405
1406 (test-equal "package-input-rewriting/spec, graft"
1407   (derivation-file-name (package-derivation %store sed))
1408
1409   ;; Make sure replacements are rewritten.
1410   (let* ((dep0 (dummy-package "dep"
1411                  (version "1")
1412                  (build-system trivial-build-system)
1413                  (inputs `(("coreutils" ,coreutils)))))
1414          (dep1 (dummy-package "dep"
1415                  (version "0")
1416                  (build-system trivial-build-system)
1417                  (replacement dep0)))
1418          (p0   (dummy-package "p"
1419                  (build-system trivial-build-system)
1420                  (inputs `(("dep" ,dep1)))))
1421          (rewrite (package-input-rewriting/spec
1422                    `(("coreutils" . ,(const sed)))))
1423          (p1      (rewrite p0)))
1424     (match (package-inputs p1)
1425       ((("dep" dep))
1426        (match (package-inputs (package-replacement dep))
1427          ((("coreutils" coreutils))
1428           ;; COREUTILS is not 'eq?' to SED, so the most reliable way to check
1429           ;; for equality is to lower to a derivation.
1430           (derivation-file-name
1431            (package-derivation %store coreutils))))))))
1432
1433 (test-assert "package-with-c-toolchain"
1434   (let* ((dep (dummy-package "chbouib"
1435                 (build-system gnu-build-system)
1436                 (native-inputs `(("x" ,grep)))))
1437          (p0  (dummy-package "thingie"
1438                 (build-system gnu-build-system)
1439                 (inputs `(("foo" ,grep)
1440                           ("bar" ,dep)))))
1441          (tc  (dummy-package "my-toolchain"))
1442          (p1  (package-with-c-toolchain p0 `(("toolchain" ,tc)))))
1443     (define toolchain-packages
1444       '("gcc" "binutils" "glibc" "ld-wrapper"))
1445
1446     (match (bag-build-inputs (package->bag p1))
1447       ((("foo" foo) ("bar" bar) (_ (= package-name packages) . _) ...)
1448        (and (not (any (cut member <> packages) toolchain-packages))
1449             (member "my-toolchain" packages)
1450             (eq? foo grep)
1451             (eq? bar dep))))))
1452
1453 (test-equal "package-patched-vulnerabilities"
1454   '(("CVE-2015-1234")
1455     ("CVE-2016-1234" "CVE-2018-4567")
1456     ())
1457   (let ((p1 (dummy-package "pi"
1458               (source (dummy-origin
1459                        (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
1460         (p2 (dummy-package "pi"
1461               (source (dummy-origin
1462                        (patches (list
1463                                  "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
1464         (p3 (dummy-package "pi" (source (dummy-origin)))))
1465     (map package-patched-vulnerabilities
1466          (list p1 p2 p3))))
1467
1468 (test-eq "fold-packages" hello
1469   (fold-packages (lambda (p r)
1470                    (if (string=? (package-name p) "hello")
1471                        p
1472                        r))
1473                  #f))
1474
1475 (test-assert "fold-packages, hidden package"
1476   ;; There are two public variables providing "guile@2.0" ('guile-final' in
1477   ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
1478   ;; should show up.
1479   (match (fold-packages (lambda (p r)
1480                           (if (and (string=? (package-name p) "guile")
1481                                    (string-prefix? "2.0"
1482                                                    (package-version p)))
1483                               (cons p r)
1484                               r))
1485                         '())
1486     ((one)
1487      (eq? one guile-2.0))))
1488
1489 (test-assert "fold-available-packages with/without cache"
1490   (let ()
1491     (define no-cache
1492       (fold-available-packages (lambda* (name version result #:rest rest)
1493                                  (cons (cons* name version rest)
1494                                        result))
1495                                '()))
1496
1497     (define from-cache
1498       (call-with-temporary-directory
1499        (lambda (cache)
1500          (generate-package-cache cache)
1501          (mock ((guix describe) current-profile (const cache))
1502                (mock ((gnu packages) cache-is-authoritative? (const #t))
1503                      (fold-available-packages (lambda* (name version result
1504                                                              #:rest rest)
1505                                                 (cons (cons* name version rest)
1506                                                       result))
1507                                               '()))))))
1508
1509     (define (find-duplicates l)
1510       (match l
1511         (() '())
1512         ((head . tail)
1513          (if (member head tail)
1514              (cons head (find-duplicates tail))
1515              (find-duplicates tail)))))
1516
1517     (pk (find-duplicates from-cache))
1518     (and (equal? (delete-duplicates from-cache) from-cache)
1519          (lset= equal? no-cache from-cache))))
1520
1521 (test-assert "find-packages-by-name"
1522   (match (find-packages-by-name "hello")
1523     (((? (cut eq? hello <>))) #t)
1524     (wrong (pk 'find-packages-by-name wrong #f))))
1525
1526 (test-assert "find-packages-by-name with version"
1527   (match (find-packages-by-name "hello" (package-version hello))
1528     (((? (cut eq? hello <>))) #t)
1529     (wrong (pk 'find-packages-by-name wrong #f))))
1530
1531 (test-equal "find-packages-by-name with cache"
1532   (find-packages-by-name "guile")
1533   (call-with-temporary-directory
1534    (lambda (cache)
1535      (generate-package-cache cache)
1536      (mock ((guix describe) current-profile (const cache))
1537            (mock ((gnu packages) cache-is-authoritative? (const #t))
1538                  (find-packages-by-name "guile"))))))
1539
1540 (test-equal "find-packages-by-name + version, with cache"
1541   (find-packages-by-name "guile" "2")
1542   (call-with-temporary-directory
1543    (lambda (cache)
1544      (generate-package-cache cache)
1545      (mock ((guix describe) current-profile (const cache))
1546            (mock ((gnu packages) cache-is-authoritative? (const #t))
1547                  (find-packages-by-name "guile" "2"))))))
1548
1549 (test-assert "--search-paths with pattern"
1550   ;; Make sure 'guix package --search-paths' correctly reports environment
1551   ;; variables when file patterns are used (in particular, it must follow
1552   ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
1553   ;; libxml2 package specification, which contains such a definition.
1554   (let* ((p1 (package
1555                (name "foo") (version "0") (source #f)
1556                (build-system trivial-build-system)
1557                (arguments
1558                 `(#:guile ,%bootstrap-guile
1559                   #:modules ((guix build utils))
1560                   #:builder (begin
1561                               (use-modules (guix build utils))
1562                               (let ((out (assoc-ref %outputs "out")))
1563                                 (mkdir-p (string-append out "/xml/bar/baz"))
1564                                 (call-with-output-file
1565                                     (string-append out "/xml/bar/baz/catalog.xml")
1566                                   (lambda (port)
1567                                     (display "xml? wat?!" port)))
1568                                 #t))))
1569                (synopsis #f) (description #f)
1570                (home-page #f) (license #f)))
1571          (p2 (package
1572                ;; Provide a fake libxml2 to avoid building the real one.  This
1573                ;; is OK because 'guix package' gets search path specifications
1574                ;; from the same-named package found in the distro.
1575                (name "libxml2") (version "0.0.0") (source #f)
1576                (build-system trivial-build-system)
1577                (arguments
1578                 `(#:guile ,%bootstrap-guile
1579                   #:builder (begin
1580                               (mkdir (assoc-ref %outputs "out"))
1581                               #t)))
1582                (native-search-paths (package-native-search-paths libxml2))
1583                (synopsis #f) (description #f)
1584                (home-page #f) (license #f)))
1585          (prof (run-with-store %store
1586                  (profile-derivation
1587                   (manifest (map package->manifest-entry
1588                                  (list p1 p2)))
1589                   #:hooks '()
1590                   #:locales? #f)
1591                  #:guile-for-build (%guile-for-build))))
1592     (build-derivations %store (list prof))
1593     (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
1594                           (regexp-quote (derivation->output-path prof)))
1595                   (with-output-to-string
1596                     (lambda ()
1597                       (guix-package "-p" (derivation->output-path prof)
1598                                     "--search-paths"))))))
1599
1600 (test-assert "--search-paths with single-item search path"
1601   ;; Make sure 'guix package --search-paths' correctly reports environment
1602   ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
1603   ;; separator, meaning that the first match wins.
1604   (let* ((p1 (dummy-package "foo"
1605                (build-system trivial-build-system)
1606                (arguments
1607                 `(#:guile ,%bootstrap-guile
1608                   #:modules ((guix build utils))
1609                   #:builder (begin
1610                               (use-modules (guix build utils))
1611                               (let ((out (assoc-ref %outputs "out")))
1612                                 (mkdir-p (string-append out "/etc/ssl/certs"))
1613                                 (call-with-output-file
1614                                     (string-append
1615                                      out "/etc/ssl/certs/ca-certificates.crt")
1616                                   (const #t))))))))
1617          (p2 (package (inherit p1) (name "bar")))
1618          (p3 (dummy-package "git"
1619                ;; Provide a fake Git to avoid building the real one.
1620                (build-system trivial-build-system)
1621                (arguments
1622                 `(#:guile ,%bootstrap-guile
1623                   #:builder (begin
1624                               (mkdir (assoc-ref %outputs "out"))
1625                               #t)))
1626                (native-search-paths (package-native-search-paths git))))
1627          (prof1 (run-with-store %store
1628                   (profile-derivation
1629                    (packages->manifest (list p1 p3))
1630                    #:hooks '()
1631                    #:locales? #f)
1632                   #:guile-for-build (%guile-for-build)))
1633          (prof2 (run-with-store %store
1634                   (profile-derivation
1635                    (packages->manifest (list p2 p3))
1636                    #:hooks '()
1637                    #:locales? #f)
1638                   #:guile-for-build (%guile-for-build))))
1639     (build-derivations %store (list prof1 prof2))
1640     (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
1641                           (regexp-quote (derivation->output-path prof1)))
1642                   (with-output-to-string
1643                     (lambda ()
1644                       (guix-package "-p" (derivation->output-path prof1)
1645                                     "-p" (derivation->output-path prof2)
1646                                     "--search-paths"))))))
1647
1648 (test-equal "specification->package when not found"
1649   'quit
1650   (catch 'quit
1651     (lambda ()
1652       ;; This should call 'leave', producing an error message.
1653       (specification->package "this-package-does-not-exist"))
1654     (lambda (key . args)
1655       key)))
1656
1657 (test-equal "specification->package+output"
1658   `((,coreutils "out") (,coreutils "debug"))
1659   (list (call-with-values (lambda ()
1660                             (specification->package+output "coreutils"))
1661           list)
1662         (call-with-values (lambda ()
1663                             (specification->package+output "coreutils:debug"))
1664           list)))
1665
1666 (test-equal "specification->package+output invalid output"
1667   'error
1668   (catch 'quit
1669     (lambda ()
1670       (specification->package+output "coreutils:does-not-exist"))
1671     (lambda _
1672       'error)))
1673
1674 (test-equal "specification->package+output no default output"
1675   `(,coreutils #f)
1676   (call-with-values
1677     (lambda ()
1678       (specification->package+output "coreutils" #f))
1679     list))
1680
1681 (test-equal "specification->package+output invalid output, no default"
1682   'error
1683   (catch 'quit
1684     (lambda ()
1685       (specification->package+output "coreutils:does-not-exist" #f))
1686     (lambda _
1687       'error)))
1688
1689 (test-equal "find-package-locations"
1690   (map (lambda (package)
1691          (cons (package-version package)
1692                (package-location package)))
1693        (find-packages-by-name "guile"))
1694   (find-package-locations "guile"))
1695
1696 (test-equal "find-package-locations with cache"
1697   (map (lambda (package)
1698          (cons (package-version package)
1699                (package-location package)))
1700        (find-packages-by-name "guile"))
1701   (call-with-temporary-directory
1702    (lambda (cache)
1703      (generate-package-cache cache)
1704      (mock ((guix describe) current-profile (const cache))
1705            (mock ((gnu packages) cache-is-authoritative? (const #t))
1706                  (find-package-locations "guile"))))))
1707
1708 (test-equal "specification->location"
1709   (package-location (specification->package "guile@2"))
1710   (specification->location "guile@2"))
1711
1712 (test-end "packages")
1713
1714 ;;; Local Variables:
1715 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
1716 ;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1)
1717 ;;; End: