summaryrefslogtreecommitdiff
path: root/tests/utils.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-03-07 16:46:09 +0100
committerLudovic Courtès <ludo@gnu.org>2014-03-08 00:18:22 +0100
commitc7445833eb43ec621fb5a56f6bfbbf0a02a675c2 (patch)
tree3107311f5d32a144f6c3373f6b5b0eb70041f6d5 /tests/utils.scm
parente7f34eb0dc5a5302726857a77de3cf5f6635c1b7 (diff)
utils: Add a non-blocking option for 'fcntl-flock'.
* guix/utils.scm (F_SETLK): New variable. (fcntl-flock): Add 'wait?' keyword parameter; honor it. * tests/utils.scm ("fcntl-flock non-blocking"): New test.
Diffstat (limited to 'tests/utils.scm')
-rw-r--r--tests/utils.scm44
1 files changed, 43 insertions, 1 deletions
diff --git a/tests/utils.scm b/tests/utils.scm
index 5be7baf016..adac5d4381 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -143,7 +143,7 @@
(equal? (get-bytevector-all decompressed) data)))))
(false-if-exception (delete-file temp-file))
-(test-equal "fcntl-flock"
+(test-equal "fcntl-flock wait"
42 ; the child's exit status
(let ((file (open-file temp-file "w0")))
;; Acquire an exclusive lock.
@@ -182,6 +182,48 @@
(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 "w")))
+ (catch 'flock-error
+ (lambda ()
+ ;; This attempt should throw EAGAIN.
+ (fcntl-flock file 'write-lock #:wait? #f))
+ (lambda (key errno)
+ (primitive-exit errno))))
+ (primitive-exit -1))
+ (lambda ()
+ (primitive-exit -2))))
+ (pid
+ (close-port input)
+ (let ((file (open-file temp-file "w")))
+ ;; 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"