diff options
| -rw-r--r-- | guix/utils.scm | 17 | ||||
| -rw-r--r-- | tests/utils.scm | 44 |
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" |