summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-01-10 23:27:39 +0100
committerLudovic Courtès <ludo@gnu.org>2014-01-24 00:01:49 +0100
commit2cd5c0380ed36f334114904bacf9562fc98e2090 (patch)
tree00fa49aafd427e7539e0bd77cc6511f12b0c7aac /tests
parent6bfec3edf52ed6145c3c89fb19d350498dd2b758 (diff)
utils: Add 'fcntl-flock'.
* guix/utils.scm (%struct-flock, F_SETLKW, F_xxLCK): New variables. (fcntl-flock): New procedure. * tests/utils.scm ("fcntl-flock"): New test.
Diffstat (limited to 'tests')
-rw-r--r--tests/utils.scm32
1 files changed, 31 insertions, 1 deletions
diff --git a/tests/utils.scm b/tests/utils.scm
index 017d9170fa..b5706aa792 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -139,6 +139,36 @@
(append pids1 pids2)))
(equal? (get-bytevector-all decompressed) data)))))
+(test-equal "fcntl-flock"
+ 0 ; the child's exit status
+ (let ((file (open-input-file (search-path %load-path "guix.scm"))))
+ (fcntl-flock file 'read-lock)
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ ;; Taking a read lock should be OK.
+ (fcntl-flock file 'read-lock)
+ (fcntl-flock file 'unlock)
+
+ (catch 'flock-error
+ (lambda ()
+ ;; Taking an exclusive lock should raise an exception.
+ (fcntl-flock file 'write-lock))
+ (lambda args
+ (primitive-exit 0)))
+ (primitive-exit 1))
+ (lambda ()
+ (primitive-exit 2))))
+ (pid
+ (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"