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