X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/811b21fb15d36b06fde994ca7ef5916a9a19f250..97cb43e732a38758c95b7caf3963507188d011cf:/tests/inferior.scm diff --git a/tests/inferior.scm b/tests/inferior.scm index d1d5c00a77..963d405e33 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018-2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,9 +26,12 @@ #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (gnu packages guile) + #:use-module (gnu packages sqlite) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) - #:use-module (ice-9 match)) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim)) (define %top-srcdir (dirname (search-path %load-path "guix.scm"))) @@ -60,6 +63,46 @@ (close-inferior inferior) (list a (inferior-object? b)))))) +(test-equal "close-inferior" + '((hello) (world)) + (let* ((inferior1 (open-inferior %top-builddir #:command "scripts/guix")) + (lst1 (inferior-eval '(list 'hello) inferior1)) + (inferior2 (open-inferior %top-builddir #:command "scripts/guix")) + (lst2 (inferior-eval '(list 'world) inferior2))) + ;; This call succeeds if and only if INFERIOR2 does not also hold a file + ;; descriptor to the socketpair beneath INFERIOR1; otherwise it blocks. + ;; See . + (close-inferior inferior1) + + (close-inferior inferior2) + (list lst1 lst2))) + +(test-equal "&inferior-exception" + '(a b c d) + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((inferior-exception? c) + (close-inferior inferior) + (and (eq? inferior (inferior-exception-inferior c)) + (match (inferior-exception-stack c) + (((_ (files lines columns)) ..1) + (member "guix/repl.scm" files))) + (inferior-exception-arguments c)))) + (inferior-eval '(throw 'a 'b 'c 'd) inferior) + 'badness))) + +(test-equal "&inferior-exception, legacy mode" + '(a b c d) + ;; Omit #:command to open an inferior in "legacy" mode, where Guile runs + ;; directly. + (let ((inferior (open-inferior %top-builddir))) + (guard (c ((inferior-exception? c) + (close-inferior inferior) + (and (eq? inferior (inferior-exception-inferior c)) + (inferior-exception-arguments c)))) + (inferior-eval '(throw 'a 'b 'c 'd) inferior) + 'badness))) + (test-equal "inferior-packages" (take (sort (fold-packages (lambda (package lst) (cons (list (package-name package) @@ -89,6 +132,26 @@ (close-inferior inferior) result)))) +(test-equal "inferior-available-packages" + (take (sort (fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (alist-cons name version result) + result)) + '()) + (lambda (x y) + (stringlist (lambda (package) (list (package-name package) @@ -126,9 +189,9 @@ ,(package-version package) ,(package-location package)) ,@rest))))) - (list (map ->list (package-inputs guile-2.2)) - (map ->list (package-native-inputs guile-2.2)) - (map ->list (package-propagated-inputs guile-2.2)))) + (list (map ->list (package-inputs guile-3.0-latest)) + (map ->list (package-native-inputs guile-3.0-latest)) + (map ->list (package-propagated-inputs guile-3.0-latest)))) (let* ((inferior (open-inferior %top-builddir #:command "scripts/guix")) (guile (first (lookup-inferior-packages inferior "guile"))) @@ -149,7 +212,7 @@ result)) (test-equal "inferior-package-search-paths" - (package-native-search-paths guile-2.2) + (package-native-search-paths guile-3.0) (let* ((inferior (open-inferior %top-builddir #:command "scripts/guix")) (guile (first (lookup-inferior-packages inferior "guile"))) @@ -157,6 +220,47 @@ (close-inferior inferior) result)) +(test-equal "inferior-eval-with-store" + (add-text-to-store %store "foo" "Hello, world!") + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "foo" + "Hello, world!"))))) + +(test-assert "inferior-eval-with-store, &store-protocol-error" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) + "invalid character"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "we|rd/?!@" + "uh uh"))) + #f))) + +(test-equal "inferior-eval-with-store, exception" + '(the-answer = 42) + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((inferior-exception? c) + (close-inferior inferior) + (inferior-exception-arguments c))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (throw 'the-answer '= 42)))))) + +(test-equal "inferior-eval-with-store, not a procedure" + 'wrong-type-arg + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((inferior-exception? c) + (close-inferior inferior) + (car (inferior-exception-arguments c)))) + (inferior-eval-with-store inferior %store '(+ 1 2))))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") @@ -172,6 +276,25 @@ (list (inferior-package-derivation %store guile "x86_64-linux") (inferior-package-derivation %store guile "armhf-linux"))))) +(unless (package-replacement sqlite) + (test-skip 1)) + +(test-equal "inferior-package-replacement" + (package-derivation %store + (package-replacement sqlite) + "x86_64-linux") + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (packages (inferior-packages inferior))) + (match (lookup-inferior-packages inferior + (package-name sqlite) + (package-version sqlite)) + ((inferior-sqlite rest ...) + (inferior-package-derivation %store + (inferior-package-replacement + inferior-sqlite) + "x86_64-linux"))))) + (test-equal "inferior-package->manifest-entry" (manifest-entry->list (package->manifest-entry (first (find-best-packages-by-name "guile" #f)))) @@ -193,4 +316,40 @@ (close-inferior inferior) (map manifest-entry->list (manifest-entries manifest)))) +(test-equal "#:error-port stderr" + 42 + ;; There's a special case in open-bidirectional-pipe for + ;; (current-error-port) being stderr, so this test just checks that + ;; open-inferior doesn't raise an exception + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix" + #:error-port (current-error-port)))) + (and (inferior? inferior) + (inferior-eval '(display "test" (current-error-port)) inferior) + (let ((result (inferior-eval '(apply * '(6 7)) inferior))) + (close-inferior inferior) + result)))) + +(test-equal "#:error-port pipe" + "42" + (match (pipe) + ((port-to-read-from . port-to-write-to) + + (setvbuf port-to-read-from 'line) + (setvbuf port-to-write-to 'line) + + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix" + #:error-port port-to-write-to))) + (and (inferior? inferior) + (begin + (inferior-eval '(display "42\n" (current-error-port)) inferior) + + (let loop ((line (read-line port-to-read-from))) + (if (string=? line "42") + (begin + (close-inferior inferior) + line) + (loop (read-line port-to-read-from)))))))))) + (test-end "inferior")