1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (test-gexp)
20 #:use-module (guix store)
21 #:use-module (guix monads)
22 #:use-module (guix gexp)
23 #:use-module (guix grafts)
24 #:use-module (guix derivations)
25 #:use-module (guix packages)
26 #:use-module (guix tests)
27 #:use-module ((guix build utils) #:select (with-directory-excursion))
28 #:use-module (gnu packages)
29 #:use-module (gnu packages base)
30 #:use-module (gnu packages bootstrap)
31 #:use-module (srfi srfi-1)
32 #:use-module (srfi srfi-34)
33 #:use-module (srfi srfi-64)
34 #:use-module (rnrs io ports)
35 #:use-module (ice-9 match)
36 #:use-module (ice-9 regex)
37 #:use-module (ice-9 popen)
38 #:use-module (ice-9 ftw))
40 ;; Test the (guix gexp) module.
43 (open-connection-for-tests))
45 ;; Globally disable grafts because they can trigger early builds.
48 ;; For white-box testing.
49 (define (gexp-inputs x)
50 ((@@ (guix gexp) gexp-inputs) x))
51 (define (gexp-native-inputs x)
52 ((@@ (guix gexp) gexp-native-inputs) x))
53 (define (gexp-outputs x)
54 ((@@ (guix gexp) gexp-outputs) x))
55 (define (gexp->sexp . x)
56 (apply (@@ (guix gexp) gexp->sexp) x))
58 (define* (gexp->sexp* exp #:optional target)
59 (run-with-store %store (gexp->sexp exp
61 #:guile-for-build (%guile-for-build)))
63 (define-syntax-rule (test-assertm name exp)
65 (run-with-store %store exp
66 #:guile-for-build (%guile-for-build))))
73 (let ((exp (gexp (display "hello!"))))
75 (null? (gexp-inputs exp))
79 '(display `(foo ,(+ 2 3)))
80 (let ((exp (gexp (display `(foo ,(+ 2 3))))))
82 (null? (gexp-inputs exp))
85 (test-assert "one input package"
86 (let ((exp (gexp (display (ungexp coreutils)))))
88 (match (gexp-inputs exp)
91 (equal? `(display ,(derivation->output-path
92 (package-derivation %store coreutils)))
95 (test-assert "one input origin"
96 (let ((exp (gexp (display (ungexp (package-source coreutils))))))
98 (match (gexp-inputs exp)
100 (eq? o (package-source coreutils))))
101 (equal? `(display ,(derivation->output-path
102 (package-source-derivation
103 %store (package-source coreutils))))
104 (gexp->sexp* exp)))))
106 (test-assert "one local file"
107 (let* ((file (search-path %load-path "guix.scm"))
108 (local (local-file file))
109 (exp (gexp (display (ungexp local))))
110 (intd (add-to-store %store (basename file) #f
113 (match (gexp-inputs exp)
116 (equal? `(display ,intd) (gexp->sexp* exp)))))
118 (test-assert "one local file, symlink"
119 (let ((file (search-path %load-path "guix.scm"))
124 (symlink (canonicalize-path file) link)
125 (let* ((local (local-file link "my-file" #:recursive? #f))
126 (exp (gexp (display (ungexp local))))
127 (intd (add-to-store %store "my-file" #f
130 (match (gexp-inputs exp)
133 (equal? `(display ,intd) (gexp->sexp* exp)))))
135 (false-if-exception (delete-file link))))))
137 (test-equal "local-file, relative file name"
138 (canonicalize-path (search-path %load-path "guix/base32.scm"))
139 (let ((directory (dirname (search-path %load-path
140 "guix/build-system/gnu.scm"))))
141 (with-directory-excursion directory
142 (let ((file (local-file "../guix/base32.scm")))
143 (local-file-absolute-file-name file)))))
145 (test-assertm "local-file, #:select?"
146 (mlet* %store-monad ((select? -> (lambda (file stat)
147 (member (basename file)
150 (file -> (local-file ".." "directory"
153 (dir (lower-object file)))
154 (return (and (store-path? dir)
155 (equal? (scandir dir)
156 '("." ".." "guix.scm" "tests"))
157 (equal? (scandir (string-append dir "/tests"))
158 '("." ".." "gexp.scm"))))))
160 (test-assert "one plain file"
161 (let* ((file (plain-file "hi" "Hello, world!"))
162 (exp (gexp (display (ungexp file))))
163 (expected (add-text-to-store %store "hi" "Hello, world!")))
165 (match (gexp-inputs exp)
168 (equal? `(display ,expected) (gexp->sexp* exp)))))
170 (test-assert "same input twice"
171 (let ((exp (gexp (begin
172 (display (ungexp coreutils))
173 (display (ungexp coreutils))))))
175 (match (gexp-inputs exp)
178 (let ((e `(display ,(derivation->output-path
179 (package-derivation %store coreutils)))))
180 (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
182 (test-assert "two input packages, one derivation, one file"
183 (let* ((drv (build-expression->derivation
185 #:guile-for-build (package-derivation %store %bootstrap-guile)))
186 (txt (add-text-to-store %store "foo" "Hello, world!"))
188 (display (ungexp coreutils))
189 (display (ungexp %bootstrap-guile))
190 (display (ungexp drv))
191 (display (ungexp txt))))))
192 (define (match-input thing)
195 (eq? thing drv-or-pkg))))
198 (= 4 (length (gexp-inputs exp)))
199 (every (lambda (input)
200 (find (match-input input) (gexp-inputs exp)))
201 (list drv coreutils %bootstrap-guile txt))
202 (let ((e0 `(display ,(derivation->output-path
203 (package-derivation %store coreutils))))
204 (e1 `(display ,(derivation->output-path
205 (package-derivation %store %bootstrap-guile))))
206 (e2 `(display ,(derivation->output-path drv)))
207 (e3 `(display ,txt)))
208 (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
210 (test-assert "ungexp + ungexp-native"
211 (let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
213 (ungexp-native glibc)
215 (target "mips64el-linux")
216 (guile (derivation->output-path
217 (package-derivation %store %bootstrap-guile)))
218 (cu (derivation->output-path
219 (package-cross-derivation %store coreutils target)))
220 (libc (derivation->output-path
221 (package-derivation %store glibc)))
222 (bu (derivation->output-path
223 (package-cross-derivation %store binutils target))))
225 `((,%bootstrap-guile "out") (,glibc "out"))
226 (gexp-native-inputs exp))
228 `((,coreutils "out") (,binutils "out"))
230 (equal? `(list ,guile ,cu ,libc ,bu)
231 (gexp->sexp* exp target)))))
233 (test-equal "ungexp + ungexp-native, nested"
234 (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
235 (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
236 (ungexp %bootstrap-guile)))))
237 (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
239 (test-assert "input list"
240 (let ((exp (gexp (display
241 '(ungexp (list %bootstrap-guile coreutils)))))
242 (guile (derivation->output-path
243 (package-derivation %store %bootstrap-guile)))
244 (cu (derivation->output-path
245 (package-derivation %store coreutils))))
247 `((,%bootstrap-guile "out") (,coreutils "out"))
249 (equal? `(display '(,guile ,cu))
250 (gexp->sexp* exp)))))
252 (test-assert "input list + ungexp-native"
253 (let* ((target "mips64el-linux")
255 (cons '(ungexp-native (list %bootstrap-guile coreutils))
256 '(ungexp (list glibc binutils))))))
257 (guile (derivation->output-path
258 (package-derivation %store %bootstrap-guile)))
259 (cu (derivation->output-path
260 (package-derivation %store coreutils)))
261 (xlibc (derivation->output-path
262 (package-cross-derivation %store glibc target)))
263 (xbu (derivation->output-path
264 (package-cross-derivation %store binutils target))))
266 `((,%bootstrap-guile "out") (,coreutils "out"))
267 (gexp-native-inputs exp))
269 `((,glibc "out") (,binutils "out"))
271 (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
272 (gexp->sexp* exp target)))))
274 (test-assert "input list splicing"
275 (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile))
276 (outputs (list (derivation->output-path
277 (package-derivation %store glibc)
279 (derivation->output-path
280 (package-derivation %store %bootstrap-guile))))
281 (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
283 `((,glibc "debug") (,%bootstrap-guile "out"))
285 (equal? (gexp->sexp* exp)
286 `(list ,@(cons 5 outputs))))))
288 (test-assert "input list splicing + ungexp-native-splicing"
289 (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile))
290 (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
292 `((,glibc "debug") (,%bootstrap-guile "out"))
293 (gexp-native-inputs exp))
294 (null? (gexp-inputs exp))
295 (equal? (gexp->sexp* exp) ;native
296 (gexp->sexp* exp "mips64el-linux")))))
298 (test-equal "output list"
300 (let ((exp (gexp (begin (mkdir (ungexp output))
301 (mkdir (ungexp output "bar"))))))
302 (length (gexp-outputs exp)))) ;XXX: <output-ref> is private
304 (test-assert "output list, combined gexps"
305 (let* ((exp0 (gexp (mkdir (ungexp output))))
306 (exp1 (gexp (mkdir (ungexp output "foo"))))
307 (exp2 (gexp (begin (display "hi!") (ungexp exp0) (ungexp exp1)))))
309 (append (gexp-outputs exp0) (gexp-outputs exp1))
311 (= 2 (length (gexp-outputs exp2))))))
313 (test-equal "output list, combined gexps, duplicate output"
315 (let* ((exp0 (gexp (mkdir (ungexp output))))
316 (exp1 (gexp (begin (mkdir (ungexp output)) (ungexp exp0))))
317 (exp2 (gexp (begin (mkdir (ungexp output)) (ungexp exp1)))))
318 (length (gexp-outputs exp2))))
320 (test-assert "output list + ungexp-splicing list, combined gexps"
321 (let* ((exp0 (gexp (mkdir (ungexp output))))
322 (exp1 (gexp (mkdir (ungexp output "foo"))))
323 (exp2 (gexp (begin (display "hi!")
324 (ungexp-splicing (list exp0 exp1))))))
326 (append (gexp-outputs exp0) (gexp-outputs exp1))
328 (= 2 (length (gexp-outputs exp2))))))
330 (test-assertm "gexp->file"
331 (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
332 (guile (package-file %bootstrap-guile))
333 (sexp (gexp->sexp exp))
334 (drv (gexp->file "foo" exp))
335 (out -> (derivation->output-path drv))
336 (done (built-derivations (list drv)))
337 (refs ((store-lift references) out)))
338 (return (and (equal? sexp (call-with-input-file out read))
339 (equal? (list guile) refs)))))
341 (test-assertm "gexp->derivation"
342 (mlet* %store-monad ((file (text-file "foo" "Hello, world!"))
345 (mkdir (ungexp output))
346 (chdir (ungexp output))
348 (string-append (ungexp %bootstrap-guile)
351 (symlink (ungexp file)
352 (ungexp output "2nd")))))
353 (drv (gexp->derivation "foo" exp))
354 (out -> (derivation->output-path drv))
355 (out2 -> (derivation->output-path drv "2nd"))
356 (done (built-derivations (list drv)))
357 (refs ((store-lift references) out))
358 (refs2 ((store-lift references) out2))
359 (guile (package-file %bootstrap-guile "bin/guile")))
360 (return (and (string=? (readlink (string-append out "/foo")) guile)
361 (string=? (readlink out2) file)
362 (equal? refs (list (dirname (dirname guile))))
363 (equal? refs2 (list file))))))
365 (test-assertm "gexp->derivation vs. grafts"
366 (mlet* %store-monad ((graft? (set-grafting #f))
367 (p0 -> (dummy-package "dummy"
369 '(#:implicit-inputs? #f))))
370 (r -> (package (inherit p0) (name "DuMMY")))
371 (p1 -> (package (inherit p0) (replacement r)))
372 (exp0 -> (gexp (frob (ungexp p0) (ungexp output))))
373 (exp1 -> (gexp (frob (ungexp p1) (ungexp output))))
374 (void (set-guile-for-build %bootstrap-guile))
375 (drv0 (gexp->derivation "t" exp0 #:graft? #t))
376 (drv1 (gexp->derivation "t" exp1 #:graft? #t))
377 (drv1* (gexp->derivation "t" exp1 #:graft? #f))
378 (_ (set-grafting graft?)))
379 (return (and (not (string=? (derivation->output-path drv0)
380 (derivation->output-path drv1)))
381 (string=? (derivation->output-path drv0)
382 (derivation->output-path drv1*))))))
384 (test-assertm "gexp->derivation, composed gexps"
385 (mlet* %store-monad ((exp0 -> (gexp (begin
386 (mkdir (ungexp output))
387 (chdir (ungexp output)))))
388 (exp1 -> (gexp (symlink
389 (string-append (ungexp %bootstrap-guile)
392 (exp -> (gexp (begin (ungexp exp0) (ungexp exp1))))
393 (drv (gexp->derivation "foo" exp))
394 (out -> (derivation->output-path drv))
395 (done (built-derivations (list drv)))
396 (guile (package-file %bootstrap-guile "bin/guile")))
397 (return (string=? (readlink (string-append out "/foo"))
400 (test-assertm "gexp->derivation, default system"
401 ;; The default system should be the one at '>>=' time, not the one at
402 ;; invocation time. See <http://bugs.gnu.org/18002>.
403 (let ((system (%current-system))
404 (mdrv (parameterize ((%current-system "foobar64-linux"))
405 (gexp->derivation "foo"
407 (mkdir (ungexp output)))))))
408 (mlet %store-monad ((drv mdrv))
409 (return (string=? system (derivation-system drv))))))
411 (test-assertm "gexp->derivation, local-file"
412 (mlet* %store-monad ((file -> (search-path %load-path "guix.scm"))
413 (intd (interned-file file #:recursive? #f))
414 (local -> (local-file file))
416 (stat (ungexp local))
417 (symlink (ungexp local)
419 (drv (gexp->derivation "local-file" exp)))
421 (built-derivations (list drv))
422 (return (string=? (readlink (derivation->output-path drv))
425 (test-assertm "gexp->derivation, cross-compilation"
426 (mlet* %store-monad ((target -> "mips64el-linux")
427 (exp -> (gexp (list (ungexp coreutils)
429 (xdrv (gexp->derivation "foo" exp
431 (refs ((store-lift references)
432 (derivation-file-name xdrv)))
433 (xcu (package->cross-derivation coreutils
435 (cu (package->derivation coreutils)))
436 (return (and (member (derivation-file-name xcu) refs)
437 (not (member (derivation-file-name cu) refs))))))
439 (test-assertm "gexp->derivation, ungexp-native"
440 (mlet* %store-monad ((target -> "mips64el-linux")
441 (exp -> (gexp (list (ungexp-native coreutils)
443 (xdrv (gexp->derivation "foo" exp
445 (drv (gexp->derivation "foo" exp)))
446 (return (string=? (derivation-file-name drv)
447 (derivation-file-name xdrv)))))
449 (test-assertm "gexp->derivation, ungexp + ungexp-native"
450 (mlet* %store-monad ((target -> "mips64el-linux")
451 (exp -> (gexp (list (ungexp-native coreutils)
454 (xdrv (gexp->derivation "foo" exp
456 (refs ((store-lift references)
457 (derivation-file-name xdrv)))
458 (xglibc (package->cross-derivation glibc target))
459 (cu (package->derivation coreutils)))
460 (return (and (member (derivation-file-name cu) refs)
461 (member (derivation-file-name xglibc) refs)))))
463 (test-assertm "gexp->derivation, ungexp-native + composed gexps"
464 (mlet* %store-monad ((target -> "mips64el-linux")
465 (exp0 -> (gexp (list 1 2
466 (ungexp coreutils))))
467 (exp -> (gexp (list 0 (ungexp-native exp0))))
468 (xdrv (gexp->derivation "foo" exp
470 (drv (gexp->derivation "foo" exp)))
471 (return (string=? (derivation-file-name drv)
472 (derivation-file-name xdrv)))))
474 (test-assertm "gexp->derivation, store copy"
475 (let ((build-one #~(call-with-output-file #$output
477 (display "This is the one." port))))
478 (build-two (lambda (one)
481 (symlink #$one (string-append #$output "/one"))
482 (call-with-output-file (string-append #$output "/two")
484 (display "This is the second one." port))))))
486 (use-modules (guix build store-copy))
489 (populate-store '("graph") #$output))))
490 (mlet* %store-monad ((one (gexp->derivation "one" build-one))
491 (two (gexp->derivation "two" (build-two one)))
492 (drv (gexp->derivation "store-copy" build-drv
496 '((guix build store-copy)
497 (guix build utils))))
498 (ok? (built-derivations (list drv)))
499 (out -> (derivation->output-path drv)))
500 (let ((one (derivation->output-path one))
501 (two (derivation->output-path two)))
503 (file-exists? (string-append out "/" one))
504 (file-exists? (string-append out "/" two))
505 (file-exists? (string-append out "/" two "/two"))
506 (string=? (readlink (string-append out "/" two "/one"))
509 (test-assertm "imported-files"
511 ((files -> `(("x" . ,(search-path %load-path "ice-9/q.scm"))
512 ("a/b/c" . ,(search-path %load-path
513 "guix/derivations.scm"))
514 ("p/q" . ,(search-path %load-path "guix.scm"))
515 ("p/z" . ,(search-path %load-path "guix/store.scm"))))
516 (drv (imported-files files)))
518 (built-derivations (list drv))
519 (let ((dir (derivation->output-path drv)))
523 (equal? (call-with-input-file (string-append dir "/" path)
525 (call-with-input-file source
526 get-bytevector-all))))
529 (test-assertm "gexp->derivation #:modules"
532 (use-modules (guix build utils))
533 (mkdir-p (string-append #$output "/guile/guix/nix"))
535 (drv (gexp->derivation "test-with-modules" build
536 #:modules '((guix build utils)))))
538 (built-derivations (list drv))
539 (let* ((p (derivation->output-path drv))
540 (s (stat (string-append p "/guile/guix/nix"))))
541 (return (eq? (stat:type s) 'directory))))))
543 (test-assertm "gexp->derivation #:references-graphs"
545 ((one (text-file "one" (random-text)))
546 (two (gexp->derivation "two"
547 #~(symlink #$one #$output:chbouib)))
548 (drv (gexp->derivation "ref-graphs"
550 (use-modules (guix build store-copy))
551 (with-output-to-file #$output
553 (write (call-with-input-file "guile"
554 read-reference-graph))))
555 (with-output-to-file #$output:one
557 (write (call-with-input-file "one"
558 read-reference-graph))))
559 (with-output-to-file #$output:two
561 (write (call-with-input-file "two"
562 read-reference-graph)))))
563 #:references-graphs `(("one" ,one)
564 ("two" ,two "chbouib")
565 ("guile" ,%bootstrap-guile))
566 #:modules '((guix build store-copy)
567 (guix build utils))))
568 (ok? (built-derivations (list drv)))
569 (guile-drv (package->derivation %bootstrap-guile))
570 (bash (interned-file (search-bootstrap-binary "bash"
572 "bash" #:recursive? #t))
573 (g-one -> (derivation->output-path drv "one"))
574 (g-two -> (derivation->output-path drv "two"))
575 (g-guile -> (derivation->output-path drv)))
577 (equal? (call-with-input-file g-one read) (list one))
579 (call-with-input-file g-two read)
580 (list one (derivation->output-path two "chbouib")))
582 ;; Note: %BOOTSTRAP-GUILE depends on the bootstrap Bash.
584 (call-with-input-file g-guile read)
585 (list (derivation->output-path guile-drv) bash))))))
587 (test-assertm "gexp->derivation #:allowed-references"
588 (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
592 (symlink #$output "self")
593 (symlink #$%bootstrap-guile
596 (list "out" %bootstrap-guile))))
597 (built-derivations (list drv))))
599 (test-assertm "gexp->derivation #:allowed-references, specific output"
600 (mlet* %store-monad ((in (gexp->derivation "thing"
603 (mkdir #$output:not-ok))))
604 (drv (gexp->derivation "allowed-refs"
609 (symlink #$output "self")
610 (symlink #$in:ok "ok"))
613 (gexp-input in "ok")))))
614 (built-derivations (list drv))))
616 (test-assert "gexp->derivation #:allowed-references, disallowed"
617 (let ((drv (run-with-store %store
618 (gexp->derivation "allowed-refs"
622 (symlink #$%bootstrap-guile "guile"))
623 #:allowed-references '()))))
624 (guard (c ((nix-protocol-error? c) #t))
625 (build-derivations %store (list drv))
628 (test-assertm "gexp->derivation #:disallowed-references, allowed"
629 (mlet %store-monad ((drv (gexp->derivation "disallowed-refs"
633 (symlink #$output "self")
634 (symlink #$%bootstrap-guile
636 #:disallowed-references '())))
637 (built-derivations (list drv))))
640 (test-assert "gexp->derivation #:disallowed-references"
641 (let ((drv (run-with-store %store
642 (gexp->derivation "disallowed-refs"
646 (symlink #$%bootstrap-guile "guile"))
647 #:disallowed-references (list %bootstrap-guile)))))
648 (guard (c ((nix-protocol-error? c) #t))
649 (build-derivations %store (list drv))
653 (string-append "#!" (derivation->output-path (%guile-for-build))
654 "/bin/guile --no-auto-compile"))
656 ;; If we're going to hit the silly shebang limit (128 chars on Linux-based
657 ;; systems), then skip the following test.
658 (test-skip (if (> (string-length shebang) 127) 2 0))
660 (test-assertm "gexp->script"
661 (mlet* %store-monad ((n -> (random (expt 2 50)))
664 (string-append (ungexp %bootstrap-guile)
667 '(display (expt (ungexp n) 2))))))
668 (drv (gexp->script "guile-thing" exp
669 #:guile %bootstrap-guile))
670 (out -> (derivation->output-path drv))
671 (done (built-derivations (list drv))))
672 (let* ((pipe (open-input-pipe out))
673 (str (get-string-all pipe)))
674 (return (and (zero? (close-pipe pipe))
675 (= (expt n 2) (string->number str)))))))
677 (test-assertm "program-file"
678 (let* ((n (random (expt 2 50)))
680 (use-modules (guix build utils))
681 (display (ungexp n)))))
682 (file (program-file "program" exp
683 #:modules '((guix build utils))
684 #:guile %bootstrap-guile)))
685 (mlet* %store-monad ((drv (lower-object file))
686 (out -> (derivation->output-path drv)))
688 (built-derivations (list drv))
689 (let* ((pipe (open-input-pipe out))
690 (str (get-string-all pipe)))
691 (return (and (zero? (close-pipe pipe))
692 (= n (string->number str)))))))))
694 (test-assertm "scheme-file"
695 (let* ((text (plain-file "foo" "Hello, world!"))
696 (scheme (scheme-file "bar" #~(list "foo" #$text))))
697 (mlet* %store-monad ((drv (lower-object scheme))
698 (text (lower-object text))
699 (out -> (derivation->output-path drv)))
701 (built-derivations (list drv))
702 (mlet %store-monad ((refs ((store-lift references) out)))
703 (return (and (equal? refs (list text))
704 (equal? `(list "foo" ,text)
705 (call-with-input-file out read)))))))))
707 (test-assert "text-file*"
708 (let ((references (store-lift references)))
709 (run-with-store %store
711 ((drv (package->derivation %bootstrap-guile))
712 (guile -> (derivation->output-path drv))
713 (file (text-file "bar" "This is bar."))
714 (text (text-file* "foo"
715 %bootstrap-guile "/bin/guile "
716 (gexp-input %bootstrap-guile "out") "/bin/guile "
719 (done (built-derivations (list text)))
720 (out -> (derivation->output-path text))
721 (refs (references out)))
722 ;; Make sure we get the right references and the right content.
723 (return (and (lset= string=? refs (list guile file))
724 (equal? (call-with-input-file out get-string-all)
725 (string-append guile "/bin/guile "
729 #:guile-for-build (package-derivation %store %bootstrap-guile))))
731 (test-assertm "mixed-text-file"
732 (mlet* %store-monad ((file -> (mixed-text-file "mixed"
734 %bootstrap-guile "/bin"))
735 (drv (lower-object file))
736 (out -> (derivation->output-path drv))
737 (guile-drv (package->derivation %bootstrap-guile))
738 (guile -> (derivation->output-path guile-drv)))
740 (built-derivations (list drv))
741 (mlet %store-monad ((refs ((store-lift references) out)))
742 (return (and (string=? (string-append "export PATH=" guile "/bin")
743 (call-with-input-file out get-string-all))
744 (equal? refs (list guile))))))))
746 (test-assert "gexp->derivation vs. %current-target-system"
747 (let ((mval (gexp->derivation "foo"
752 ;; The value of %CURRENT-TARGET-SYSTEM at bind-time should have no
754 (parameterize ((%current-target-system "fooooo"))
755 (derivation? (run-with-store %store mval)))))
757 (test-assertm "lower-object"
758 (mlet %store-monad ((drv1 (lower-object %bootstrap-guile))
759 (drv2 (lower-object (package-source coreutils)))
760 (item (lower-object (plain-file "foo" "Hello!"))))
761 (return (and (derivation? drv1) (derivation? drv2)
762 (store-path? item)))))
764 (test-assertm "lower-object, computed-file"
765 (let* ((text (plain-file "foo" "Hello!"))
768 (symlink #$%bootstrap-guile
769 (string-append #$output "/guile"))
770 (symlink #$text (string-append #$output "/text"))))
771 (computed (computed-file "computed" exp)))
772 (mlet* %store-monad ((text (lower-object text))
773 (guile-drv (lower-object %bootstrap-guile))
774 (comp-drv (lower-object computed))
775 (comp -> (derivation->output-path comp-drv)))
777 (built-derivations (list comp-drv))
778 (return (and (string=? (readlink (string-append comp "/guile"))
779 (derivation->output-path guile-drv))
780 (string=? (readlink (string-append comp "/text"))
783 (test-assert "printer"
784 (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
785 \"/bin/uname\"\\) [[:xdigit:]]+>$"
786 (with-output-to-string
789 (gexp (string-append (ungexp coreutils)
792 (test-assert "printer vs. ungexp-splicing"
793 (string-match "^#<gexp .* [[:xdigit:]]+>$"
794 (with-output-to-string
798 (gexp (begin (ungexp-splicing (gexp ())))))))))
801 '(gexp (foo (ungexp bar) (ungexp baz "out")
802 (ungexp (chbouib 42))
803 (ungexp-splicing (list x y z))
804 (ungexp-native foo) (ungexp-native foo "out")
805 (ungexp-native (chbouib 42))
806 (ungexp-native-splicing (list x y z))))
807 '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
808 #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
813 ;; eval: (put 'test-assertm 'scheme-indent-function 1)