summaryrefslogtreecommitdiff
path: root/guix
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 /guix
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 'guix')
-rw-r--r--guix/utils.scm17
1 files changed, 14 insertions, 3 deletions
diff --git a/guix/utils.scm b/guix/utils.scm
index 38f9ad0f61..68329ec915 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -244,6 +244,13 @@ buffered data is lost."
((string-contains %host-type "linux") 7) ; *-linux-gnu
(else 9)))) ; *-gnu*
+(define F_SETLK
+ ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
+ (compile-time-value
+ (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
+ ((string-contains %host-type "linux") 6) ; *-linux-gnu
+ (else 8)))) ; *-gnu*
+
(define F_xxLCK
;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
(compile-time-value
@@ -271,9 +278,11 @@ buffered data is lost."
(define fcntl-flock
(let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
(proc (pointer->procedure int ptr `(,int ,int *))))
- (lambda (fd-or-port operation)
+ (lambda* (fd-or-port operation #:key (wait? #t))
"Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION
-must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
+must be a symbol, one of 'read-lock, 'write-lock, or 'unlock. When WAIT? is
+true, block until the lock is acquired; otherwise, thrown an 'flock-error'
+exception if it's already taken."
(define (operation->int op)
(case op
((read-lock) (vector-ref F_xxLCK 0))
@@ -289,7 +298,9 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
;; XXX: 'fcntl' is a vararg function, but here we happily use the
;; standard ABI; crossing fingers.
(let ((err (proc fd
- F_SETLKW ; lock & wait
+ (if wait?
+ F_SETLKW ; lock & wait
+ F_SETLK) ; non-blocking attempt
(make-c-struct %struct-flock
(list (operation->int operation)
SEEK_SET