tests/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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-newest-available-packages
 100                      (const vlist-null))
 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-newest-available-packages
 113                      (const (vhash-cons "foo" (list "2" new) vlist-null)))
 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-newest-available-packages
 130                      (const (vhash-cons "foo" (list "2" dep) vlist-null)))
 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-equal "origin-actual-file-name"
 253   "foo-1.tar.gz"
 254   (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
 255     (origin-actual-file-name o)))
 256
 257 (test-equal "origin-actual-file-name, file-name"
 258   "foo-1.tar.gz"
 259   (let ((o (dummy-origin
 260             (uri "http://www.example.com/tarball")
 261             (file-name "foo-1.tar.gz"))))
 262     (origin-actual-file-name o)))
 263
 264 (let* ((o (dummy-origin))
 265        (u (dummy-origin))
 266        (i (dummy-origin))
 267        (a (dummy-package "a"))
 268        (b (dummy-package "b"
 269             (inputs `(("a" ,a) ("i" ,i)))))
 270        (c (package (inherit b) (source o)))
 271        (d (dummy-package "d"
 272             (build-system trivial-build-system)
 273             (source u) (inputs `(("c" ,c))))))
 274   (test-assert "package-direct-sources, no source"
 275     (null? (package-direct-sources a)))
 276   (test-equal "package-direct-sources, #f source"
 277     (list i)
 278     (package-direct-sources b))
 279   (test-equal "package-direct-sources, not input source"
 280     (list u)
 281     (package-direct-sources d))
 282   (test-assert "package-direct-sources"
 283     (let ((s (package-direct-sources c)))
 284       (and (= (length (pk 's-sources s)) 2)
 285            (member o s)
 286            (member i s))))
 287   (test-assert "package-transitive-sources"
 288     (let ((s (package-transitive-sources d)))
 289       (and (= (length (pk 'd-sources s)) 3)
 290            (member o s)
 291            (member i s)
 292            (member u s)))))
 293
 294 (test-assert "transitive-input-references"
 295   (let* ((a (dummy-package "a"))
 296          (b (dummy-package "b"))
 297          (c (dummy-package "c"
 298               (inputs `(("a" ,a)))
 299               (propagated-inputs `(("boo" ,b)))))
 300          (d (dummy-package "d"
 301               (inputs `(("c*" ,c)))))
 302          (keys (map (match-lambda
 303                       (('assoc-ref 'l key)
 304                        key))
 305                     (pk 'refs (transitive-input-references
 306                                'l (package-inputs d))))))
 307     (and (= (length keys) 2)
 308          (member "c*" keys)
 309          (member "boo" keys))))
 310
 311 (test-equal "package-transitive-supported-systems, implicit inputs"
 312   %supported-systems
 313
 314   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 315   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 316   (let ((p (dummy-package "foo"
 317              (build-system gnu-build-system)
 318              (supported-systems
 319               `("does-not-exist" "foobar" ,@%supported-systems)))))
 320     (package-transitive-supported-systems p)))
 321
 322 (test-assert "supported-package?"
 323   (let ((p (dummy-package "foo"
 324              (build-system gnu-build-system)
 325              (supported-systems '("x86_64-linux" "does-not-exist")))))
 326     (and (supported-package? p "x86_64-linux")
 327          (not (supported-package? p "does-not-exist"))
 328          (not (supported-package? p "i686-linux")))))
 329
 330 (test-skip (if (not %store) 8 0))
 331
 332 (test-assert "package-source-derivation, file"
 333   (let* ((file    (search-path %load-path "guix.scm"))
 334          (package (package (inherit (dummy-package "p"))
 335                     (source file)))
 336          (source  (package-source-derivation %store
 337                                              (package-source package))))
 338     (and (store-path? source)
 339          (valid-path? %store source)
 340          (equal? (call-with-input-file source get-bytevector-all)
 341                  (call-with-input-file file get-bytevector-all)))))
 342
 343 (test-assert "package-source-derivation, store path"
 344   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 345                                 (search-path %load-path "guix.scm")))
 346          (package (package (inherit (dummy-package "p"))
 347                     (source file)))
 348          (source  (package-source-derivation %store
 349                                              (package-source package))))
 350     (string=? file source)))
 351
 352 (test-assert "package-source-derivation, indirect store path"
 353   (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
 354                                 (dirname (search-path %load-path
 355                                                       "guix/build/utils.scm"))))
 356          (package (package (inherit (dummy-package "p"))
 357                     (source (string-append dir "/utils.scm"))))
 358          (source  (package-source-derivation %store
 359                                              (package-source package))))
 360     (and (direct-store-path? source)
 361          (string-suffix? "utils.scm" source))))
 362
 363 (test-assert "package-source-derivation, local-file"
 364   (let* ((file    (local-file "../guix/base32.scm"))
 365          (package (package (inherit (dummy-package "p"))
 366                     (source file)))
 367          (source  (package-source-derivation %store
 368                                              (package-source package))))
 369     (and (store-path? source)
 370          (string-suffix? "base32.scm" source)
 371          (valid-path? %store source)
 372          (equal? (call-with-input-file source get-bytevector-all)
 373                  (call-with-input-file
 374                      (search-path %load-path "guix/base32.scm")
 375                    get-bytevector-all)))))
 376
 377 (unless (network-reachable?) (test-skip 1))
 378 (test-equal "package-source-derivation, snippet"
 379   "OK"
 380   (let* ((source (bootstrap-origin
 381                   (origin
 382                     (inherit (bootstrap-guile-origin (%current-system)))
 383                     (patch-inputs
 384                      `(("tar" ,%bootstrap-coreutils&co)
 385                        ("xz" ,%bootstrap-coreutils&co)
 386                        ("patch" ,%bootstrap-coreutils&co)))
 387                     (patch-guile %bootstrap-guile)
 388                     (modules '((guix build utils)))
 389                     (snippet '(begin
 390                                 ;; We end up in 'bin', because it's the first
 391                                 ;; directory, alphabetically.  Not a very good
 392                                 ;; example but hey.
 393                                 (chmod "." #o777)
 394                                 (symlink "guile" "guile-rocks")
 395                                 (copy-recursively "../share/guile/2.0/scripts"
 396                                                   "scripts")
 397
 398                                 ;; Make sure '.file_list' can be created.
 399                                 (chmod ".." #o777))))))
 400          (package (package (inherit (dummy-package "with-snippet"))
 401                     (source source)
 402                     (build-system trivial-build-system)
 403                     (inputs
 404                      `(("tar" ,(search-bootstrap-binary "tar"
 405                                                         (%current-system)))
 406                        ("xz"  ,(search-bootstrap-binary "xz"
 407                                                         (%current-system)))))
 408                     (arguments
 409                      `(#:guile ,%bootstrap-guile
 410                        #:modules ((guix build utils))
 411                        #:builder
 412                        (begin
 413                          (use-modules (guix build utils))
 414                          (let ((tar    (assoc-ref %build-inputs "tar"))
 415                                (xz     (assoc-ref %build-inputs "xz"))
 416                                (source (assoc-ref %build-inputs "source")))
 417                            (invoke tar "xvf" source
 418                                    "--use-compress-program" xz)
 419                            (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
 420                                         (file-exists? "bin/scripts/compile.scm"))
 421                              (error "the snippet apparently failed"))
 422                            (let ((out (assoc-ref %outputs "out")))
 423                              (call-with-output-file out
 424                                (lambda (p)
 425                                  (display "OK" p))))
 426                            #t))))))
 427          (drv    (package-derivation %store package))
 428          (out    (derivation->output-path drv)))
 429     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 430          (call-with-input-file out get-string-all))))
 431
 432 (test-assert "return value"
 433   (let ((drv (package-derivation %store (dummy-package "p"))))
 434     (and (derivation? drv)
 435          (file-exists? (derivation-file-name drv)))))
 436
 437 (test-assert "package-output"
 438   (let* ((package  (dummy-package "p"))
 439          (drv      (package-derivation %store package)))
 440     (and (derivation? drv)
 441          (string=? (derivation->output-path drv)
 442                    (package-output %store package "out")))))
 443
 444 (test-assert "patch not found yields a run-time error"
 445   (guard (c ((condition-has-type? c &message)
 446              (and (string-contains (condition-message c)
 447                                    "does-not-exist.patch")
 448                   (string-contains (condition-message c)
 449                                    "not found"))))
 450     (let ((p (package
 451                (inherit (dummy-package "p"))
 452                (source (origin
 453                          (method (const #f))
 454                          (uri "http://whatever")
 455                          (patches
 456                           (list (search-patch "does-not-exist.patch")))
 457                          (sha256
 458                           (base32
 459                            "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
 460       (package-derivation %store p)
 461       #f)))
 462
 463 (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
 464   (test-equal "&package-input-error"
 465     (list dummy (current-module))
 466     (guard (c ((package-input-error? c)
 467                (list (package-error-package c)
 468                      (package-error-invalid-input c))))
 469       (package-derivation %store dummy))))
 470
 471 (test-assert "reference to non-existent output"
 472   ;; See <http://bugs.gnu.org/19630>.
 473   (parameterize ((%graft? #f))
 474     (let* ((dep (dummy-package "dep"))
 475            (p   (dummy-package "p"
 476                   (inputs `(("dep" ,dep "non-existent"))))))
 477       (guard (c ((derivation-missing-output-error? c)
 478                  (and (string=? (derivation-missing-output c) "non-existent")
 479                       (equal? (package-derivation %store dep)
 480                               (derivation-error-derivation c)))))
 481         (package-derivation %store p)))))
 482
 483 (test-assert "trivial"
 484   (let* ((p (package (inherit (dummy-package "trivial"))
 485               (build-system trivial-build-system)
 486               (source #f)
 487               (arguments
 488                `(#:guile ,%bootstrap-guile
 489                  #:builder
 490                  (begin
 491                    (mkdir %output)
 492                    (call-with-output-file (string-append %output "/test")
 493                      (lambda (p)
 494                        (display '(hello guix) p)))
 495                    #t)))))
 496          (d (package-derivation %store p)))
 497     (and (build-derivations %store (list d))
 498          (let ((p (pk 'drv d (derivation->output-path d))))
 499            (equal? '(hello guix)
 500                    (call-with-input-file (string-append p "/test") read))))))
 501
 502 (test-assert "trivial with local file as input"
 503   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 504          (p (package (inherit (dummy-package "trivial-with-input-file"))
 505               (build-system trivial-build-system)
 506               (source #f)
 507               (arguments
 508                `(#:guile ,%bootstrap-guile
 509                  #:builder (begin
 510                              (copy-file (assoc-ref %build-inputs "input")
 511                                         %output)
 512                              #t)))
 513               (inputs `(("input" ,i)))))
 514          (d (package-derivation %store p)))
 515     (and (build-derivations %store (list d))
 516          (let ((p (pk 'drv d (derivation->output-path d))))
 517            (equal? (call-with-input-file p get-bytevector-all)
 518                    (call-with-input-file i get-bytevector-all))))))
 519
 520 (test-assert "trivial with source"
 521   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 522          (p (package (inherit (dummy-package "trivial-with-source"))
 523               (build-system trivial-build-system)
 524               (source i)
 525               (arguments
 526                `(#:guile ,%bootstrap-guile
 527                  #:builder (begin
 528                              (copy-file (assoc-ref %build-inputs "source")
 529                                         %output)
 530                              #t)))))
 531          (d (package-derivation %store p)))
 532     (and (build-derivations %store (list d))
 533          (let ((p (derivation->output-path d)))
 534            (equal? (call-with-input-file p get-bytevector-all)
 535                    (call-with-input-file i get-bytevector-all))))))
 536
 537 (test-assert "trivial with system-dependent input"
 538   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 539               (build-system trivial-build-system)
 540               (source #f)
 541               (arguments
 542                `(#:guile ,%bootstrap-guile
 543                  #:modules ((guix build utils))
 544                  #:builder
 545                  (begin
 546                    (use-modules (guix build utils))
 547                    (let ((out  (assoc-ref %outputs "out"))
 548                          (bash (assoc-ref %build-inputs "bash")))
 549                      (invoke bash "-c"
 550                              (format #f "echo hello > ~a" out))))))
 551               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 552                                                           (%current-system)))))))
 553          (d (package-derivation %store p)))
 554     (and (build-derivations %store (list d))
 555          (let ((p (pk 'drv d (derivation->output-path d))))
 556            (eq? 'hello (call-with-input-file p read))))))
 557
 558 (test-assert "trivial with #:allowed-references"
 559   (let* ((p (package
 560               (inherit (dummy-package "trivial"))
 561               (build-system trivial-build-system)
 562               (arguments
 563                `(#:guile ,%bootstrap-guile
 564                  #:allowed-references (,%bootstrap-guile)
 565                  #:builder
 566                  (begin
 567                    (mkdir %output)
 568                    ;; The reference to itself isn't allowed so building it
 569                    ;; should fail.
 570                    (symlink %output (string-append %output "/self"))
 571                    #t)))))
 572          (d (package-derivation %store p)))
 573     (guard (c ((nix-protocol-error? c) #t))
 574       (build-derivations %store (list d))
 575       #f)))
 576
 577 (test-assert "search paths"
 578   (let* ((p (make-prompt-tag "return-search-paths"))
 579          (s (build-system
 580              (name 'raw)
 581              (description "Raw build system with direct store access")
 582              (lower (lambda* (name #:key source inputs system target
 583                                    #:allow-other-keys)
 584                       (bag
 585                         (name name)
 586                         (system system) (target target)
 587                         (build-inputs inputs)
 588                         (build
 589                          (lambda* (store name inputs
 590                                          #:key outputs system search-paths)
 591                            search-paths)))))))
 592          (x (list (search-path-specification
 593                    (variable "GUILE_LOAD_PATH")
 594                    (files '("share/guile/site/2.0")))
 595                   (search-path-specification
 596                    (variable "GUILE_LOAD_COMPILED_PATH")
 597                    (files '("share/guile/site/2.0")))))
 598          (a (package (inherit (dummy-package "guile"))
 599               (build-system s)
 600               (native-search-paths x)))
 601          (b (package (inherit (dummy-package "guile-foo"))
 602               (build-system s)
 603               (inputs `(("guile" ,a)))))
 604          (c (package (inherit (dummy-package "guile-bar"))
 605               (build-system s)
 606               (inputs `(("guile" ,a)
 607                         ("guile-foo" ,b))))))
 608     (let-syntax ((collect (syntax-rules ()
 609                             ((_ body ...)
 610                              (call-with-prompt p
 611                                (lambda ()
 612                                  body ...)
 613                                (lambda (k search-paths)
 614                                  search-paths))))))
 615       (and (null? (collect (package-derivation %store a)))
 616            (equal? x (collect (package-derivation %store b)))
 617            (equal? x (collect (package-derivation %store c)))))))
 618
 619 (test-assert "package-transitive-native-search-paths"
 620   (let* ((sp (lambda (name)
 621                (list (search-path-specification
 622                       (variable name)
 623                       (files '("foo/bar"))))))
 624          (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
 625          (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
 626          (p2 (dummy-package "p2"
 627                (native-search-paths (sp "PATH2"))
 628                (inputs `(("p0" ,p0)))
 629                (propagated-inputs `(("p1" ,p1)))))
 630          (p3 (dummy-package "p3"
 631                (native-search-paths (sp "PATH3"))
 632                (native-inputs `(("p0" ,p0)))
 633                (propagated-inputs `(("p2" ,p2))))))
 634     (lset= string=?
 635            '("PATH1" "PATH2" "PATH3")
 636            (map search-path-specification-variable
 637                 (package-transitive-native-search-paths p3)))))
 638
 639 (test-assert "package-cross-derivation"
 640   (let ((drv (package-cross-derivation %store (dummy-package "p")
 641                                        "mips64el-linux-gnu")))
 642     (and (derivation? drv)
 643          (file-exists? (derivation-file-name drv)))))
 644
 645 (test-assert "package-cross-derivation, trivial-build-system"
 646   (let ((p (package (inherit (dummy-package "p"))
 647              (build-system trivial-build-system)
 648              (arguments '(#:builder (exit 1))))))
 649     (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
 650       (derivation? drv))))
 651
 652 (test-assert "package-cross-derivation, no cross builder"
 653   (let* ((b (build-system (inherit trivial-build-system)
 654               (lower (const #f))))
 655          (p (package (inherit (dummy-package "p"))
 656               (build-system b))))
 657     (guard (c ((package-cross-build-system-error? c)
 658                (eq? (package-error-package c) p)))
 659       (package-cross-derivation %store p "mips64el-linux-gnu")
 660       #f)))
 661
 662 ;; XXX: The next two tests can trigger builds when the distro defines
 663 ;; replacements on core packages, so they're disable for lack of a better
 664 ;; solution.
 665
 666 ;; (test-equal "package-derivation, direct graft"
 667 ;;   (package-derivation %store gnu-make #:graft? #f)
 668 ;;   (let ((p (package (inherit coreutils)
 669 ;;              (replacement gnu-make))))
 670 ;;     (package-derivation %store p #:graft? #t)))
 671
 672 ;; (test-equal "package-cross-derivation, direct graft"
 673 ;;   (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
 674 ;;                             #:graft? #f)
 675 ;;   (let ((p (package (inherit coreutils)
 676 ;;              (replacement gnu-make))))
 677 ;;     (package-cross-derivation %store p "mips64el-linux-gnu"
 678 ;;                               #:graft? #t)))
 679
 680 (test-assert "package-grafts, indirect grafts"
 681   (let* ((new   (dummy-package "dep"
 682                   (arguments '(#:implicit-inputs? #f))))
 683          (dep   (package (inherit new) (version "0.0")))
 684          (dep*  (package (inherit dep) (replacement new)))
 685          (dummy (dummy-package "dummy"
 686                   (arguments '(#:implicit-inputs? #f))
 687                   (inputs `(("dep" ,dep*))))))
 688     (equal? (package-grafts %store dummy)
 689             (list (graft
 690                     (origin (package-derivation %store dep))
 691                     (replacement (package-derivation %store new)))))))
 692
 693 ;; XXX: This test would require building the cross toolchain just to see if it
 694 ;; needs grafting, which is obviously too expensive, and thus disabled.
 695 ;;
 696 ;; (test-assert "package-grafts, indirect grafts, cross"
 697 ;;   (let* ((new    (dummy-package "dep"
 698 ;;                    (arguments '(#:implicit-inputs? #f))))
 699 ;;          (dep    (package (inherit new) (version "0.0")))
 700 ;;          (dep*   (package (inherit dep) (replacement new)))
 701 ;;          (dummy  (dummy-package "dummy"
 702 ;;                    (arguments '(#:implicit-inputs? #f))
 703 ;;                    (inputs `(("dep" ,dep*)))))
 704 ;;          (target "mips64el-linux-gnu"))
 705 ;;     ;; XXX: There might be additional grafts, for instance if the distro
 706 ;;     ;; defines replacements for core packages like Perl.
 707 ;;     (member (graft
 708 ;;               (origin (package-cross-derivation %store dep target))
 709 ;;               (replacement
 710 ;;                (package-cross-derivation %store new target)))
 711 ;;             (package-grafts %store dummy #:target target))))
 712
 713 (test-assert "package-grafts, indirect grafts, propagated inputs"
 714   (let* ((new   (dummy-package "dep"
 715                   (arguments '(#:implicit-inputs? #f))))
 716          (dep   (package (inherit new) (version "0.0")))
 717          (dep*  (package (inherit dep) (replacement new)))
 718          (prop  (dummy-package "propagated"
 719                   (propagated-inputs `(("dep" ,dep*)))
 720                   (arguments '(#:implicit-inputs? #f))))
 721          (dummy (dummy-package "dummy"
 722                   (arguments '(#:implicit-inputs? #f))
 723                   (inputs `(("prop" ,prop))))))
 724     (equal? (package-grafts %store dummy)
 725             (list (graft
 726                     (origin (package-derivation %store dep))
 727                     (replacement (package-derivation %store new)))))))
 728
 729 (test-assert "package-grafts, same replacement twice"
 730   (let* ((new  (dummy-package "dep"
 731                  (version "1")
 732                  (arguments '(#:implicit-inputs? #f))))
 733          (dep  (package (inherit new) (version "0") (replacement new)))
 734          (p1   (dummy-package "intermediate1"
 735                  (arguments '(#:implicit-inputs? #f))
 736                  (inputs `(("dep" ,dep)))))
 737          (p2   (dummy-package "intermediate2"
 738                  (arguments '(#:implicit-inputs? #f))
 739                  ;; Here we copy DEP to have an equivalent package that is not
 740                  ;; 'eq?' to DEP.  This is similar to what happens with
 741                  ;; 'package-with-explicit-inputs' & co.
 742                  (inputs `(("dep" ,(package (inherit dep)))))))
 743          (p3   (dummy-package "final"
 744                  (arguments '(#:implicit-inputs? #f))
 745                  (inputs `(("p1" ,p1) ("p2" ,p2))))))
 746     (equal? (package-grafts %store p3)
 747             (list (graft
 748                     (origin (package-derivation %store
 749                                                 (package (inherit dep)
 750                                                          (replacement #f))))
 751                     (replacement (package-derivation %store new)))))))
 752
 753 (test-assert "replacement also grafted"
 754   ;; We build a DAG as below, where dotted arrows represent replacements and
 755   ;; solid arrows represent dependencies:
 756   ;;
 757   ;;  P1  ·············>  P1R
 758   ;;  |\__________________.
 759   ;;  v                   v
 760   ;;  P2  ·············>  P2R
 761   ;;  |
 762   ;;  v
 763   ;;  P3
 764   ;;
 765   ;; We want to make sure that:
 766   ;;   grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
 767   ;; where:
 768   ;;   (A,B) is a graft to replace A by B
 769   ;;   grafted(DRV,G) denoted DRV with graft G applied
 770   (let* ((p1r (dummy-package "P1"
 771                 (build-system trivial-build-system)
 772                 (arguments
 773                  `(#:guile ,%bootstrap-guile
 774                    #:builder (let ((out (assoc-ref %outputs "out")))
 775                                (mkdir out)
 776                                (call-with-output-file
 777                                    (string-append out "/replacement")
 778                                  (const #t)))))))
 779          (p1  (package
 780                 (inherit p1r) (name "p1") (replacement p1r)
 781                 (arguments
 782                  `(#:guile ,%bootstrap-guile
 783                    #:builder (begin
 784                                (mkdir (assoc-ref %outputs "out"))
 785                                #t)))))
 786          (p2r (dummy-package "P2"
 787                 (build-system trivial-build-system)
 788                 (inputs `(("p1" ,p1)))
 789                 (arguments
 790                  `(#:guile ,%bootstrap-guile
 791                    #:builder (let ((out (assoc-ref %outputs "out")))
 792                                (mkdir out)
 793                                (chdir out)
 794                                (symlink (assoc-ref %build-inputs "p1") "p1")
 795                                (call-with-output-file (string-append out "/replacement")
 796                                  (const #t)))))))
 797          (p2  (package
 798                 (inherit p2r) (name "p2") (replacement p2r)
 799                 (arguments
 800                  `(#:guile ,%bootstrap-guile
 801                    #:builder (let ((out (assoc-ref %outputs "out")))
 802                                (mkdir out)
 803                                (chdir out)
 804                                (symlink (assoc-ref %build-inputs "p1")
 805                                         "p1")
 806                                #t)))))
 807          (p3  (dummy-package "p3"
 808                 (build-system trivial-build-system)
 809                 (inputs `(("p2" ,p2)))
 810                 (arguments
 811                  `(#:guile ,%bootstrap-guile
 812                    #:builder (let ((out (assoc-ref %outputs "out")))
 813                                (mkdir out)
 814                                (chdir out)
 815                                (symlink (assoc-ref %build-inputs "p2")
 816                                         "p2")
 817                                #t))))))
 818     (lset= equal?
 819            (package-grafts %store p3)
 820            (list (graft
 821                    (origin (package-derivation %store p1 #:graft? #f))
 822                    (replacement (package-derivation %store p1r)))
 823                  (graft
 824                    (origin (package-derivation %store p2 #:graft? #f))
 825                    (replacement
 826                     (package-derivation %store p2r #:graft? #t)))))))
 827
 828 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
 829 ;;; find out about their run-time dependencies, so this test is no longer
 830 ;;; applicable since it would trigger a full rebuild.
 831 ;;
 832 ;; (test-assert "package-derivation, indirect grafts"
 833 ;;   (let* ((new   (dummy-package "dep"
 834 ;;                   (arguments '(#:implicit-inputs? #f))))
 835 ;;          (dep   (package (inherit new) (version "0.0")))
 836 ;;          (dep*  (package (inherit dep) (replacement new)))
 837 ;;          (dummy (dummy-package "dummy"
 838 ;;                   (arguments '(#:implicit-inputs? #f))
 839 ;;                   (inputs `(("dep" ,dep*)))))
 840 ;;          (guile (package-derivation %store (canonical-package guile-2.0)
 841 ;;                                     #:graft? #f)))
 842 ;;     (equal? (package-derivation %store dummy)
 843 ;;             (graft-derivation %store
 844 ;;                               (package-derivation %store dummy #:graft? #f)
 845 ;;                               (package-grafts %store dummy)
 846
 847 ;;                               ;; Use the same Guile as 'package-derivation'.
 848 ;;                               #:guile guile))))
 849
 850 (test-equal "package->bag"
 851   `("foo86-hurd" #f (,(package-source gnu-make))
 852     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 853   (let ((bag (package->bag gnu-make "foo86-hurd")))
 854     (list (bag-system bag) (bag-target bag)
 855           (assoc-ref (bag-build-inputs bag) "source")
 856           (assoc-ref (bag-build-inputs bag) "libc")
 857           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 858
 859 (test-equal "package->bag, cross-compilation"
 860   `(,(%current-system) "foo86-hurd"
 861     (,(package-source gnu-make))
 862     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 863   (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
 864     (list (bag-system bag) (bag-target bag)
 865           (assoc-ref (bag-build-inputs bag) "source")
 866           (assoc-ref (bag-build-inputs bag) "libc")
 867           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 868
 869 (test-assert "package->bag, propagated inputs"
 870   (let* ((dep    (dummy-package "dep"))
 871          (prop   (dummy-package "prop"
 872                    (propagated-inputs `(("dep" ,dep)))))
 873          (dummy  (dummy-package "dummy"
 874                    (inputs `(("prop" ,prop)))))
 875          (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
 876     (match (assoc "dep" inputs)
 877       (("dep" package)
 878        (eq? package dep)))))
 879
 880 (test-assert "bag->derivation"
 881   (parameterize ((%graft? #f))
 882     (let ((bag (package->bag gnu-make))
 883           (drv (package-derivation %store gnu-make)))
 884       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
 885         (equal? drv (bag->derivation %store bag))))))
 886
 887 (test-assert "bag->derivation, cross-compilation"
 888   (parameterize ((%graft? #f))
 889     (let* ((target "mips64el-linux-gnu")
 890            (bag    (package->bag gnu-make (%current-system) target))
 891            (drv    (package-cross-derivation %store gnu-make target)))
 892       (parameterize ((%current-system "foox86-hurd") ;should have no effect
 893                      (%current-target-system "foo64-linux-gnu"))
 894         (equal? drv (bag->derivation %store bag))))))
 895
 896 (when (or (not (network-reachable?)) (shebang-too-long?))
 897   (test-skip 1))
 898 (test-assert "GNU Make, bootstrap"
 899   ;; GNU Make is the first program built during bootstrap; we choose it
 900   ;; here so that the test doesn't last for too long.
 901   (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0)))
 902     (and (package? gnu-make)
 903          (or (location? (package-location gnu-make))
 904              (not (package-location gnu-make)))
 905          (let* ((drv (package-derivation %store gnu-make))
 906                 (out (derivation->output-path drv)))
 907            (and (build-derivations %store (list drv))
 908                 (file-exists? (string-append out "/bin/make")))))))
 909
 910 (test-equal "package-mapping"
 911   42
 912   (let* ((dep       (dummy-package "chbouib"
 913                       (native-inputs `(("x" ,grep)))))
 914          (p0        (dummy-package "example"
 915                       (inputs `(("foo" ,coreutils)
 916                                 ("bar" ,grep)
 917                                 ("baz" ,dep)))))
 918          (transform (lambda (p)
 919                       (package (inherit p) (source 42))))
 920          (rewrite   (package-mapping transform))
 921          (p1        (rewrite p0)))
 922     (and (eq? p1 (rewrite p0))
 923          (eqv? 42 (package-source p1))
 924          (match (package-inputs p1)
 925            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 926             (and (eq? dep1 (rewrite coreutils))   ;memoization
 927                  (eq? dep2 (rewrite grep))
 928                  (eq? dep3 (rewrite dep))
 929                  (eqv? 42
 930                        (package-source dep1) (package-source dep2)
 931                        (package-source dep3))
 932                  (match (package-native-inputs dep3)
 933                    ((("x" dep))
 934                     (and (eq? dep (rewrite grep))
 935                          (package-source dep))))))))))
 936
 937 (test-assert "package-input-rewriting"
 938   (let* ((dep     (dummy-package "chbouib"
 939                     (native-inputs `(("x" ,grep)))))
 940          (p0      (dummy-package "example"
 941                     (inputs `(("foo" ,coreutils)
 942                               ("bar" ,grep)
 943                               ("baz" ,dep)))))
 944          (rewrite (package-input-rewriting `((,coreutils . ,sed)
 945                                              (,grep . ,findutils))
 946                                            (cut string-append "r-" <>)))
 947          (p1      (rewrite p0))
 948          (p2      (rewrite p0)))
 949     (and (not (eq? p1 p0))
 950          (eq? p1 p2)                              ;memoization
 951          (string=? "r-example" (package-name p1))
 952          (match (package-inputs p1)
 953            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 954             (and (eq? dep1 sed)
 955                  (eq? dep2 findutils)
 956                  (string=? (package-name dep3) "r-chbouib")
 957                  (eq? dep3 (rewrite dep))         ;memoization
 958                  (match (package-native-inputs dep3)
 959                    ((("x" dep))
 960                     (eq? dep findutils)))))))))
 961
 962 (test-equal "package-patched-vulnerabilities"
 963   '(("CVE-2015-1234")
 964     ("CVE-2016-1234" "CVE-2018-4567")
 965     ())
 966   (let ((p1 (dummy-package "pi"
 967               (source (dummy-origin
 968                        (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
 969         (p2 (dummy-package "pi"
 970               (source (dummy-origin
 971                        (patches (list
 972                                  "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
 973         (p3 (dummy-package "pi" (source (dummy-origin)))))
 974     (map package-patched-vulnerabilities
 975          (list p1 p2 p3))))
 976
 977 (test-eq "fold-packages" hello
 978   (fold-packages (lambda (p r)
 979                    (if (string=? (package-name p) "hello")
 980                        p
 981                        r))
 982                  #f))
 983
 984 (test-assert "fold-packages, hidden package"
 985   ;; There are two public variables providing "guile@2.0" ('guile-final' in
 986   ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
 987   ;; should show up.
 988   (match (fold-packages (lambda (p r)
 989                           (if (and (string=? (package-name p) "guile")
 990                                    (string-prefix? "2.0"
 991                                                    (package-version p)))
 992                               (cons p r)
 993                               r))
 994                         '())
 995     ((one)
 996      (eq? one guile-2.0))))
 997
 998 (test-assert "find-packages-by-name"
 999   (match (find-packages-by-name "hello")
1000     (((? (cut eq? hello <>))) #t)
1001     (wrong (pk 'find-packages-by-name wrong #f))))
1002
1003 (test-assert "find-packages-by-name with version"
1004   (match (find-packages-by-name "hello" (package-version hello))
1005     (((? (cut eq? hello <>))) #t)
1006     (wrong (pk 'find-packages-by-name wrong #f))))
1007
1008 (test-assert "--search-paths with pattern"
1009   ;; Make sure 'guix package --search-paths' correctly reports environment
1010   ;; variables when file patterns are used (in particular, it must follow
1011   ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
1012   ;; libxml2 package specification, which contains such a definition.
1013   (let* ((p1 (package
1014                (name "foo") (version "0") (source #f)
1015                (build-system trivial-build-system)
1016                (arguments
1017                 `(#:guile ,%bootstrap-guile
1018                   #:modules ((guix build utils))
1019                   #:builder (begin
1020                               (use-modules (guix build utils))
1021                               (let ((out (assoc-ref %outputs "out")))
1022                                 (mkdir-p (string-append out "/xml/bar/baz"))
1023                                 (call-with-output-file
1024                                     (string-append out "/xml/bar/baz/catalog.xml")
1025                                   (lambda (port)
1026                                     (display "xml? wat?!" port)))
1027                                 #t))))
1028                (synopsis #f) (description #f)
1029                (home-page #f) (license #f)))
1030          (p2 (package
1031                ;; Provide a fake libxml2 to avoid building the real one.  This
1032                ;; is OK because 'guix package' gets search path specifications
1033                ;; from the same-named package found in the distro.
1034                (name "libxml2") (version "0.0.0") (source #f)
1035                (build-system trivial-build-system)
1036                (arguments
1037                 `(#:guile ,%bootstrap-guile
1038                   #:builder (begin
1039                               (mkdir (assoc-ref %outputs "out"))
1040                               #t)))
1041                (native-search-paths (package-native-search-paths libxml2))
1042                (synopsis #f) (description #f)
1043                (home-page #f) (license #f)))
1044          (prof (run-with-store %store
1045                  (profile-derivation
1046                   (manifest (map package->manifest-entry
1047                                  (list p1 p2)))
1048                   #:hooks '()
1049                   #:locales? #f)
1050                  #:guile-for-build (%guile-for-build))))
1051     (build-derivations %store (list prof))
1052     (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
1053                           (regexp-quote (derivation->output-path prof)))
1054                   (with-output-to-string
1055                     (lambda ()
1056                       (guix-package "-p" (derivation->output-path prof)
1057                                     "--search-paths"))))))
1058
1059 (test-assert "--search-paths with single-item search path"
1060   ;; Make sure 'guix package --search-paths' correctly reports environment
1061   ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
1062   ;; separator, meaning that the first match wins.
1063   (let* ((p1 (dummy-package "foo"
1064                (build-system trivial-build-system)
1065                (arguments
1066                 `(#:guile ,%bootstrap-guile
1067                   #:modules ((guix build utils))
1068                   #:builder (begin
1069                               (use-modules (guix build utils))
1070                               (let ((out (assoc-ref %outputs "out")))
1071                                 (mkdir-p (string-append out "/etc/ssl/certs"))
1072                                 (call-with-output-file
1073                                     (string-append
1074                                      out "/etc/ssl/certs/ca-certificates.crt")
1075                                   (const #t))))))))
1076          (p2 (package (inherit p1) (name "bar")))
1077          (p3 (dummy-package "git"
1078                ;; Provide a fake Git to avoid building the real one.
1079                (build-system trivial-build-system)
1080                (arguments
1081                 `(#:guile ,%bootstrap-guile
1082                   #:builder (begin
1083                               (mkdir (assoc-ref %outputs "out"))
1084                               #t)))
1085                (native-search-paths (package-native-search-paths git))))
1086          (prof1 (run-with-store %store
1087                   (profile-derivation
1088                    (packages->manifest (list p1 p3))
1089                    #:hooks '()
1090                    #:locales? #f)
1091                   #:guile-for-build (%guile-for-build)))
1092          (prof2 (run-with-store %store
1093                   (profile-derivation
1094                    (packages->manifest (list p2 p3))
1095                    #:hooks '()
1096                    #:locales? #f)
1097                   #:guile-for-build (%guile-for-build))))
1098     (build-derivations %store (list prof1 prof2))
1099     (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
1100                           (regexp-quote (derivation->output-path prof1)))
1101                   (with-output-to-string
1102                     (lambda ()
1103                       (guix-package "-p" (derivation->output-path prof1)
1104                                     "-p" (derivation->output-path prof2)
1105                                     "--search-paths"))))))
1106
1107 (test-equal "specification->package when not found"
1108   'quit
1109   (catch 'quit
1110     (lambda ()
1111       ;; This should call 'leave', producing an error message.
1112       (specification->package "this-package-does-not-exist"))
1113     (lambda (key . args)
1114       key)))
1115
1116 (test-end "packages")
1117
1118 ;;; Local Variables:
1119 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
1120 ;;; End: