1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
4 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
5 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
6 ;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
8 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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))
38 (test-begin "build-utils")
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))))
44 (test-equal "alist-cons-before, reference not found"
45 '((a . 1) (b . 2) (c . 3) (x . 42))
46 (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
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))))
52 (test-equal "alist-cons-after, reference not found"
53 '((a . 1) (b . 2) (c . 3) (x . 42))
54 (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
56 (test-equal "alist-replace"
57 '((a . 1) (b . 77) (c . 3))
58 (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))
60 (test-assert "alist-replace, key not found"
61 (not (false-if-exception
62 (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
64 (test-equal "fold-port-matches"
66 (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
68 (fold-port-matches cons '() "Guix" port))))
70 (test-equal "fold-port-matches, trickier"
71 (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
72 (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
74 (fold-port-matches cons '()
75 (list (char-set #\G #\g)
81 (test-equal "fold-port-matches, with unmatched chars"
84 #\G #\u #\i "Guix" "guiX" #\, #\space
86 (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
89 (fold-port-matches cons '()
90 (list (char-set #\G #\g)
97 (test-equal "wrap-program, one input, multiple calls"
99 (call-with-temporary-directory
101 (let ((bash (search-bootstrap-binary "bash" (%current-system)))
102 (foo (string-append directory "/foo")))
104 (call-with-output-file foo
107 "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
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
115 (with-environment-variable "PATH" (dirname bash)
116 (wrap-program foo `("GUIX_FOO" prefix ("hello")))
117 (wrap-program foo `("GUIX_BAR" prefix ("world")))
119 ;; The bootstrap Bash is linked against an old libc and would abort
120 ;; with an assertion failure when trying to load incompatible locale
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))
131 (test-assert "invoke/quiet, success"
133 (invoke/quiet "true")
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")
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")
149 (let ((script-contents "\
150 #!/anything/cabbage-bash-1.2.3/bin/sh
154 (test-equal "wrap-script, simple case"
157 #!~a --no-auto-compile
163 '(begin (let ((current (getenv "GUIX_FOO")))
166 (string-append "/some/path:/some/other/path"
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))))
173 (call-with-temporary-directory
175 (let ((script-file-name (string-append directory "/foo")))
176 (call-with-output-file script-file-name
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
188 (let ((script-contents "\
189 #!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
190 # vim:fileencoding=utf-8
191 print('hello world')"))
193 (test-equal "wrap-script, with encoding declaration"
196 #!MYGUILE --no-auto-compile
197 #!#; # vim:fileencoding=utf-8
201 '(begin (let ((current (getenv "GUIX_FOO")))
204 (string-append "/some/path:/some/other/path"
206 "/some/path:/some/other/path"))))
207 `(let ((cl (command-line)))
208 (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
210 (append '("-and" "-args") cl))))
212 (call-with-temporary-directory
214 (let ((script-file-name (string-append directory "/foo")))
215 (call-with-output-file script-file-name
217 (format port script-contents)))
218 (chmod script-file-name #o777)
220 (wrap-script script-file-name
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
229 (test-assert "wrap-script, raises condition"
230 (call-with-temporary-directory
232 (let ((script-file-name (string-append directory "/foo")))
233 (call-with-output-file script-file-name
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
240 `("GUIX_FOO" prefix ("/some/path"
241 "/some/other/path")))
244 (define (arg-test bash-args)
245 (call-with-temporary-directory
247 (let ((script-file-name (string-append directory "/bash-test.sh")))
248 (call-with-output-file script-file-name
250 (display (string-append "\
251 #!" (which "bash") bash-args "
252 echo \"$#$0$*${A}\"")
255 (display "Unwrapped script contents:\n")
256 (call-with-input-file script-file-name
257 (lambda (port) (display (get-string-all port))))
259 (chmod script-file-name #o777)
261 (let* ((run-script (lambda _
264 script-file-name "1" "2" "3 3" "4")))
266 (unwrapped-output (get-string-all pipe)))
269 (wrap-script script-file-name `("A" = ("A\nA")))
271 (display "Wrapped script contents:\n")
272 (call-with-input-file script-file-name
273 (lambda (port) (display (get-string-all port))))
276 (let* ((pipe (run-script))
277 (wrapped-output (get-string-all 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)))))))
286 (test-assert "wrap-script, argument handling"
289 (test-assert "wrap-script, argument handling, bash --norc"
290 (arg-test " --norc"))
292 (test-equal "substitute*, text contains a NUL byte, UTF-8"
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
303 (flush-output-port port)
309 (with-input-from-file file
311 (get-string-all (current-input-port))))))))
313 (test-equal "search-input-file: exception if not found"
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")))
321 (test-equal "search-input-file: can find if existent"
324 `(("guile/bin" . ,(dirname (which "guile"))))
327 (test-equal "search-input-file: can search in multiple directories"
329 (call-with-temporary-directory
332 `(("irrelevant" . ,directory)
333 ("guile/bin" . ,(dirname (which "guile"))))