diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/syscalls.scm | 88 | ||||
| -rw-r--r-- | tests/utils.scm | 82 |
2 files changed, 88 insertions, 82 deletions
diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 0b73fb4b0c..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) @@ -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 a54482e94c..6590ed91cf 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -168,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" |