tests/packages.scm

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