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