projects/guix·blob master · refs

375 lines · 14.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2021, 2024 Ludovic Courtès <[email protected]>
3;;; Copyright © 2014 Eric Bavier <[email protected]>
4;;; Copyright © 2016 Mathieu Lirzin <[email protected]>
5;;; Copyright © 2021 Simon Tournier <[email protected]>
6;;; Copyright © 2021 Maxime Devos <[email protected]>
7;;; Copyright © 2023 Foundation Devices, Inc. <[email protected]>
8;;; Copyright © 2024 Herman Rimm <[email protected]>
9;;;
10;;; This file is part of GNU Guix.
11;;;
12;;; GNU Guix is free software; you can redistribute it and/or modify it
13;;; under the terms of the GNU General Public License as published by
14;;; the Free Software Foundation; either version 3 of the License, or (at
15;;; your option) any later version.
16;;;
17;;; GNU Guix is distributed in the hope that it will be useful, but
18;;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;;; GNU General Public License for more details.
21;;;
22;;; You should have received a copy of the GNU General Public License
23;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
24
25(define-module (test-utils)
26 #:use-module ((guix config) #:select (%gzip))
27 #:use-module (guix utils)
28 #:use-module ((guix build utils) #:select (call-with-temporary-output-file))
29 #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
30 #:use-module ((guix search-paths) #:select (string-tokenize*))
31 #:use-module (srfi srfi-1)
32 #:use-module (srfi srfi-11)
33 #:use-module (srfi srfi-64)
34 #:use-module (rnrs bytevectors)
35 #:use-module (rnrs io ports)
36 #:use-module (ice-9 match)
37 #:use-module (ice-9 vlist))
38
39(define temp-file
40 (string-append "t-utils-" (number->string (getpid))))
41
42(test-begin "utils")
43
44(test-assert "gnu-triplet->nix-system"
45 (let ((samples '(("i586-gnu0.3" "i686-gnu")
46 ("x86_64-unknown-linux-gnu" "x86_64-linux")
47 ("i386-pc-linux-gnu" "i686-linux")
48 ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
49 ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
50 ("i686-pc-cygwin" "i686-cygwin"))))
51 (let-values (((gnu nix) (unzip2 samples)))
52 (every (lambda (gnu nix)
53 (equal? nix (gnu-triplet->nix-system gnu)))
54 gnu nix))))
55
56(test-assert "package-name->name+version"
57 (every (match-lambda
58 ((name version)
59 (let*-values (((full-name)
60 (if version
61 (string-append name "@" version)
62 name))
63 ((name* version*)
64 (package-name->name+version full-name)))
65 (and (equal? name* name)
66 (equal? version* version)))))
67 '(("foo" "0.9.1b")
68 ("foo-14-bar" "320")
69 ("foo-bar2" #f)
70 ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
71 ("nixpkgs" "1.0pre22125_a28fe19")
72 ("gtk2" "2.38.0"))))
73
74(test-assert "guile-version>? 1.8"
75 (guile-version>? "1.8"))
76
77(test-assert "guile-version>? 10.5"
78 (not (guile-version>? "10.5")))
79
80(test-assert "version-prefix?"
81 (and (version-prefix? "4.1" "4.1.2")
82 (version-prefix? "4.1" "4.1")
83 (not (version-prefix? "4.1" "4.16.2"))
84 (not (version-prefix? "4.1" "4"))))
85
86(test-equal "version-unique-prefix"
87 '("2" "2.2" "")
88 (list (version-unique-prefix "2.0" '("3.0" "2.0"))
89 (version-unique-prefix "2.2" '("3.0.5" "2.0.9" "2.2.7"))
90 (version-unique-prefix "27.1" '("27.1"))))
91
92(test-equal "string-tokenize*"
93 '(("foo")
94 ("foo" "bar" "baz")
95 ("foo" "bar" "")
96 ("foo" "bar" "baz"))
97 (list (string-tokenize* "foo" ":")
98 (string-tokenize* "foo;bar;baz" ";")
99 (string-tokenize* "foo!bar!" "!")
100 (string-tokenize* "foo+-+bar+-+baz" "+-+")))
101
102(test-equal "string-replace-substring"
103 '("foo BAR! baz"
104 "/gnu/store/chbouib"
105 "")
106 (list (string-replace-substring "foo bar baz" "bar" "BAR!")
107 (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
108 (string-replace-substring "" "foo" "bar")))
109
110(test-equal "strip-keyword-arguments"
111 '(a #:b b #:c c)
112 (strip-keyword-arguments '(#:foo #:bar #:baz)
113 '(a #:foo 42 #:b b #:baz 3
114 #:c c #:bar 4)))
115
116(test-equal "ensure-keyword-arguments"
117 '((#:foo 2)
118 (#:foo 2 #:bar 3)
119 (#:foo 42 #:bar 3))
120 (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
121 (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
122 (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
123
124(test-equal "default-keyword-arguments"
125 '((#:foo 2)
126 (#:foo 2)
127 (#:foo 2 #:bar 3)
128 (#:foo 2 #:bar 3)
129 (#:foo 2 #:bar 3))
130 (list (default-keyword-arguments '() '(#:foo 2))
131 (default-keyword-arguments '(#:foo 2) '(#:foo 4))
132 (default-keyword-arguments '() '(#:bar 3 #:foo 2))
133 (default-keyword-arguments '(#:bar 3) '(#:foo 2))
134 (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))
135
136(test-equal "substitute-keyword-arguments"
137 '((#:foo 3)
138 (#:foo 3)
139 (#:foo 3 #:bar (1 2))
140 (#:bar (1 2) #:foo 3)
141 (#:foo 3))
142 (list (substitute-keyword-arguments '(#:foo 2)
143 ((#:foo f) (1+ f)))
144 (substitute-keyword-arguments '()
145 ((#:foo f 2) (1+ f)))
146 (substitute-keyword-arguments '(#:foo 2 #:bar (2))
147 ((#:foo f) (1+ f))
148 ((#:bar b) (cons 1 b)))
149 (substitute-keyword-arguments '(#:foo 2)
150 ((#:foo _) 3)
151 ((#:bar b '(2)) (cons 1 b)))
152 (substitute-keyword-arguments '(#:foo 2)
153 ((#:foo f 1) (1+ f))
154 ((#:bar b) (cons 42 b)))))
155
156(test-assert "filtered-port, file"
157 (let* ((file (search-path %load-path "guix.scm"))
158 (input (open-file file "r0b")))
159 (let*-values (((compressed pids1)
160 (filtered-port `(,%gzip "-c" "--fast") input))
161 ((decompressed pids2)
162 (filtered-port `(,%gzip "-d") compressed)))
163 (and (every (compose zero? cdr waitpid)
164 (append pids1 pids2))
165 (equal? (get-bytevector-all decompressed)
166 (call-with-input-file file get-bytevector-all))))))
167
168(test-assert "filtered-port, non-file"
169 (let ((data (call-with-input-file (search-path %load-path "guix.scm")
170 get-bytevector-all)))
171 (let*-values (((compressed pids1)
172 (filtered-port `(,%gzip "-c" "--fast")
173 (open-bytevector-input-port data)))
174 ((decompressed pids2)
175 (filtered-port `(,%gzip "-d") compressed)))
176 (and (pk (every (compose zero? cdr waitpid)
177 (append pids1 pids2)))
178 (equal? (get-bytevector-all decompressed) data)))))
179
180(test-assert "filtered-port, does not exist"
181 (let* ((file (search-path %load-path "guix.scm"))
182 (input (open-file file "r0b")))
183 (let-values (((port pids)
184 (filtered-port '("/does/not/exist") input)))
185 (any (compose (negate zero?) cdr waitpid)
186 pids))))
187
188(define (test-compression/decompression method run?)
189 "Test METHOD, a symbol such as 'gzip. Call RUN? to determine whether to
190skip these tests."
191 (unless (run?) (test-skip 1))
192 (test-assert (format #f "compressed-port, decompressed-port, non-file [~a]"
193 method)
194 (let ((data (call-with-input-file (search-path %load-path "guix.scm")
195 get-bytevector-all)))
196 (call-with-temporary-output-file
197 (lambda (output port)
198 (close-port port)
199 (let*-values (((compressed pids)
200 ;; Note: 'compressed-output-port' only supports file
201 ;; ports.
202 (compressed-output-port method
203 (open-file output "w0"))))
204 (put-bytevector compressed data)
205 (close-port compressed)
206 (and (every (compose zero? cdr waitpid)
207 (pk 'pids method pids))
208 (let*-values (((decompressed pids)
209 (decompressed-port method
210 (open-bytevector-input-port
211 (call-with-input-file output
212 get-bytevector-all))))
213 ((result)
214 (get-bytevector-all decompressed)))
215 (close-port decompressed)
216 (pk 'len method
217 (if (bytevector? result)
218 (bytevector-length result)
219 result)
220 (bytevector-length data))
221 (and (every (compose zero? cdr waitpid)
222 (pk 'pids method pids))
223 (equal? result data)))))))))
224
225 (false-if-exception (delete-file temp-file))
226 (unless (run?) (test-skip 1))
227 (test-assert (format #f "compressed-output-port + decompressed-port [~a]"
228 method)
229 (let* ((file (search-path %load-path "guix/derivations.scm"))
230 (data (call-with-input-file file get-bytevector-all))
231 (port (open-file temp-file "w0b")))
232 (call-with-compressed-output-port method port
233 (lambda (compressed)
234 (put-bytevector compressed data)))
235 (close-port port)
236
237 (bytevector=? data
238 (call-with-decompressed-port method (open-file temp-file "r0b")
239 get-bytevector-all)))))
240
241(for-each test-compression/decompression
242 `(gzip xz lzip zstd)
243 (list (const #t) (const #t) (const #t)
244 (lambda ()
245 (resolve-module '(zstd) #t #f #:ensure #f))))
246
247;; This is actually in (guix store).
248(test-equal "store-path-package-name"
249 "bash-4.2-p24"
250 (store-path-package-name
251 (string-append (%store-prefix)
252 "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
253
254(test-equal "canonical-newline-port"
255 "This is a journey\nInto the sound\nA journey ...\n"
256 (let ((port (open-string-input-port
257 "This is a journey\r\nInto the sound\r\nA journey ...\n")))
258 (get-string-all (canonical-newline-port port))))
259
260(test-equal "canonical-newline-port-1024"
261 (string-concatenate (make-list 100 "0123456789abcde\n"))
262 (let ((port (open-string-input-port
263 (string-concatenate
264 (make-list 100 "0123456789abcde\r\n")))))
265 (get-string-all (canonical-newline-port port))))
266
267(test-equal "edit-expression"
268 "(display \"GNU Guix\")\n(newline)\n"
269 (begin
270 (call-with-output-file temp-file
271 (lambda (port)
272 (display "(display \"xiuG UNG\")\n(newline)\n" port)))
273 (edit-expression `((filename . ,temp-file)
274 (line . 0)
275 (column . 9))
276 string-reverse)
277 (call-with-input-file temp-file get-string-all)))
278
279(test-equal "insert-expression"
280 "(define-public package-1\n 'package)\n
281(define-public package-2\n 'package)\n"
282 (begin
283 (call-with-output-file temp-file
284 (lambda (port)
285 (display "(define-public package-2\n 'package)\n" port)))
286 (insert-expression `((filename . ,temp-file)
287 (line . 0)
288 (column . 0))
289 `(define-public package-1 'package))
290 (call-with-input-file temp-file get-string-all)))
291
292(test-equal "find-definition-insertion-location"
293 (list `((filename . ,temp-file) (line . 0) (column . 0))
294 `((filename . ,temp-file) (line . 5) (column . 0))
295 #f)
296 (begin
297 (call-with-output-file temp-file
298 (lambda (port)
299 (display "(define-public package-1\n 'foo)\n\n" port)
300 (display "(define foo 'bar)\n\n" port)
301 (display "(define-public package-2\n 'baz)\n" port)))
302 (map (lambda (term)
303 (find-definition-insertion-location temp-file term))
304 (list 'package 'package-1 'package-2))))
305
306(test-equal "string-distance"
307 '(0 1 1 5 5)
308 (list
309 (string-distance "hello" "hello")
310 (string-distance "hello" "helo")
311 (string-distance "helo" "hello")
312 (string-distance "" "hello")
313 (string-distance "hello" "")))
314
315(test-equal "string-closest"
316 '("hello" "hello" "helo" #f)
317 (list
318 (string-closest "hello" '("hello"))
319 (string-closest "hello" '("helo" "hello" "halo"))
320 (string-closest "hello" '("kikoo" "helo" "hihihi" "halo"))
321 (string-closest "hello" '("aaaaa" "12345" "hellohello" "h"))))
322
323(test-equal "target-linux?"
324 '(#t #f #f #t)
325 (map target-linux?
326 '("i686-linux-gnu" "i686-w64-mingw32"
327 ;; Checking that "gnu" is present is not sufficient,
328 ;; as GNU/Hurd exists.
329 "i686-pc-gnu"
330 ;; Some targets have a suffix.
331 "arm-linux-gnueabihf")))
332
333(test-equal "target-mingw?"
334 '(#f #f #t)
335 (map target-mingw?
336 '("i686-linux-gnu" "i686-pc-gnu"
337 "i686-w64-mingw32")))
338
339(test-equal "target-x86-32?"
340 '(#f #f #f #t #t #t #t #f)
341 ;; These are (according to Wikipedia) two RISC architectures
342 ;; by Intel and presumably not compatible with the x86-32 series.
343 (map target-x86-32?
344 '("i860-gnu" "i960-gnu"
345 ;; This is a 16-bit architecture
346 "i286-gnu"
347 ;; These are part of the x86-32 series.
348 "i386-gnu" "i486-gnu" "i586-gnu" "i686-gnu"
349 ;; Maybe this one will exist some day, but not yet.
350 "i786-gnu")))
351
352(test-equal "target-x86-64?"
353 '(#t #f #f #f)
354 (map target-x86-64?
355 `("x86_64-linux-gnu" "i386-linux-gnu"
356 ;; Just because it includes "64" doesn't make it 64-bit.
357 "aarch64-linux-gnu"
358 ;; Note that (expt 2 109) in decimal notation starts with 64.
359 ;; However, it isn't 32-bit.
360 ,(format #f "x86_~a-linux-gnu" (expt 2 109)))))
361
362(test-equal "target-avr?"
363 '(#t #t #t #f #f)
364 (map target-avr?
365 '("avr" "avr-unknown-none"
366 ;; In addition LLVM also uses this form.
367 "avr-unknown-unknown"
368 ;; The AVR32 architecture also was made by Atmel/Microchip but it
369 ;; does not resemble the AVR family, they aren't compatible in any
370 ;; way.
371 "avr32" "avr32-unknown-none")))
372
373(test-end)
374
375(false-if-exception (delete-file temp-file))