aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/utils.scm17
-rw-r--r--tests/utils.scm44
2 files changed, 57 insertions, 4 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
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"