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