projects/guix·blob version-0.16.0 · refs

230 lines · 8.5 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <[email protected]>
3;;; Copyright © 2014 Eric Bavier <[email protected]>
4;;; Copyright © 2016 Mathieu Lirzin <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (test-utils)
22 #:use-module ((guix config) #:select (%gzip))
23 #:use-module (guix utils)
24 #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
25 #:use-module ((guix search-paths) #:select (string-tokenize*))
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-11)
28 #:use-module (srfi srfi-64)
29 #:use-module (rnrs bytevectors)
30 #:use-module (rnrs io ports)
31 #:use-module (ice-9 match)
32 #:use-module (ice-9 vlist))
33
34(define temp-file
35 (string-append "t-utils-" (number->string (getpid))))
36
37(test-begin "utils")
38
39(test-assert "gnu-triplet->nix-system"
40 (let ((samples '(("i586-gnu0.3" "i686-gnu")
41 ("x86_64-unknown-linux-gnu" "x86_64-linux")
42 ("i386-pc-linux-gnu" "i686-linux")
43 ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
44 ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
45 ("i686-pc-cygwin" "i686-cygwin"))))
46 (let-values (((gnu nix) (unzip2 samples)))
47 (every (lambda (gnu nix)
48 (equal? nix (gnu-triplet->nix-system gnu)))
49 gnu nix))))
50
51(test-assert "package-name->name+version"
52 (every (match-lambda
53 ((name version)
54 (let*-values (((full-name)
55 (if version
56 (string-append name "@" version)
57 name))
58 ((name* version*)
59 (package-name->name+version full-name)))
60 (and (equal? name* name)
61 (equal? version* version)))))
62 '(("foo" "0.9.1b")
63 ("foo-14-bar" "320")
64 ("foo-bar2" #f)
65 ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
66 ("nixpkgs" "1.0pre22125_a28fe19")
67 ("gtk2" "2.38.0"))))
68
69(test-assert "guile-version>? 1.8"
70 (guile-version>? "1.8"))
71
72(test-assert "guile-version>? 10.5"
73 (not (guile-version>? "10.5")))
74
75(test-assert "version-prefix?"
76 (and (version-prefix? "4.1" "4.1.2")
77 (version-prefix? "4.1" "4.1")
78 (not (version-prefix? "4.1" "4.16.2"))
79 (not (version-prefix? "4.1" "4"))))
80
81(test-equal "string-tokenize*"
82 '(("foo")
83 ("foo" "bar" "baz")
84 ("foo" "bar" "")
85 ("foo" "bar" "baz"))
86 (list (string-tokenize* "foo" ":")
87 (string-tokenize* "foo;bar;baz" ";")
88 (string-tokenize* "foo!bar!" "!")
89 (string-tokenize* "foo+-+bar+-+baz" "+-+")))
90
91(test-equal "string-replace-substring"
92 '("foo BAR! baz"
93 "/gnu/store/chbouib"
94 "")
95 (list (string-replace-substring "foo bar baz" "bar" "BAR!")
96 (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
97 (string-replace-substring "" "foo" "bar")))
98
99(test-equal "strip-keyword-arguments"
100 '(a #:b b #:c c)
101 (strip-keyword-arguments '(#:foo #:bar #:baz)
102 '(a #:foo 42 #:b b #:baz 3
103 #:c c #:bar 4)))
104
105(test-equal "ensure-keyword-arguments"
106 '((#:foo 2)
107 (#:foo 2 #:bar 3)
108 (#:foo 42 #:bar 3))
109 (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
110 (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
111 (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
112
113(test-equal "default-keyword-arguments"
114 '((#:foo 2)
115 (#:foo 2)
116 (#:foo 2 #:bar 3)
117 (#:foo 2 #:bar 3)
118 (#:foo 2 #:bar 3))
119 (list (default-keyword-arguments '() '(#:foo 2))
120 (default-keyword-arguments '(#:foo 2) '(#:foo 4))
121 (default-keyword-arguments '() '(#:bar 3 #:foo 2))
122 (default-keyword-arguments '(#:bar 3) '(#:foo 2))
123 (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))
124
125(test-equal "substitute-keyword-arguments"
126 '((#:foo 3)
127 (#:foo 3)
128 (#:foo 3 #:bar (1 2))
129 (#:bar (1 2) #:foo 3)
130 (#:foo 3))
131 (list (substitute-keyword-arguments '(#:foo 2)
132 ((#:foo f) (1+ f)))
133 (substitute-keyword-arguments '()
134 ((#:foo f 2) (1+ f)))
135 (substitute-keyword-arguments '(#:foo 2 #:bar (2))
136 ((#:foo f) (1+ f))
137 ((#:bar b) (cons 1 b)))
138 (substitute-keyword-arguments '(#:foo 2)
139 ((#:foo _) 3)
140 ((#:bar b '(2)) (cons 1 b)))
141 (substitute-keyword-arguments '(#:foo 2)
142 ((#:foo f 1) (1+ f))
143 ((#:bar b) (cons 42 b)))))
144
145(test-assert "filtered-port, file"
146 (let* ((file (search-path %load-path "guix.scm"))
147 (input (open-file file "r0b")))
148 (let*-values (((compressed pids1)
149 (filtered-port `(,%gzip "-c" "--fast") input))
150 ((decompressed pids2)
151 (filtered-port `(,%gzip "-d") compressed)))
152 (and (every (compose zero? cdr waitpid)
153 (append pids1 pids2))
154 (equal? (get-bytevector-all decompressed)
155 (call-with-input-file file get-bytevector-all))))))
156
157(test-assert "filtered-port, non-file"
158 (let ((data (call-with-input-file (search-path %load-path "guix.scm")
159 get-bytevector-all)))
160 (let*-values (((compressed pids1)
161 (filtered-port `(,%gzip "-c" "--fast")
162 (open-bytevector-input-port data)))
163 ((decompressed pids2)
164 (filtered-port `(,%gzip "-d") compressed)))
165 (and (pk (every (compose zero? cdr waitpid)
166 (append pids1 pids2)))
167 (equal? (get-bytevector-all decompressed) data)))))
168
169(test-assert "filtered-port, does not exist"
170 (let* ((file (search-path %load-path "guix.scm"))
171 (input (open-file file "r0b")))
172 (let-values (((port pids)
173 (filtered-port '("/does/not/exist") input)))
174 (any (compose (negate zero?) cdr waitpid)
175 pids))))
176
177(test-assert "compressed-port, decompressed-port, non-file"
178 (let ((data (call-with-input-file (search-path %load-path "guix.scm")
179 get-bytevector-all)))
180 (let*-values (((compressed pids1)
181 (compressed-port 'xz (open-bytevector-input-port data)))
182 ((decompressed pids2)
183 (decompressed-port 'xz compressed)))
184 (and (every (compose zero? cdr waitpid)
185 (append pids1 pids2))
186 (equal? (get-bytevector-all decompressed) data)))))
187
188(false-if-exception (delete-file temp-file))
189(test-assert "compressed-output-port + decompressed-port"
190 (let* ((file (search-path %load-path "guix/derivations.scm"))
191 (data (call-with-input-file file get-bytevector-all))
192 (port (open-file temp-file "w0b")))
193 (call-with-compressed-output-port 'xz port
194 (lambda (compressed)
195 (put-bytevector compressed data)))
196 (close-port port)
197
198 (bytevector=? data
199 (call-with-decompressed-port 'xz (open-file temp-file "r0b")
200 get-bytevector-all))))
201
202;; This is actually in (guix store).
203(test-equal "store-path-package-name"
204 "bash-4.2-p24"
205 (store-path-package-name
206 (string-append (%store-prefix)
207 "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
208
209(test-equal "canonical-newline-port"
210 "This is a journey\nInto the sound\nA journey ...\n"
211 (let ((port (open-string-input-port
212 "This is a journey\r\nInto the sound\r\nA journey ...\n")))
213 (get-string-all (canonical-newline-port port))))
214
215
216(test-equal "edit-expression"
217 "(display \"GNU Guix\")\n(newline)\n"
218 (begin
219 (call-with-output-file temp-file
220 (lambda (port)
221 (display "(display \"xiuG UNG\")\n(newline)\n" port)))
222 (edit-expression `((filename . ,temp-file)
223 (line . 0)
224 (column . 9))
225 string-reverse)
226 (call-with-input-file temp-file get-string-all)))
227
228(test-end)
229
230(false-if-exception (delete-file temp-file))