diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/combinators.scm | 85 | ||||
| -rw-r--r-- | tests/syscalls.scm | 90 | ||||
| -rw-r--r-- | tests/utils.scm | 152 |
3 files changed, 174 insertions, 153 deletions
diff --git a/tests/combinators.scm b/tests/combinators.scm new file mode 100644 index 0000000000..1e4bb236b7 --- /dev/null +++ b/tests/combinators.scm @@ -0,0 +1,85 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-combinators) + #:use-module (guix combinators) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 vlist)) + +(test-begin "combinators") + +(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)) + +(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-end) + diff --git a/tests/syscalls.scm b/tests/syscalls.scm index ab1e13984d..73fa8a7acf 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -29,6 +29,10 @@ ;; Test the (guix build syscalls) module, although there's not much that can ;; actually be tested without being root. +(define temp-file + (string-append "t-utils-" (number->string (getpid)))) + + (test-begin "syscalls") (test-equal "mount, ENOENT" @@ -172,6 +176,88 @@ (status:exit-val status)))) (eq? #t result)))))))) +(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))))))))) + (test-assert "all-network-interface-names" (match (all-network-interface-names) (((? string? names) ..1) @@ -281,7 +367,7 @@ (test-assert "tcsetattr" (let ((first (tcgetattr 0))) - (tcsetattr 0 TCSANOW first) + (tcsetattr 0 (tcsetattr-action TCSANOW) first) (equal? first (tcgetattr 0)))) (test-assert "terminal-window-size ENOTTY" @@ -303,3 +389,5 @@ 0)) (test-end) + +(false-if-exception (delete-file temp-file)) diff --git a/tests/utils.scm b/tests/utils.scm index d0ee02a1cf..6590ed91cf 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -97,45 +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 "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) @@ -150,37 +111,6 @@ (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-assert "filtered-port, file" (let* ((file (search-path %load-path "guix.scm")) (input (open-file file "r0b"))) @@ -238,88 +168,6 @@ (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))))))))) - ;; This is actually in (guix store). (test-equal "store-path-package-name" "bash-4.2-p24" |