mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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.
This commit is contained in:
parent
e7f34eb0dc
commit
c7445833eb
2 changed files with 57 additions and 4 deletions
|
@ -244,6 +244,13 @@ (define F_SETLKW
|
||||||
((string-contains %host-type "linux") 7) ; *-linux-gnu
|
((string-contains %host-type "linux") 7) ; *-linux-gnu
|
||||||
(else 9)))) ; *-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
|
(define F_xxLCK
|
||||||
;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
|
;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
|
||||||
(compile-time-value
|
(compile-time-value
|
||||||
|
@ -271,9 +278,11 @@ (define (errno)
|
||||||
(define fcntl-flock
|
(define fcntl-flock
|
||||||
(let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
|
(let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
|
||||||
(proc (pointer->procedure int ptr `(,int ,int *))))
|
(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
|
"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)
|
(define (operation->int op)
|
||||||
(case op
|
(case op
|
||||||
((read-lock) (vector-ref F_xxLCK 0))
|
((read-lock) (vector-ref F_xxLCK 0))
|
||||||
|
@ -289,7 +298,9 @@ (define fd
|
||||||
;; XXX: 'fcntl' is a vararg function, but here we happily use the
|
;; XXX: 'fcntl' is a vararg function, but here we happily use the
|
||||||
;; standard ABI; crossing fingers.
|
;; standard ABI; crossing fingers.
|
||||||
(let ((err (proc fd
|
(let ((err (proc fd
|
||||||
F_SETLKW ; lock & wait
|
(if wait?
|
||||||
|
F_SETLKW ; lock & wait
|
||||||
|
F_SETLK) ; non-blocking attempt
|
||||||
(make-c-struct %struct-flock
|
(make-c-struct %struct-flock
|
||||||
(list (operation->int operation)
|
(list (operation->int operation)
|
||||||
SEEK_SET
|
SEEK_SET
|
||||||
|
|
|
@ -143,7 +143,7 @@ (define temp-file
|
||||||
(equal? (get-bytevector-all decompressed) data)))))
|
(equal? (get-bytevector-all decompressed) data)))))
|
||||||
|
|
||||||
(false-if-exception (delete-file temp-file))
|
(false-if-exception (delete-file temp-file))
|
||||||
(test-equal "fcntl-flock"
|
(test-equal "fcntl-flock wait"
|
||||||
42 ; the child's exit status
|
42 ; the child's exit status
|
||||||
(let ((file (open-file temp-file "w0")))
|
(let ((file (open-file temp-file "w0")))
|
||||||
;; Acquire an exclusive lock.
|
;; Acquire an exclusive lock.
|
||||||
|
@ -182,6 +182,48 @@ (define temp-file
|
||||||
(close-port file)
|
(close-port file)
|
||||||
result)))))))
|
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).
|
;; This is actually in (guix store).
|
||||||
(test-equal "store-path-package-name"
|
(test-equal "store-path-package-name"
|
||||||
"bash-4.2-p24"
|
"bash-4.2-p24"
|
||||||
|
|
Loading…
Reference in a new issue