projects/guix·blob python-team · refs

355 lines · 14.7 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2018-2022 Ludovic Courtès <[email protected]>
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-inferior)
20 #:use-module (guix tests)
21 #:use-module (guix inferior)
22 #:use-module (guix packages)
23 #:use-module (guix store)
24 #:use-module (guix profiles)
25 #:use-module (guix derivations)
26 #:use-module (gnu packages)
27 #:use-module (gnu packages bootstrap)
28 #:use-module (gnu packages guile)
29 #:use-module (gnu packages sqlite)
30 #:use-module (srfi srfi-1)
31 #:use-module (srfi srfi-34)
32 #:use-module (srfi srfi-64)
33 #:use-module (ice-9 match)
34 #:use-module (ice-9 rdelim))
35
36(define %top-srcdir
37 (dirname (search-path %load-path "guix.scm")))
38
39(define %top-builddir
40 (dirname (search-path %load-compiled-path "guix.go")))
41
42(define %store
43 (open-connection-for-tests))
44
45(define (manifest-entry->list entry)
46 (list (manifest-entry-name entry)
47 (manifest-entry-version entry)
48 (manifest-entry-output entry)
49 (manifest-entry-search-paths entry)
50 (map manifest-entry->list (manifest-entry-dependencies entry))))
51
52
53(test-begin "inferior")
54
55(test-equal "open-inferior"
56 '(42 #t)
57 (let ((inferior (open-inferior %top-builddir
58 #:command "scripts/guix")))
59 (and (inferior? inferior)
60 (let ((a (inferior-eval '(apply * '(6 7)) inferior))
61 (b (inferior-eval '(@ (gnu packages base) coreutils)
62 inferior)))
63 (close-inferior inferior)
64 (list a (inferior-object? b))))))
65
66(test-equal "close-inferior"
67 '((hello) (world))
68 (let* ((inferior1 (open-inferior %top-builddir #:command "scripts/guix"))
69 (lst1 (inferior-eval '(list 'hello) inferior1))
70 (inferior2 (open-inferior %top-builddir #:command "scripts/guix"))
71 (lst2 (inferior-eval '(list 'world) inferior2)))
72 ;; This call succeeds if and only if INFERIOR2 does not also hold a file
73 ;; descriptor to the socketpair beneath INFERIOR1; otherwise it blocks.
74 ;; See <https://issues.guix.gnu.org/55441#10>.
75 (close-inferior inferior1)
76
77 (close-inferior inferior2)
78 (list lst1 lst2)))
79
80(test-equal "&inferior-exception"
81 '(a b c d)
82 (let ((inferior (open-inferior %top-builddir
83 #:command "scripts/guix")))
84 (guard (c ((inferior-exception? c)
85 (close-inferior inferior)
86 (and (eq? inferior (inferior-exception-inferior c))
87 (match (inferior-exception-stack c)
88 (((_ (files lines columns)) ..1)
89 (member "guix/repl.scm" files)))
90 (inferior-exception-arguments c))))
91 (inferior-eval '(throw 'a 'b 'c 'd) inferior)
92 'badness)))
93
94(test-equal "&inferior-exception, legacy mode"
95 '(a b c d)
96 ;; Omit #:command to open an inferior in "legacy" mode, where Guile runs
97 ;; directly.
98 (let ((inferior (open-inferior %top-builddir)))
99 (guard (c ((inferior-exception? c)
100 (close-inferior inferior)
101 (and (eq? inferior (inferior-exception-inferior c))
102 (inferior-exception-arguments c))))
103 (inferior-eval '(throw 'a 'b 'c 'd) inferior)
104 'badness)))
105
106(test-equal "inferior-packages"
107 (take (sort (fold-packages (lambda (package lst)
108 (cons (list (package-name package)
109 (package-version package)
110 (package-home-page package)
111 (package-location package))
112 lst))
113 '())
114 (lambda (x y)
115 (string<? (car x) (car y))))
116 10)
117 (let* ((inferior (open-inferior %top-builddir
118 #:command "scripts/guix"))
119 (packages (inferior-packages inferior)))
120 (and (every string? (map inferior-package-synopsis packages))
121 (let ()
122 (define result
123 (take (sort (map (lambda (package)
124 (list (inferior-package-name package)
125 (inferior-package-version package)
126 (inferior-package-home-page package)
127 (inferior-package-location package)))
128 packages)
129 (lambda (x y)
130 (string<? (car x) (car y))))
131 10))
132 (close-inferior inferior)
133 result))))
134
135(test-equal "inferior-available-packages"
136 (take (sort (fold-available-packages
137 (lambda* (name version result
138 #:key supported? deprecated?
139 #:allow-other-keys)
140 (if (and supported? (not deprecated?))
141 (alist-cons name version result)
142 result))
143 '())
144 (lambda (x y)
145 (string<? (car x) (car y))))
146 10)
147 (let* ((inferior (open-inferior %top-builddir
148 #:command "scripts/guix"))
149 (packages (inferior-available-packages inferior)))
150 (close-inferior inferior)
151 (take (sort packages (lambda (x y)
152 (string<? (car x) (car y))))
153 10)))
154
155(test-equal "lookup-inferior-packages"
156 (let ((->list (lambda (package)
157 (list (package-name package)
158 (package-version package)
159 (package-location package)))))
160 (list (map ->list (find-packages-by-name "guile" #f))
161 (map ->list (find-packages-by-name "guile" "2.2"))))
162 (let* ((inferior (open-inferior %top-builddir
163 #:command "scripts/guix"))
164 (->list (lambda (package)
165 (list (inferior-package-name package)
166 (inferior-package-version package)
167 (inferior-package-location package))))
168 (lst1 (map ->list
169 (lookup-inferior-packages inferior "guile")))
170 (lst2 (map ->list
171 (lookup-inferior-packages inferior
172 "guile" "2.2"))))
173 (close-inferior inferior)
174 (list lst1 lst2)))
175
176(test-assert "lookup-inferior-packages and eq?-ness"
177 (let* ((inferior (open-inferior %top-builddir
178 #:command "scripts/guix"))
179 (lst1 (lookup-inferior-packages inferior "guile"))
180 (lst2 (lookup-inferior-packages inferior "guile")))
181 (close-inferior inferior)
182 (every eq? lst1 lst2)))
183
184(test-equal "inferior-package-inputs"
185 (let ((->list (match-lambda
186 ((label (? package? package) . rest)
187 `(,label
188 (package ,(package-name package)
189 ,(package-version package)
190 ,(package-location package))
191 ,@rest)))))
192 (list (map ->list (package-inputs guile-3.0-latest))
193 (map ->list (package-native-inputs guile-3.0-latest))
194 (map ->list (package-propagated-inputs guile-3.0-latest))))
195 (let* ((inferior (open-inferior %top-builddir
196 #:command "scripts/guix"))
197 (guile (first (lookup-inferior-packages inferior "guile")))
198 (->list (match-lambda
199 ((label (? inferior-package? package) . rest)
200 `(,label
201 (package ,(inferior-package-name package)
202 ,(inferior-package-version package)
203 ,(inferior-package-location package))
204 ,@rest))))
205 (result (list (map ->list (inferior-package-inputs guile))
206 (map ->list
207 (inferior-package-native-inputs guile))
208 (map ->list
209 (inferior-package-propagated-inputs
210 guile)))))
211 (close-inferior inferior)
212 result))
213
214(test-equal "inferior-package-search-paths"
215 (package-native-search-paths guile-3.0)
216 (let* ((inferior (open-inferior %top-builddir
217 #:command "scripts/guix"))
218 (guile (first (lookup-inferior-packages inferior "guile")))
219 (result (inferior-package-native-search-paths guile)))
220 (close-inferior inferior)
221 result))
222
223(test-equal "inferior-eval-with-store"
224 (add-text-to-store %store "foo" "Hello, world!")
225 (let* ((inferior (open-inferior %top-builddir
226 #:command "scripts/guix")))
227 (inferior-eval-with-store inferior %store
228 '(lambda (store)
229 (add-text-to-store store "foo"
230 "Hello, world!")))))
231
232(test-assert "inferior-eval-with-store, &store-protocol-error"
233 (let* ((inferior (open-inferior %top-builddir
234 #:command "scripts/guix")))
235 (guard (c ((store-protocol-error? c)
236 (string-contains (store-protocol-error-message c)
237 "invalid character")))
238 (inferior-eval-with-store inferior %store
239 '(lambda (store)
240 (add-text-to-store store "we|rd/?!@"
241 "uh uh")))
242 #f)))
243
244(test-equal "inferior-eval-with-store, exception"
245 '(the-answer = 42)
246 (let ((inferior (open-inferior %top-builddir
247 #:command "scripts/guix")))
248 (guard (c ((inferior-exception? c)
249 (close-inferior inferior)
250 (inferior-exception-arguments c)))
251 (inferior-eval-with-store inferior %store
252 '(lambda (store)
253 (throw 'the-answer '= 42))))))
254
255(test-equal "inferior-eval-with-store, not a procedure"
256 'wrong-type-arg
257 (let ((inferior (open-inferior %top-builddir
258 #:command "scripts/guix")))
259 (guard (c ((inferior-exception? c)
260 (close-inferior inferior)
261 (car (inferior-exception-arguments c))))
262 (inferior-eval-with-store inferior %store '(+ 1 2)))))
263
264(test-equal "inferior-package-derivation"
265 (map derivation-file-name
266 (list (package-derivation %store %bootstrap-guile "x86_64-linux")
267 (package-derivation %store %bootstrap-guile "armhf-linux")))
268 (let* ((inferior (open-inferior %top-builddir
269 #:command "scripts/guix"))
270 (packages (inferior-packages inferior))
271 (guile (find (lambda (package)
272 (string=? (package-name %bootstrap-guile)
273 (inferior-package-name package)))
274 packages)))
275 (map derivation-file-name
276 (list (inferior-package-derivation %store guile "x86_64-linux")
277 (inferior-package-derivation %store guile "armhf-linux")))))
278
279(unless (package-replacement sqlite)
280 (test-skip 1))
281
282(test-equal "inferior-package-replacement"
283 (package-derivation %store
284 (package-replacement sqlite)
285 "x86_64-linux")
286 (let* ((inferior (open-inferior %top-builddir
287 #:command "scripts/guix"))
288 (packages (inferior-packages inferior)))
289 (match (lookup-inferior-packages inferior
290 (package-name sqlite)
291 (package-version sqlite))
292 ((inferior-sqlite rest ...)
293 (inferior-package-derivation %store
294 (inferior-package-replacement
295 inferior-sqlite)
296 "x86_64-linux")))))
297
298(test-equal "inferior-package->manifest-entry"
299 (manifest-entry->list (package->manifest-entry
300 (first (find-best-packages-by-name "guile" #f))))
301 (let* ((inferior (open-inferior %top-builddir
302 #:command "scripts/guix"))
303 (guile (first (lookup-inferior-packages inferior "guile")))
304 (entry (inferior-package->manifest-entry guile)))
305 (close-inferior inferior)
306 (manifest-entry->list entry)))
307
308(test-equal "packages->manifest"
309 (map manifest-entry->list
310 (manifest-entries (packages->manifest
311 (find-best-packages-by-name "guile" #f))))
312 (let* ((inferior (open-inferior %top-builddir
313 #:command "scripts/guix"))
314 (guile (first (lookup-inferior-packages inferior "guile")))
315 (manifest (packages->manifest (list guile))))
316 (close-inferior inferior)
317 (map manifest-entry->list (manifest-entries manifest))))
318
319(test-equal "#:error-port stderr"
320 42
321 ;; There's a special case in open-bidirectional-pipe for
322 ;; (current-error-port) being stderr, so this test just checks that
323 ;; open-inferior doesn't raise an exception
324 (let ((inferior (open-inferior %top-builddir
325 #:command "scripts/guix"
326 #:error-port (current-error-port))))
327 (and (inferior? inferior)
328 (inferior-eval '(display "test" (current-error-port)) inferior)
329 (let ((result (inferior-eval '(apply * '(6 7)) inferior)))
330 (close-inferior inferior)
331 result))))
332
333(test-equal "#:error-port pipe"
334 "42"
335 (match (pipe)
336 ((port-to-read-from . port-to-write-to)
337
338 (setvbuf port-to-read-from 'line)
339 (setvbuf port-to-write-to 'line)
340
341 (let ((inferior (open-inferior %top-builddir
342 #:command "scripts/guix"
343 #:error-port port-to-write-to)))
344 (and (inferior? inferior)
345 (begin
346 (inferior-eval '(display "42\n" (current-error-port)) inferior)
347
348 (let loop ((line (read-line port-to-read-from)))
349 (if (string=? line "42")
350 (begin
351 (close-inferior inferior)
352 line)
353 (loop (read-line port-to-read-from))))))))))
354
355(test-end "inferior")