X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/4b6fa8b33970be414ae035f63ed80b147dcd8200..20710b911f7784c5602799181d6f108814695b31:/tests/utils.scm diff --git a/tests/utils.scm b/tests/utils.scm index 854999f670..f78ec356bd 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2016 Mathieu Lirzin ;;; @@ -23,6 +23,7 @@ #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix store-path-package-name)) #:use-module ((guix search-paths) #:select (string-tokenize*)) + #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) @@ -36,13 +37,6 @@ (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") @@ -79,6 +73,12 @@ (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 "string-tokenize*" '(("foo") ("foo" "bar" "baz") @@ -97,31 +97,6 @@ (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 "strip-keyword-arguments" '(a #:b b #:c c) (strip-keyword-arguments '(#:foo #:bar #:baz) @@ -136,36 +111,37 @@ (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")) @@ -199,112 +175,47 @@ (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 - (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))))))))) +(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))) + (let*-values (((compressed pids1) + (compressed-port method (open-bytevector-input-port data))) + ((decompressed pids2) + (decompressed-port method compressed))) + (and (every (compose zero? cdr waitpid) + (pk 'pids method (append pids1 pids2))) + (let ((result (get-bytevector-all decompressed))) + (pk 'len method + (if (bytevector? result) + (bytevector-length result) + result) + (bytevector-length data)) + (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) + (list (const #t) (const #t) lzlib-available?)) ;; This is actually in (guix store). (test-equal "store-path-package-name" @@ -319,6 +230,12 @@ "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"