projects/guix·blob master · refs

336 lines · 11.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <[email protected]>
3;;; Copyright © 2019 Ricardo Wurmus <[email protected]>
4;;; Copyright © 2021 Maxim Cournoyer <[email protected]>
5;;; Copyright © 2021 Maxime Devos <[email protected]>
6;;; Copyright © 2021 Brendan Tildesley <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23
24(define-module (test build-utils)
25 #:use-module (guix tests)
26 #:use-module (guix build utils)
27 #:use-module ((guix utils)
28 #:select (%current-system call-with-temporary-directory))
29 #:use-module (gnu packages)
30 #:use-module (gnu packages bootstrap)
31 #:use-module (srfi srfi-34)
32 #:use-module (srfi srfi-35)
33 #:use-module (srfi srfi-64)
34 #:use-module (rnrs io ports)
35 #:use-module (ice-9 popen))
36
37
38(test-begin "build-utils")
39
40(test-equal "alist-cons-before"
41 '((a . 1) (x . 42) (b . 2) (c . 3))
42 (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
43
44(test-assert "alist-cons-before, reference not found"
45 (not (false-if-exception
46 (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))))
47
48(test-equal "alist-cons-after"
49 '((a . 1) (b . 2) (x . 42) (c . 3))
50 (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
51
52(test-assert "alist-cons-after, reference not found"
53 (not (false-if-exception
54 (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))))
55
56(test-equal "alist-replace"
57 '((a . 1) (b . 77) (c . 3))
58 (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))
59
60(test-assert "alist-replace, key not found"
61 (not (false-if-exception
62 (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
63
64(test-equal "fold-port-matches"
65 (make-list 3 "Guix")
66 (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
67 (lambda (port)
68 (fold-port-matches cons '() "Guix" port))))
69
70(test-equal "fold-port-matches, trickier"
71 (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
72 (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
73 (lambda (port)
74 (fold-port-matches cons '()
75 (list (char-set #\G #\g)
76 (char-set #\u)
77 (char-set #\i)
78 (char-set #\x #\X))
79 port))))
80
81(test-equal "fold-port-matches, with unmatched chars"
82 '("Guix" #\, #\space
83 "guix" #\, #\space
84 #\G #\u #\i "Guix" "guiX" #\, #\space
85 "Guix")
86 (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
87 (lambda (port)
88 (reverse
89 (fold-port-matches cons '()
90 (list (char-set #\G #\g)
91 (char-set #\u)
92 (char-set #\i)
93 (char-set #\x #\X))
94 port
95 cons)))))
96
97(test-equal "wrap-program, one input, multiple calls"
98 "hello world\n"
99 (call-with-temporary-directory
100 (lambda (directory)
101 (let ((bash (search-bootstrap-binary "bash" (%current-system)))
102 (foo (string-append directory "/foo")))
103
104 (call-with-output-file foo
105 (lambda (p)
106 (format p
107 "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
108 bash)))
109 (chmod foo #o777)
110
111 ;; wrap-program uses `which' to find bash for the wrapper shebang, but
112 ;; it can't know about the bootstrap bash in the store, since it's not
113 ;; named "bash". Help it out a bit by providing a symlink it this
114 ;; package's output.
115 (with-environment-variable "PATH" (dirname bash)
116 (wrap-program foo `("GUIX_FOO" prefix ("hello")))
117 (wrap-program foo `("GUIX_BAR" prefix ("world")))
118
119 ;; The bootstrap Bash is linked against an old libc and would abort
120 ;; with an assertion failure when trying to load incompatible locale
121 ;; data.
122 (unsetenv "LOCPATH")
123
124 (let* ((pipe (open-input-pipe foo))
125 (str (get-string-all pipe)))
126 (with-directory-excursion directory
127 (for-each delete-file '("foo" ".foo-real")))
128 (and (zero? (close-pipe pipe))
129 str)))))))
130
131(test-assert "invoke/quiet, success"
132 (begin
133 (invoke/quiet "true")
134 #t))
135
136(test-assert "invoke/quiet, failure"
137 (guard (c ((message-condition? c)
138 (string-contains (condition-message c) "This is an error.")))
139 (invoke/quiet "sh" "-c" "echo This is an error. ; false")
140 #f))
141
142(test-assert "invoke/quiet, failure, message on stderr"
143 (guard (c ((message-condition? c)
144 (string-contains (condition-message c)
145 "This is another error.")))
146 (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
147 #f))
148
149(let ((script-contents "\
150#!/anything/cabbage-bash-1.2.3/bin/sh
151
152echo hello world"))
153
154 (test-equal "wrap-script, simple case"
155 (string-append
156 (format #f "\
157#!~a --no-auto-compile
158#!#; Guix wrapper
159#\\-~s
160#\\-~s
161"
162 (which "guile")
163 '(begin (let ((current (getenv "GUIX_FOO")))
164 (setenv "GUIX_FOO"
165 (if current
166 (string-append "/some/path:/some/other/path"
167 ":" current)
168 "/some/path:/some/other/path"))))
169 '(let ((cl (command-line)))
170 (apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
171 (car cl) (append (quote ()) cl))))
172 script-contents)
173 (call-with-temporary-directory
174 (lambda (directory)
175 (let ((script-file-name (string-append directory "/foo")))
176 (call-with-output-file script-file-name
177 (lambda (port)
178 (display script-contents port)))
179 (chmod script-file-name #o777)
180 (wrap-script script-file-name
181 `("GUIX_FOO" prefix ("/some/path"
182 "/some/other/path")))
183 (let ((str (call-with-input-file script-file-name get-string-all)))
184 (with-directory-excursion directory
185 (delete-file "foo"))
186 str))))))
187
188(let ((script-contents "\
189#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
190# vim:fileencoding=utf-8
191print('hello world')"))
192
193 (test-equal "wrap-script, with encoding declaration"
194 (string-append
195 (format #f "\
196#!MYGUILE --no-auto-compile
197#!#; # vim:fileencoding=utf-8
198#\\-~s
199#\\-~s
200"
201 '(begin (let ((current (getenv "GUIX_FOO")))
202 (setenv "GUIX_FOO"
203 (if current
204 (string-append "/some/path:/some/other/path"
205 ":" current)
206 "/some/path:/some/other/path"))))
207 `(let ((cl (command-line)))
208 (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
209 (car cl)
210 (append '("-and" "-args") cl))))
211 script-contents)
212 (call-with-temporary-directory
213 (lambda (directory)
214 (let ((script-file-name (string-append directory "/foo")))
215 (call-with-output-file script-file-name
216 (lambda (port)
217 (format port script-contents)))
218 (chmod script-file-name #o777)
219
220 (wrap-script script-file-name
221 #:guile "MYGUILE"
222 `("GUIX_FOO" prefix ("/some/path"
223 "/some/other/path")))
224 (let ((str (call-with-input-file script-file-name get-string-all)))
225 (with-directory-excursion directory
226 (delete-file "foo"))
227 str))))))
228
229(test-assert "wrap-script, raises condition"
230 (call-with-temporary-directory
231 (lambda (directory)
232 (let ((script-file-name (string-append directory "/foo")))
233 (call-with-output-file script-file-name
234 (lambda (port)
235 (format port "This is not a script")))
236 (chmod script-file-name #o777)
237 (guard (c ((wrap-error? c) #t))
238 (wrap-script script-file-name
239 #:guile "MYGUILE"
240 `("GUIX_FOO" prefix ("/some/path"
241 "/some/other/path")))
242 #f)))))
243
244(define (arg-test bash-args)
245 (call-with-temporary-directory
246 (lambda (directory)
247 (let ((script-file-name (string-append directory "/bash-test.sh")))
248 (call-with-output-file script-file-name
249 (lambda (port)
250 (display (string-append "\
251#!" (which "bash") bash-args "
252echo \"$#$0$*${A}\"")
253 port)))
254
255 (display "Unwrapped script contents:\n")
256 (call-with-input-file script-file-name
257 (lambda (port) (display (get-string-all port))))
258 (newline) (newline)
259 (chmod script-file-name #o777)
260 (setenv "A" "A")
261 (let* ((run-script (lambda _
262 (open-pipe*
263 OPEN_READ
264 script-file-name "1" "2" "3 3" "4")))
265 (pipe (run-script))
266 (unwrapped-output (get-string-all pipe)))
267 (close-pipe pipe)
268
269 (wrap-script script-file-name `("A" = ("A\nA")))
270
271 (display "Wrapped script contents:\n")
272 (call-with-input-file script-file-name
273 (lambda (port) (display (get-string-all port))))
274 (newline) (newline)
275
276 (let* ((pipe (run-script))
277 (wrapped-output (get-string-all pipe)))
278 (close-pipe pipe)
279 (display "./bash-test.sh 1 2 3\\ 3 4 # Output:\n")
280 (display unwrapped-output) (newline)
281 (display "./bash-test.sh 1 2 3\\ 3 4 # Output (wrapped):\n")
282 (display wrapped-output) (newline)
283 (string=? (string-append unwrapped-output "A\n")
284 wrapped-output)))))))
285
286(test-assert "wrap-script, argument handling"
287 (arg-test ""))
288
289(test-assert "wrap-script, argument handling, bash --norc"
290 (arg-test " --norc"))
291
292(test-equal "substitute*, text contains a NUL byte, UTF-8"
293 "c\0d"
294 (with-fluids ((%default-port-encoding "UTF-8")
295 (%default-port-conversion-strategy 'error))
296 ;; The GNU libc is locale sensitive. Depending on the value of LANG, the
297 ;; test could fail with "string contains #\\nul character: ~S" or "cannot
298 ;; convert wide string to output locale".
299 (setlocale LC_ALL "en_US.UTF-8")
300 (call-with-temporary-output-file
301 (lambda (file port)
302 (format port "a\0b")
303 (flush-output-port port)
304
305 (substitute* file
306 (("a") "c")
307 (("b") "d"))
308
309 (with-input-from-file file
310 (lambda _
311 (get-string-all (current-input-port))))))))
312
313(test-equal "search-input-file: exception if not found"
314 `((path)
315 (file . "does-not-exist"))
316 (guard (e ((search-error? e)
317 `((path . ,(search-error-path e))
318 (file . ,(search-error-file e)))))
319 (search-input-file '() "does-not-exist")))
320
321(test-equal "search-input-file: can find if existent"
322 (which "guile")
323 (search-input-file
324 `(("guile/bin" . ,(dirname (which "guile"))))
325 "guile"))
326
327(test-equal "search-input-file: can search in multiple directories"
328 (which "guile")
329 (call-with-temporary-directory
330 (lambda (directory)
331 (search-input-file
332 `(("irrelevant" . ,directory)
333 ("guile/bin" . ,(dirname (which "guile"))))
334 "guile"))))
335
336(test-end)