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