tests/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 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 utils)
  24                 ;; Rename the 'location' binding to allow proper syntax
  25                 ;; matching when setting the 'location' field of a package.
  26                 #:renamer (lambda (name)
  27                             (cond ((eq? name 'location) 'make-location)
  28                                   (else name))))
  29   #:use-module (guix hash)
  30   #:use-module (guix derivations)
  31   #:use-module (guix packages)
  32   #:use-module (guix build-system)
  33   #:use-module (guix build-system trivial)
  34   #:use-module (guix build-system gnu)
  35   #:use-module (guix profiles)
  36   #:use-module (guix scripts package)
  37   #:use-module (gnu packages)
  38   #:use-module (gnu packages base)
  39   #:use-module (gnu packages guile)
  40   #:use-module (gnu packages bootstrap)
  41   #:use-module (gnu packages xml)
  42   #:use-module (srfi srfi-1)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-35)
  46   #:use-module (srfi srfi-64)
  47   #:use-module (rnrs io ports)
  48   #:use-module (ice-9 regex)
  49   #:use-module (ice-9 match))
  50
  51 ;; Test the high-level packaging layer.
  52
  53 (define %store
  54   (open-connection-for-tests))
  55
  56 \f
  57 (test-begin "packages")
  58
  59 (test-assert "printer with location"
  60   (string-match "^#<package foo-0 foo.scm:42 [[:xdigit:]]+>$"
  61                 (with-output-to-string
  62                   (lambda ()
  63                     (write
  64                      (dummy-package "foo"
  65                        (location (make-location "foo.scm" 42 7))))))))
  66
  67 (test-assert "printer without location"
  68   (string-match "^#<package foo-0 [[:xdigit:]]+>$"
  69                 (with-output-to-string
  70                   (lambda ()
  71                     (write
  72                      (dummy-package "foo" (location #f)))))))
  73
  74 (test-assert "package-field-location"
  75   (let ()
  76     (define (goto port line column)
  77       (unless (and (= (port-column port) (- column 1))
  78                    (= (port-line port) (- line 1)))
  79         (unless (eof-object? (get-char port))
  80           (goto port line column))))
  81
  82     (define read-at
  83       (match-lambda
  84        (($ <location> file line column)
  85         (call-with-input-file (search-path %load-path file)
  86           (lambda (port)
  87             (goto port line column)
  88             (read port))))))
  89
  90     ;; Until Guile 2.0.6 included, source properties were added only to pairs.
  91     ;; Thus, check against both VALUE and (FIELD VALUE).
  92     (and (member (read-at (package-field-location %bootstrap-guile 'name))
  93                  (let ((name (package-name %bootstrap-guile)))
  94                    (list name `(name ,name))))
  95          (member (read-at (package-field-location %bootstrap-guile 'version))
  96                  (let ((version (package-version %bootstrap-guile)))
  97                    (list version `(version ,version))))
  98          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
  99
 100 ;; Make sure we don't change the file name to an absolute file name.
 101 (test-equal "package-field-location, relative file name"
 102   (location-file (package-location %bootstrap-guile))
 103   (with-fluids ((%file-port-name-canonicalization 'absolute))
 104     (location-file (package-field-location %bootstrap-guile 'version))))
 105
 106 (test-assert "package-transitive-inputs"
 107   (let* ((a (dummy-package "a"))
 108          (b (dummy-package "b"
 109               (propagated-inputs `(("a" ,a)))))
 110          (c (dummy-package "c"
 111               (inputs `(("a" ,a)))))
 112          (d (dummy-package "d"
 113               (propagated-inputs `(("x" "something.drv")))))
 114          (e (dummy-package "e"
 115               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
 116     (and (null? (package-transitive-inputs a))
 117          (equal? `(("a" ,a)) (package-transitive-inputs b))
 118          (equal? `(("a" ,a)) (package-transitive-inputs c))
 119          (equal? (package-propagated-inputs d)
 120                  (package-transitive-inputs d))
 121          (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
 122                    ("a" ,a) ("x" "something.drv"))
 123                  (pk 'x (package-transitive-inputs e))))))
 124
 125 (test-assert "package-transitive-inputs, no duplicates"
 126   (let* ((a (dummy-package "a"))
 127          (b (dummy-package "b"
 128               (inputs `(("a+" ,a)))
 129               (native-inputs `(("a*" ,a)))
 130               (propagated-inputs `(("a" ,a)))))
 131          (c (dummy-package "c"
 132               (propagated-inputs `(("b" ,b)))))
 133          (d (dummy-package "d"
 134               (inputs `(("a" ,a) ("c" ,c)))))
 135          (e (dummy-package "e"
 136               (inputs `(("b" ,b) ("c" ,c))))))
 137     (and (null? (package-transitive-inputs a))
 138          (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a))   ;here duplicates are kept
 139                  (package-transitive-inputs b))
 140          (equal? `(("b" ,b) ("a" ,a))
 141                  (package-transitive-inputs c))
 142          (equal? `(("a" ,a) ("c" ,c) ("b" ,b))     ;duplicate A removed
 143                  (package-transitive-inputs d))
 144          (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
 145                  (package-transitive-inputs e))))) ;ditto
 146
 147 (test-equal "package-transitive-supported-systems"
 148   '(("x" "y" "z")                                 ;a
 149     ("x" "y")                                     ;b
 150     ("y")                                         ;c
 151     ("y")                                         ;d
 152     ("y"))                                        ;e
 153   ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
 154   ;; doesn't restrict the set of supported systems.
 155   (let* ((a (dummy-package "a"
 156               (build-system trivial-build-system)
 157               (supported-systems '("x" "y" "z"))))
 158          (b (dummy-package "b"
 159               (build-system trivial-build-system)
 160               (supported-systems '("x" "y"))
 161               (inputs `(("a" ,a)))))
 162          (c (dummy-package "c"
 163               (build-system trivial-build-system)
 164               (supported-systems '("y" "z"))
 165               (inputs `(("b" ,b)))))
 166          (d (dummy-package "d"
 167               (build-system trivial-build-system)
 168               (supported-systems '("x" "y" "z"))
 169               (inputs `(("b" ,b) ("c" ,c)))))
 170          (e (dummy-package "e"
 171               (build-system trivial-build-system)
 172               (supported-systems '("x" "y" "z"))
 173               (inputs `(("d" ,d))))))
 174     (list (package-transitive-supported-systems a)
 175           (package-transitive-supported-systems b)
 176           (package-transitive-supported-systems c)
 177           (package-transitive-supported-systems d)
 178           (package-transitive-supported-systems e))))
 179
 180 (test-equal "origin-actual-file-name"
 181   "foo-1.tar.gz"
 182   (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
 183     (origin-actual-file-name o)))
 184
 185 (test-equal "origin-actual-file-name, file-name"
 186   "foo-1.tar.gz"
 187   (let ((o (dummy-origin
 188             (uri "http://www.example.com/tarball")
 189             (file-name "foo-1.tar.gz"))))
 190     (origin-actual-file-name o)))
 191
 192 (let* ((o (dummy-origin))
 193        (u (dummy-origin))
 194        (i (dummy-origin))
 195        (a (dummy-package "a"))
 196        (b (dummy-package "b"
 197             (inputs `(("a" ,a) ("i" ,i)))))
 198        (c (package (inherit b) (source o)))
 199        (d (dummy-package "d"
 200             (build-system trivial-build-system)
 201             (source u) (inputs `(("c" ,c))))))
 202   (test-assert "package-direct-sources, no source"
 203     (null? (package-direct-sources a)))
 204   (test-equal "package-direct-sources, #f source"
 205     (list i)
 206     (package-direct-sources b))
 207   (test-equal "package-direct-sources, not input source"
 208     (list u)
 209     (package-direct-sources d))
 210   (test-assert "package-direct-sources"
 211     (let ((s (package-direct-sources c)))
 212       (and (= (length (pk 's-sources s)) 2)
 213            (member o s)
 214            (member i s))))
 215   (test-assert "package-transitive-sources"
 216     (let ((s (package-transitive-sources d)))
 217       (and (= (length (pk 'd-sources s)) 3)
 218            (member o s)
 219            (member i s)
 220            (member u s)))))
 221
 222 (test-assert "transitive-input-references"
 223   (let* ((a (dummy-package "a"))
 224          (b (dummy-package "b"))
 225          (c (dummy-package "c"
 226               (inputs `(("a" ,a)))
 227               (propagated-inputs `(("boo" ,b)))))
 228          (d (dummy-package "d"
 229               (inputs `(("c*" ,c)))))
 230          (keys (map (match-lambda
 231                       (('assoc-ref 'l key)
 232                        key))
 233                     (pk 'refs (transitive-input-references
 234                                'l (package-inputs d))))))
 235     (and (= (length keys) 2)
 236          (member "c*" keys)
 237          (member "boo" keys))))
 238
 239 (test-equal "package-transitive-supported-systems, implicit inputs"
 240   %supported-systems
 241
 242   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 243   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 244   (let ((p (dummy-package "foo"
 245              (build-system gnu-build-system)
 246              (supported-systems
 247               `("does-not-exist" "foobar" ,@%supported-systems)))))
 248     (package-transitive-supported-systems p)))
 249
 250 (test-assert "supported-package?"
 251   (let ((p (dummy-package "foo"
 252              (build-system gnu-build-system)
 253              (supported-systems '("x86_64-linux" "does-not-exist")))))
 254     (and (supported-package? p "x86_64-linux")
 255          (not (supported-package? p "does-not-exist"))
 256          (not (supported-package? p "i686-linux")))))
 257
 258 (test-skip (if (not %store) 8 0))
 259
 260 (test-assert "package-source-derivation, file"
 261   (let* ((file    (search-path %load-path "guix.scm"))
 262          (package (package (inherit (dummy-package "p"))
 263                     (source file)))
 264          (source  (package-source-derivation %store
 265                                              (package-source package))))
 266     (and (store-path? source)
 267          (valid-path? %store source)
 268          (equal? (call-with-input-file source get-bytevector-all)
 269                  (call-with-input-file file get-bytevector-all)))))
 270
 271 (test-assert "package-source-derivation, store path"
 272   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 273                                 (search-path %load-path "guix.scm")))
 274          (package (package (inherit (dummy-package "p"))
 275                     (source file)))
 276          (source  (package-source-derivation %store
 277                                              (package-source package))))
 278     (string=? file source)))
 279
 280 (test-assert "package-source-derivation, indirect store path"
 281   (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
 282                                 (dirname (search-path %load-path
 283                                                       "guix/build/utils.scm"))))
 284          (package (package (inherit (dummy-package "p"))
 285                     (source (string-append dir "/utils.scm"))))
 286          (source  (package-source-derivation %store
 287                                              (package-source package))))
 288     (and (direct-store-path? source)
 289          (string-suffix? "utils.scm" source))))
 290
 291 (unless (network-reachable?) (test-skip 1))
 292 (test-equal "package-source-derivation, snippet"
 293   "OK"
 294   (let* ((file   (search-bootstrap-binary (match (%current-system)
 295                                             ("armhf-linux"
 296                                              "guile-2.0.11.tar.xz")
 297                                             (_
 298                                              "guile-2.0.9.tar.xz"))
 299                                           (%current-system)))
 300          (sha256 (call-with-input-file file port-sha256))
 301          (fetch  (lambda* (url hash-algo hash
 302                            #:optional name #:key system)
 303                    (pk 'fetch url hash-algo hash name system)
 304                    (interned-file url)))
 305          (source (bootstrap-origin
 306                   (origin
 307                     (method fetch)
 308                     (uri file)
 309                     (sha256 sha256)
 310                     (patch-inputs
 311                      `(("tar" ,%bootstrap-coreutils&co)
 312                        ("xz" ,%bootstrap-coreutils&co)
 313                        ("patch" ,%bootstrap-coreutils&co)))
 314                     (patch-guile %bootstrap-guile)
 315                     (modules '((guix build utils)))
 316                     (imported-modules modules)
 317                     (snippet '(begin
 318                                 ;; We end up in 'bin', because it's the first
 319                                 ;; directory, alphabetically.  Not a very good
 320                                 ;; example but hey.
 321                                 (chmod "." #o777)
 322                                 (symlink "guile" "guile-rocks")
 323                                 (copy-recursively "../share/guile/2.0/scripts"
 324                                                   "scripts")
 325
 326                                 ;; Make sure '.file_list' can be created.
 327                                 (chmod ".." #o777))))))
 328          (package (package (inherit (dummy-package "with-snippet"))
 329                     (source source)
 330                     (build-system trivial-build-system)
 331                     (inputs
 332                      `(("tar" ,(search-bootstrap-binary "tar"
 333                                                         (%current-system)))
 334                        ("xz"  ,(search-bootstrap-binary "xz"
 335                                                         (%current-system)))))
 336                     (arguments
 337                      `(#:guile ,%bootstrap-guile
 338                        #:builder
 339                        (let ((tar    (assoc-ref %build-inputs "tar"))
 340                              (xz     (assoc-ref %build-inputs "xz"))
 341                              (source (assoc-ref %build-inputs "source")))
 342                          (and (zero? (system* tar "xvf" source
 343                                               "--use-compress-program" xz))
 344                               (string=? "guile" (readlink "bin/guile-rocks"))
 345                               (file-exists? "bin/scripts/compile.scm")
 346                               (let ((out (assoc-ref %outputs "out")))
 347                                 (call-with-output-file out
 348                                   (lambda (p)
 349                                     (display "OK" p))))))))))
 350          (drv    (package-derivation %store package))
 351          (out    (derivation->output-path drv)))
 352     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 353          (call-with-input-file out get-string-all))))
 354
 355 (test-assert "return value"
 356   (let ((drv (package-derivation %store (dummy-package "p"))))
 357     (and (derivation? drv)
 358          (file-exists? (derivation-file-name drv)))))
 359
 360 (test-assert "package-output"
 361   (let* ((package  (dummy-package "p"))
 362          (drv      (package-derivation %store package)))
 363     (and (derivation? drv)
 364          (string=? (derivation->output-path drv)
 365                    (package-output %store package "out")))))
 366
 367 (test-assert "patch not found yields a run-time error"
 368   (guard (c ((condition-has-type? c &message)
 369              (and (string-contains (condition-message c)
 370                                    "does-not-exist.patch")
 371                   (string-contains (condition-message c)
 372                                    "not found"))))
 373     (let ((p (package
 374                (inherit (dummy-package "p"))
 375                (source (origin
 376                          (method (const #f))
 377                          (uri "http://whatever")
 378                          (patches
 379                           (list (search-patch "does-not-exist.patch")))
 380                          (sha256
 381                           (base32
 382                            "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
 383       (package-derivation %store p)
 384       #f)))
 385
 386 (test-assert "reference to non-existent output"
 387   ;; See <http://bugs.gnu.org/19630>.
 388   (parameterize ((%graft? #f))
 389     (let* ((dep (dummy-package "dep"))
 390            (p   (dummy-package "p"
 391                   (inputs `(("dep" ,dep "non-existent"))))))
 392       (guard (c ((derivation-missing-output-error? c)
 393                  (and (string=? (derivation-missing-output c) "non-existent")
 394                       (equal? (package-derivation %store dep)
 395                               (derivation-error-derivation c)))))
 396         (package-derivation %store p)))))
 397
 398 (test-assert "trivial"
 399   (let* ((p (package (inherit (dummy-package "trivial"))
 400               (build-system trivial-build-system)
 401               (source #f)
 402               (arguments
 403                `(#:guile ,%bootstrap-guile
 404                  #:builder
 405                  (begin
 406                    (mkdir %output)
 407                    (call-with-output-file (string-append %output "/test")
 408                      (lambda (p)
 409                        (display '(hello guix) p))))))))
 410          (d (package-derivation %store p)))
 411     (and (build-derivations %store (list d))
 412          (let ((p (pk 'drv d (derivation->output-path d))))
 413            (equal? '(hello guix)
 414                    (call-with-input-file (string-append p "/test") read))))))
 415
 416 (test-assert "trivial with local file as input"
 417   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 418          (p (package (inherit (dummy-package "trivial-with-input-file"))
 419               (build-system trivial-build-system)
 420               (source #f)
 421               (arguments
 422                `(#:guile ,%bootstrap-guile
 423                  #:builder (copy-file (assoc-ref %build-inputs "input")
 424                                       %output)))
 425               (inputs `(("input" ,i)))))
 426          (d (package-derivation %store p)))
 427     (and (build-derivations %store (list d))
 428          (let ((p (pk 'drv d (derivation->output-path d))))
 429            (equal? (call-with-input-file p get-bytevector-all)
 430                    (call-with-input-file i get-bytevector-all))))))
 431
 432 (test-assert "trivial with source"
 433   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 434          (p (package (inherit (dummy-package "trivial-with-source"))
 435               (build-system trivial-build-system)
 436               (source i)
 437               (arguments
 438                `(#:guile ,%bootstrap-guile
 439                  #:builder (copy-file (assoc-ref %build-inputs "source")
 440                                       %output)))))
 441          (d (package-derivation %store p)))
 442     (and (build-derivations %store (list d))
 443          (let ((p (derivation->output-path d)))
 444            (equal? (call-with-input-file p get-bytevector-all)
 445                    (call-with-input-file i get-bytevector-all))))))
 446
 447 (test-assert "trivial with system-dependent input"
 448   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 449               (build-system trivial-build-system)
 450               (source #f)
 451               (arguments
 452                `(#:guile ,%bootstrap-guile
 453                  #:builder
 454                  (let ((out  (assoc-ref %outputs "out"))
 455                        (bash (assoc-ref %build-inputs "bash")))
 456                    (zero? (system* bash "-c"
 457                                    (format #f "echo hello > ~a" out))))))
 458               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 459                                                           (%current-system)))))))
 460          (d (package-derivation %store p)))
 461     (and (build-derivations %store (list d))
 462          (let ((p (pk 'drv d (derivation->output-path d))))
 463            (eq? 'hello (call-with-input-file p read))))))
 464
 465 (test-assert "search paths"
 466   (let* ((p (make-prompt-tag "return-search-paths"))
 467          (s (build-system
 468              (name 'raw)
 469              (description "Raw build system with direct store access")
 470              (lower (lambda* (name #:key source inputs system target
 471                                    #:allow-other-keys)
 472                       (bag
 473                         (name name)
 474                         (system system) (target target)
 475                         (build-inputs inputs)
 476                         (build
 477                          (lambda* (store name inputs
 478                                          #:key outputs system search-paths)
 479                            search-paths)))))))
 480          (x (list (search-path-specification
 481                    (variable "GUILE_LOAD_PATH")
 482                    (files '("share/guile/site/2.0")))
 483                   (search-path-specification
 484                    (variable "GUILE_LOAD_COMPILED_PATH")
 485                    (files '("share/guile/site/2.0")))))
 486          (a (package (inherit (dummy-package "guile"))
 487               (build-system s)
 488               (native-search-paths x)))
 489          (b (package (inherit (dummy-package "guile-foo"))
 490               (build-system s)
 491               (inputs `(("guile" ,a)))))
 492          (c (package (inherit (dummy-package "guile-bar"))
 493               (build-system s)
 494               (inputs `(("guile" ,a)
 495                         ("guile-foo" ,b))))))
 496     (let-syntax ((collect (syntax-rules ()
 497                             ((_ body ...)
 498                              (call-with-prompt p
 499                                (lambda ()
 500                                  body ...)
 501                                (lambda (k search-paths)
 502                                  search-paths))))))
 503       (and (null? (collect (package-derivation %store a)))
 504            (equal? x (collect (package-derivation %store b)))
 505            (equal? x (collect (package-derivation %store c)))))))
 506
 507 (test-assert "package-cross-derivation"
 508   (let ((drv (package-cross-derivation %store (dummy-package "p")
 509                                        "mips64el-linux-gnu")))
 510     (and (derivation? drv)
 511          (file-exists? (derivation-file-name drv)))))
 512
 513 (test-assert "package-cross-derivation, trivial-build-system"
 514   (let ((p (package (inherit (dummy-package "p"))
 515              (build-system trivial-build-system)
 516              (arguments '(#:builder (exit 1))))))
 517     (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
 518       (derivation? drv))))
 519
 520 (test-assert "package-cross-derivation, no cross builder"
 521   (let* ((b (build-system (inherit trivial-build-system)
 522               (lower (const #f))))
 523          (p (package (inherit (dummy-package "p"))
 524               (build-system b))))
 525     (guard (c ((package-cross-build-system-error? c)
 526                (eq? (package-error-package c) p)))
 527       (package-cross-derivation %store p "mips64el-linux-gnu")
 528       #f)))
 529
 530 (test-equal "package-derivation, direct graft"
 531   (package-derivation %store gnu-make)
 532   (let ((p (package (inherit coreutils)
 533              (replacement gnu-make))))
 534     (package-derivation %store p)))
 535
 536 (test-equal "package-cross-derivation, direct graft"
 537   (package-cross-derivation %store gnu-make "mips64el-linux-gnu")
 538   (let ((p (package (inherit coreutils)
 539              (replacement gnu-make))))
 540     (package-cross-derivation %store p "mips64el-linux-gnu")))
 541
 542 (test-assert "package-grafts, indirect grafts"
 543   (let* ((new   (dummy-package "dep"
 544                   (arguments '(#:implicit-inputs? #f))))
 545          (dep   (package (inherit new) (version "0.0")))
 546          (dep*  (package (inherit dep) (replacement new)))
 547          (dummy (dummy-package "dummy"
 548                   (arguments '(#:implicit-inputs? #f))
 549                   (inputs `(("dep" ,dep*))))))
 550     (equal? (package-grafts %store dummy)
 551             (list (graft
 552                     (origin (package-derivation %store dep))
 553                     (replacement (package-derivation %store new)))))))
 554
 555 (test-assert "package-grafts, indirect grafts, cross"
 556   (let* ((new    (dummy-package "dep"
 557                    (arguments '(#:implicit-inputs? #f))))
 558          (dep    (package (inherit new) (version "0.0")))
 559          (dep*   (package (inherit dep) (replacement new)))
 560          (dummy  (dummy-package "dummy"
 561                    (arguments '(#:implicit-inputs? #f))
 562                    (inputs `(("dep" ,dep*)))))
 563          (target "mips64el-linux-gnu"))
 564     (equal? (package-grafts %store dummy #:target target)
 565             (list (graft
 566                     (origin (package-cross-derivation %store dep target))
 567                     (replacement
 568                      (package-cross-derivation %store new target)))))))
 569
 570 (test-assert "package-grafts, indirect grafts, propagated inputs"
 571   (let* ((new   (dummy-package "dep"
 572                   (arguments '(#:implicit-inputs? #f))))
 573          (dep   (package (inherit new) (version "0.0")))
 574          (dep*  (package (inherit dep) (replacement new)))
 575          (prop  (dummy-package "propagated"
 576                   (propagated-inputs `(("dep" ,dep*)))
 577                   (arguments '(#:implicit-inputs? #f))))
 578          (dummy (dummy-package "dummy"
 579                   (arguments '(#:implicit-inputs? #f))
 580                   (inputs `(("prop" ,prop))))))
 581     (equal? (package-grafts %store dummy)
 582             (list (graft
 583                     (origin (package-derivation %store dep))
 584                     (replacement (package-derivation %store new)))))))
 585
 586 (test-assert "package-derivation, indirect grafts"
 587   (let* ((new   (dummy-package "dep"
 588                   (arguments '(#:implicit-inputs? #f))))
 589          (dep   (package (inherit new) (version "0.0")))
 590          (dep*  (package (inherit dep) (replacement new)))
 591          (dummy (dummy-package "dummy"
 592                   (arguments '(#:implicit-inputs? #f))
 593                   (inputs `(("dep" ,dep*)))))
 594          (guile (package-derivation %store (canonical-package guile-2.0)
 595                                     #:graft? #f)))
 596     (equal? (package-derivation %store dummy)
 597             (graft-derivation %store "dummy-0"
 598                               (package-derivation %store dummy #:graft? #f)
 599                               (package-grafts %store dummy)
 600
 601                               ;; Use the same Guile as 'package-derivation'.
 602                               #:guile guile))))
 603
 604 (test-equal "package->bag"
 605   `("foo86-hurd" #f (,(package-source gnu-make))
 606     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 607   (let ((bag (package->bag gnu-make "foo86-hurd")))
 608     (list (bag-system bag) (bag-target bag)
 609           (assoc-ref (bag-build-inputs bag) "source")
 610           (assoc-ref (bag-build-inputs bag) "libc")
 611           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 612
 613 (test-equal "package->bag, cross-compilation"
 614   `(,(%current-system) "foo86-hurd"
 615     (,(package-source gnu-make))
 616     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 617   (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
 618     (list (bag-system bag) (bag-target bag)
 619           (assoc-ref (bag-build-inputs bag) "source")
 620           (assoc-ref (bag-build-inputs bag) "libc")
 621           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 622
 623 (test-assert "package->bag, propagated inputs"
 624   (let* ((dep    (dummy-package "dep"))
 625          (prop   (dummy-package "prop"
 626                    (propagated-inputs `(("dep" ,dep)))))
 627          (dummy  (dummy-package "dummy"
 628                    (inputs `(("prop" ,prop)))))
 629          (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
 630     (match (assoc "dep" inputs)
 631       (("dep" package)
 632        (eq? package dep)))))
 633
 634 (test-assert "bag->derivation"
 635   (parameterize ((%graft? #f))
 636     (let ((bag (package->bag gnu-make))
 637           (drv (package-derivation %store gnu-make)))
 638       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
 639         (equal? drv (bag->derivation %store bag))))))
 640
 641 (test-assert "bag->derivation, cross-compilation"
 642   (parameterize ((%graft? #f))
 643     (let* ((target "mips64el-linux-gnu")
 644            (bag    (package->bag gnu-make (%current-system) target))
 645            (drv    (package-cross-derivation %store gnu-make target)))
 646       (parameterize ((%current-system "foox86-hurd") ;should have no effect
 647                      (%current-target-system "foo64-linux-gnu"))
 648         (equal? drv (bag->derivation %store bag))))))
 649
 650 (when (or (not (network-reachable?)) (shebang-too-long?))
 651   (test-skip 1))
 652 (test-assert "GNU Make, bootstrap"
 653   ;; GNU Make is the first program built during bootstrap; we choose it
 654   ;; here so that the test doesn't last for too long.
 655   (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0)))
 656     (and (package? gnu-make)
 657          (or (location? (package-location gnu-make))
 658              (not (package-location gnu-make)))
 659          (let* ((drv (package-derivation %store gnu-make))
 660                 (out (derivation->output-path drv)))
 661            (and (build-derivations %store (list drv))
 662                 (file-exists? (string-append out "/bin/make")))))))
 663
 664 (test-eq "fold-packages" hello
 665   (fold-packages (lambda (p r)
 666                    (if (string=? (package-name p) "hello")
 667                        p
 668                        r))
 669                  #f))
 670
 671 (test-assert "find-packages-by-name"
 672   (match (find-packages-by-name "hello")
 673     (((? (cut eq? hello <>))) #t)
 674     (wrong (pk 'find-packages-by-name wrong #f))))
 675
 676 (test-assert "find-packages-by-name with version"
 677   (match (find-packages-by-name "hello" (package-version hello))
 678     (((? (cut eq? hello <>))) #t)
 679     (wrong (pk 'find-packages-by-name wrong #f))))
 680
 681 (test-assert "--search-paths with pattern"
 682   ;; Make sure 'guix package --search-paths' correctly reports environment
 683   ;; variables when file patterns are used (in particular, it must follow
 684   ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
 685   ;; libxml2 package specification, which contains such a definition.
 686   (let* ((p1 (package
 687                (name "foo") (version "0") (source #f)
 688                (build-system trivial-build-system)
 689                (arguments
 690                 `(#:guile ,%bootstrap-guile
 691                   #:modules ((guix build utils))
 692                   #:builder (begin
 693                               (use-modules (guix build utils))
 694                               (let ((out (assoc-ref %outputs "out")))
 695                                 (mkdir-p (string-append out "/xml/bar/baz"))
 696                                 (call-with-output-file
 697                                     (string-append out "/xml/bar/baz/catalog.xml")
 698                                   (lambda (port)
 699                                     (display "xml? wat?!" port)))))))
 700                (synopsis #f) (description #f)
 701                (home-page #f) (license #f)))
 702          (p2 (package
 703                ;; Provide a fake libxml2 to avoid building the real one.  This
 704                ;; is OK because 'guix package' gets search path specifications
 705                ;; from the same-named package found in the distro.
 706                (name "libxml2") (version "0.0.0") (source #f)
 707                (build-system trivial-build-system)
 708                (arguments
 709                 `(#:guile ,%bootstrap-guile
 710                   #:builder (mkdir (assoc-ref %outputs "out"))))
 711                (native-search-paths (package-native-search-paths libxml2))
 712                (synopsis #f) (description #f)
 713                (home-page #f) (license #f)))
 714          (prof (run-with-store %store
 715                  (profile-derivation
 716                   (manifest (map package->manifest-entry
 717                                  (list p1 p2)))
 718                   #:hooks '())
 719                  #:guile-for-build (%guile-for-build))))
 720     (build-derivations %store (list prof))
 721     (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
 722                           (derivation->output-path prof))
 723                   (with-output-to-string
 724                     (lambda ()
 725                       (guix-package "-p" (derivation->output-path prof)
 726                                     "--search-paths"))))))
 727
 728 (test-end "packages")
 729
 730 \f
 731 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 732
 733 ;;; Local Variables:
 734 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 735 ;;; End: