;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
(test-begin "utils")
-(test-assert "bytevector->base16-string->bytevector"
- (every (lambda (bv)
- (equal? (base16-string->bytevector
- (bytevector->base16-string bv))
- bv))
- (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
-
(test-assert "gnu-triplet->nix-system"
(let ((samples '(("i586-gnu0.3" "i686-gnu")
("x86_64-unknown-linux-gnu" "x86_64-linux")
((name version)
(let*-values (((full-name)
(if version
- (string-append name "-" version)
+ (string-append name "@" version)
name))
((name* version*)
(package-name->name+version full-name)))
(and (equal? name* name)
(equal? version* version)))))
'(("foo" "0.9.1b")
- ("foo-bar" "1.0")
+ ("foo-14-bar" "320")
("foo-bar2" #f)
("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
("nixpkgs" "1.0pre22125_a28fe19")
(test-assert "guile-version>? 10.5"
(not (guile-version>? "10.5")))
+(test-assert "version-prefix?"
+ (and (version-prefix? "4.1" "4.1.2")
+ (version-prefix? "4.1" "4.1")
+ (not (version-prefix? "4.1" "4.16.2"))
+ (not (version-prefix? "4.1" "4"))))
+
+(test-equal "version-unique-prefix"
+ '("2" "2.2" "")
+ (list (version-unique-prefix "2.0" '("3.0" "2.0"))
+ (version-unique-prefix "2.2" '("3.0.5" "2.0.9" "2.2.7"))
+ (version-unique-prefix "27.1" '("27.1"))))
+
(test-equal "string-tokenize*"
'(("foo")
("foo" "bar" "baz")
(string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
(string-replace-substring "" "foo" "bar")))
-(test-equal "fold2, 1 list"
- (list (reverse (iota 5))
- (map - (reverse (iota 5))))
- (call-with-values
- (lambda ()
- (fold2 (lambda (i r1 r2)
- (values (cons i r1)
- (cons (- i) r2)))
- '() '()
- (iota 5)))
- list))
-
-(test-equal "fold2, 2 lists"
- (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
- (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
- (call-with-values
- (lambda ()
- (fold2 (lambda (k v r1 r2)
- (values (alist-cons k v r1)
- (alist-cons k (- v) r2)))
- '() '()
- '(a b c d)
- '(0 1 2 3)))
- list))
-
-(test-equal "split, element is in list"
- '((foo) (baz))
- (call-with-values
- (lambda ()
- (split '(foo bar baz) 'bar))
- list))
-
-(test-equal "split, element is not in list"
- '((foo bar baz) ())
- (call-with-values
- (lambda ()
- (split '(foo bar baz) 'quux))
- list))
-
(test-equal "strip-keyword-arguments"
'(a #:b b #:c c)
(strip-keyword-arguments '(#:foo #:bar #:baz)
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
-(let* ((tree (alist->vhash
- '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
- hashq))
- (add-one (lambda (_ r) (1+ r)))
- (tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
- (test-equal "fold-tree, single root"
- 5 (fold-tree add-one 0 tree-lookup '(0)))
- (test-equal "fold-tree, two roots"
- 7 (fold-tree add-one 0 tree-lookup '(0 1)))
- (test-equal "fold-tree, sum"
- 16 (fold-tree + 0 tree-lookup '(0)))
- (test-equal "fold-tree, internal"
- 18 (fold-tree + 0 tree-lookup '(3 4)))
- (test-equal "fold-tree, cons"
- '(1 3 4 5 6)
- (sort (fold-tree cons '() tree-lookup '(1)) <))
- (test-equal "fold-tree, overlapping paths"
- '(1 3 4 5 6)
- (sort (fold-tree cons '() tree-lookup '(1 4)) <))
- (test-equal "fold-tree, cons, two roots"
- '(0 2 3 4 5 6)
- (sort (fold-tree cons '() tree-lookup '(0 4)) <))
- (test-equal "fold-tree-leaves, single root"
- 2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
- (test-equal "fold-tree-leaves, single root, sum"
- 11 (fold-tree-leaves + 0 tree-lookup '(1)))
- (test-equal "fold-tree-leaves, two roots"
- 3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
- (test-equal "fold-tree-leaves, two roots, sum"
- 13 (fold-tree-leaves + 0 tree-lookup '(0 1))))
+(test-equal "default-keyword-arguments"
+ '((#:foo 2)
+ (#:foo 2)
+ (#:foo 2 #:bar 3)
+ (#:foo 2 #:bar 3)
+ (#:foo 2 #:bar 3))
+ (list (default-keyword-arguments '() '(#:foo 2))
+ (default-keyword-arguments '(#:foo 2) '(#:foo 4))
+ (default-keyword-arguments '() '(#:bar 3 #:foo 2))
+ (default-keyword-arguments '(#:bar 3) '(#:foo 2))
+ (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))
+
+(test-equal "substitute-keyword-arguments"
+ '((#:foo 3)
+ (#:foo 3)
+ (#:foo 3 #:bar (1 2))
+ (#:bar (1 2) #:foo 3)
+ (#:foo 3))
+ (list (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo f) (1+ f)))
+ (substitute-keyword-arguments '()
+ ((#:foo f 2) (1+ f)))
+ (substitute-keyword-arguments '(#:foo 2 #:bar (2))
+ ((#:foo f) (1+ f))
+ ((#:bar b) (cons 1 b)))
+ (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo _) 3)
+ ((#:bar b '(2)) (cons 1 b)))
+ (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo f 1) (1+ f))
+ ((#:bar b) (cons 42 b)))))
(test-assert "filtered-port, file"
(let* ((file (search-path %load-path "guix.scm"))
(any (compose (negate zero?) cdr waitpid)
pids))))
-(test-assert "compressed-port, decompressed-port, non-file"
- (let ((data (call-with-input-file (search-path %load-path "guix.scm")
- get-bytevector-all)))
- (let*-values (((compressed pids1)
- (compressed-port 'xz (open-bytevector-input-port data)))
- ((decompressed pids2)
- (decompressed-port 'xz compressed)))
- (and (every (compose zero? cdr waitpid)
- (append pids1 pids2))
- (equal? (get-bytevector-all decompressed) data)))))
-
-(false-if-exception (delete-file temp-file))
-(test-assert "compressed-output-port + decompressed-port"
- (let* ((file (search-path %load-path "guix/derivations.scm"))
- (data (call-with-input-file file get-bytevector-all))
- (port (open-file temp-file "w0b")))
- (call-with-compressed-output-port 'xz port
- (lambda (compressed)
- (put-bytevector compressed data)))
- (close-port port)
-
- (bytevector=? data
- (call-with-decompressed-port 'xz (open-file temp-file "r0b")
- get-bytevector-all))))
-
-(false-if-exception (delete-file temp-file))
-(test-equal "fcntl-flock wait"
- 42 ; the child's exit status
- (let ((file (open-file temp-file "w0b")))
- ;; Acquire an exclusive lock.
- (fcntl-flock file 'write-lock)
- (match (primitive-fork)
- (0
- (dynamic-wind
- (const #t)
- (lambda ()
- ;; Reopen FILE read-only so we can have a read lock.
- (let ((file (open-file temp-file "r0b")))
- ;; Wait until we can acquire the lock.
- (fcntl-flock file 'read-lock)
- (primitive-exit (read file)))
- (primitive-exit 1))
- (lambda ()
- (primitive-exit 2))))
- (pid
- ;; Write garbage and wait.
- (display "hello, world!" file)
- (force-output file)
- (sleep 1)
-
- ;; Write the real answer.
- (seek file 0 SEEK_SET)
- (truncate-file file 0)
- (write 42 file)
- (force-output file)
-
- ;; Unlock, which should let the child continue.
- (fcntl-flock file 'unlock)
-
- (match (waitpid pid)
- ((_ . status)
- (let ((result (status:exit-val status)))
- (close-port file)
- result)))))))
-
-(test-equal "fcntl-flock non-blocking"
- EAGAIN ; the child's exit status
- (match (pipe)
- ((input . output)
- (match (primitive-fork)
- (0
- (dynamic-wind
- (const #t)
- (lambda ()
- (close-port output)
-
- ;; Wait for the green light.
- (read-char input)
-
- ;; Open FILE read-only so we can have a read lock.
- (let ((file (open-file temp-file "w0")))
- (catch 'flock-error
+(define (test-compression/decompression method run?)
+ "Test METHOD, a symbol such as 'gzip. Call RUN? to determine whether to
+skip these tests."
+ (unless (run?) (test-skip 1))
+ (test-assert (format #f "compressed-port, decompressed-port, non-file [~a]"
+ method)
+ (let ((data (call-with-input-file (search-path %load-path "guix.scm")
+ get-bytevector-all)))
+ (call-with-temporary-output-file
+ (lambda (output port)
+ (close-port port)
+ (let*-values (((compressed pids)
+ ;; Note: 'compressed-output-port' only supports file
+ ;; ports.
+ (compressed-output-port method
+ (open-file output "w0"))))
+ (put-bytevector compressed data)
+ (close-port compressed)
+ (and (every (compose zero? cdr waitpid)
+ (pk 'pids method pids))
+ (let*-values (((decompressed pids)
+ (decompressed-port method
+ (open-bytevector-input-port
+ (call-with-input-file output
+ get-bytevector-all))))
+ ((result)
+ (get-bytevector-all decompressed)))
+ (close-port decompressed)
+ (pk 'len method
+ (if (bytevector? result)
+ (bytevector-length result)
+ result)
+ (bytevector-length data))
+ (and (every (compose zero? cdr waitpid)
+ (pk 'pids method pids))
+ (equal? result data)))))))))
+
+ (false-if-exception (delete-file temp-file))
+ (unless (run?) (test-skip 1))
+ (test-assert (format #f "compressed-output-port + decompressed-port [~a]"
+ method)
+ (let* ((file (search-path %load-path "guix/derivations.scm"))
+ (data (call-with-input-file file get-bytevector-all))
+ (port (open-file temp-file "w0b")))
+ (call-with-compressed-output-port method port
+ (lambda (compressed)
+ (put-bytevector compressed data)))
+ (close-port port)
+
+ (bytevector=? data
+ (call-with-decompressed-port method (open-file temp-file "r0b")
+ get-bytevector-all)))))
+
+(for-each test-compression/decompression
+ `(gzip xz lzip zstd)
+ (list (const #t) (const #t) (const #t)
(lambda ()
- ;; This attempt should throw EAGAIN.
- (fcntl-flock file 'write-lock #:wait? #f))
- (lambda (key errno)
- (primitive-exit (pk 'errno errno)))))
- (primitive-exit -1))
- (lambda ()
- (primitive-exit -2))))
- (pid
- (close-port input)
- (let ((file (open-file temp-file "w0")))
- ;; Acquire an exclusive lock.
- (fcntl-flock file 'write-lock)
-
- ;; Tell the child to continue.
- (write 'green-light output)
- (force-output output)
-
- (match (waitpid pid)
- ((_ . status)
- (let ((result (status:exit-val status)))
- (fcntl-flock file 'unlock)
- (close-port file)
- result)))))))))
+ (resolve-module '(zstd) #t #f #:ensure #f))))
;; This is actually in (guix store).
(test-equal "store-path-package-name"
"This is a journey\r\nInto the sound\r\nA journey ...\n")))
(get-string-all (canonical-newline-port port))))
+(test-equal "canonical-newline-port-1024"
+ (string-concatenate (make-list 100 "0123456789abcde\n"))
+ (let ((port (open-string-input-port
+ (string-concatenate
+ (make-list 100 "0123456789abcde\r\n")))))
+ (get-string-all (canonical-newline-port port))))
+
+(test-equal "edit-expression"
+ "(display \"GNU Guix\")\n(newline)\n"
+ (begin
+ (call-with-output-file temp-file
+ (lambda (port)
+ (display "(display \"xiuG UNG\")\n(newline)\n" port)))
+ (edit-expression `((filename . ,temp-file)
+ (line . 0)
+ (column . 9))
+ string-reverse)
+ (call-with-input-file temp-file get-string-all)))
+
+(test-equal "string-distance"
+ '(0 1 1 5 5)
+ (list
+ (string-distance "hello" "hello")
+ (string-distance "hello" "helo")
+ (string-distance "helo" "hello")
+ (string-distance "" "hello")
+ (string-distance "hello" "")))
+
+(test-equal "string-closest"
+ '("hello" "hello" "helo" #f)
+ (list
+ (string-closest "hello" '("hello"))
+ (string-closest "hello" '("helo" "hello" "halo"))
+ (string-closest "hello" '("kikoo" "helo" "hihihi" "halo"))
+ (string-closest "hello" '("aaaaa" "12345" "hellohello" "h"))))
+
+(test-equal "target-linux?"
+ '(#t #f #f #t)
+ (map target-linux?
+ '("i686-linux-gnu" "i686-w64-mingw32"
+ ;; Checking that "gnu" is present is not sufficient,
+ ;; as GNU/Hurd exists.
+ "i686-pc-gnu"
+ ;; Some targets have a suffix.
+ "arm-linux-gnueabihf")))
+
+(test-equal "target-mingw?"
+ '(#f #f #t)
+ (map target-mingw?
+ '("i686-linux-gnu" "i686-pc-gnu"
+ "i686-w64-mingw32")))
+
+(test-equal "target-x86-32?"
+ '(#f #f #f #t #t #t #t #f)
+ ;; These are (according to Wikipedia) two RISC architectures
+ ;; by Intel and presumably not compatible with the x86-32 series.
+ (map target-x86-32?
+ '("i860-gnu" "i960-gnu"
+ ;; This is a 16-bit architecture
+ "i286-gnu"
+ ;; These are part of the x86-32 series.
+ "i386-gnu" "i486-gnu" "i586-gnu" "i686-gnu"
+ ;; Maybe this one will exist some day, but not yet.
+ "i786-gnu")))
+
+(test-equal "target-x86-64?"
+ '(#t #f #f #f)
+ (map target-x86-64?
+ `("x86_64-linux-gnu" "i386-linux-gnu"
+ ;; Just because it includes "64" doesn't make it 64-bit.
+ "aarch64-linux-gnu"
+ ;; Note that (expt 2 109) in decimal notation starts with 64.
+ ;; However, it isn't 32-bit.
+ ,(format #f "x86_~a-linux-gnu" (expt 2 109)))))
+
(test-end)
(false-if-exception (delete-file temp-file))
-
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
HCoop / jackhill / guix / guix.git / blobdiff