utils: Move 'fcntl-flock' to (guix build syscalls).
* guix/utils.scm (%struct-flock, F_SETLKW, F_SETLK, F_xxLCK)
(fcntl-flock): Move to...
* guix/build/syscalls.scm: ... here. New variables.
* guix/nar.scm: Adjust imports accordingly.
* tests/utils.scm ("fcntl-flock wait", "fcntl-flock non-blocking"): Move
to...
* tests/syscalls.scm: ... here. New tests.
(temp-file): New variable.
This commit is contained in:
Ludovic Courtès
parent
ba2613bb4e
commit
4e0ea3eb28
|
|
@ -65,6 +65,7 @@
|
|||
processes
|
||||
mkdtemp!
|
||||
pivot-root
|
||||
fcntl-flock
|
||||
|
||||
CLONE_CHILD_CLEARTID
|
||||
CLONE_CHILD_SETTID
|
||||
|
|
@ -637,6 +638,74 @@ system to PUT-OLD."
|
|||
(list new-root put-old (strerror err))
|
||||
(list err)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Advisory file locking.
|
||||
;;;
|
||||
|
||||
(define %struct-flock
|
||||
;; 'struct flock' from <fcntl.h>.
|
||||
(list short ; l_type
|
||||
short ; l_whence
|
||||
size_t ; l_start
|
||||
size_t ; l_len
|
||||
int)) ; l_pid
|
||||
|
||||
(define F_SETLKW
|
||||
;; On Linux-based systems, this is usually 7, but not always
|
||||
;; (exceptions include SPARC.) On GNU/Hurd, it's 9.
|
||||
(cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
|
||||
((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.
|
||||
(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.
|
||||
(cond ((string-contains %host-type "sparc") #(1 2 3)) ; sparc-*-linux-gnu
|
||||
((string-contains %host-type "hppa") #(1 2 3)) ; hppa-*-linux-gnu
|
||||
((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu
|
||||
(else #(1 2 3)))) ; *-gnu*
|
||||
|
||||
(define fcntl-flock
|
||||
(let ((proc (syscall->procedure int "fcntl" `(,int ,int *))))
|
||||
(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. 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))
|
||||
((write-lock) (vector-ref F_xxLCK 1))
|
||||
((unlock) (vector-ref F_xxLCK 2))
|
||||
(else (error "invalid fcntl-flock operation" op))))
|
||||
|
||||
(define fd
|
||||
(if (port? fd-or-port)
|
||||
(fileno fd-or-port)
|
||||
fd-or-port))
|
||||
|
||||
;; XXX: 'fcntl' is a vararg function, but here we happily use the
|
||||
;; standard ABI; crossing fingers.
|
||||
(let ((err (proc fd
|
||||
(if wait?
|
||||
F_SETLKW ; lock & wait
|
||||
F_SETLK) ; non-blocking attempt
|
||||
(make-c-struct %struct-flock
|
||||
(list (operation->int operation)
|
||||
SEEK_SET
|
||||
0 0 ; whole file
|
||||
0)))))
|
||||
(or (zero? err)
|
||||
|
||||
;; Presumably we got EAGAIN or so.
|
||||
(throw 'flock-error (errno)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Network interfaces.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
|
|
@ -18,8 +18,8 @@
|
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix nar)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix serialization)
|
||||
#:use-module (guix build syscalls)
|
||||
#:use-module ((guix build utils)
|
||||
#:select (delete-file-recursively with-directory-excursion))
|
||||
#:use-module (guix store)
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@
|
|||
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
|
||||
#:use-module (guix combinators)
|
||||
#:use-module ((guix build utils) #:select (dump-port))
|
||||
#:use-module ((guix build syscalls) #:select (errno mkdtemp!))
|
||||
#:use-module ((guix build syscalls) #:select (mkdtemp!))
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 format)
|
||||
#:autoload (ice-9 popen) (open-pipe*)
|
||||
|
|
@ -47,7 +47,6 @@
|
|||
#:export (bytevector->base16-string
|
||||
base16-string->bytevector
|
||||
|
||||
fcntl-flock
|
||||
strip-keyword-arguments
|
||||
default-keyword-arguments
|
||||
substitute-keyword-arguments
|
||||
|
|
@ -338,78 +337,6 @@ This procedure returns #t on success."
|
|||
(put-bytevector out post-bv))
|
||||
#t))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Advisory file locking.
|
||||
;;;
|
||||
|
||||
(define %struct-flock
|
||||
;; 'struct flock' from <fcntl.h>.
|
||||
(list short ; l_type
|
||||
short ; l_whence
|
||||
size_t ; l_start
|
||||
size_t ; l_len
|
||||
int)) ; l_pid
|
||||
|
||||
(define F_SETLKW
|
||||
;; On Linux-based systems, this is usually 7, but not always
|
||||
;; (exceptions include SPARC.) On GNU/Hurd, it's 9.
|
||||
(compile-time-value
|
||||
(cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
|
||||
((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
|
||||
(cond ((string-contains %host-type "sparc") #(1 2 3)) ; sparc-*-linux-gnu
|
||||
((string-contains %host-type "hppa") #(1 2 3)) ; hppa-*-linux-gnu
|
||||
((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu
|
||||
(else #(1 2 3))))) ; *-gnu*
|
||||
|
||||
(define fcntl-flock
|
||||
(let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
|
||||
(proc (pointer->procedure int ptr `(,int ,int *))))
|
||||
(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. 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))
|
||||
((write-lock) (vector-ref F_xxLCK 1))
|
||||
((unlock) (vector-ref F_xxLCK 2))
|
||||
(else (error "invalid fcntl-flock operation" op))))
|
||||
|
||||
(define fd
|
||||
(if (port? fd-or-port)
|
||||
(fileno fd-or-port)
|
||||
fd-or-port))
|
||||
|
||||
;; XXX: 'fcntl' is a vararg function, but here we happily use the
|
||||
;; standard ABI; crossing fingers.
|
||||
(let ((err (proc fd
|
||||
(if wait?
|
||||
F_SETLKW ; lock & wait
|
||||
F_SETLK) ; non-blocking attempt
|
||||
(make-c-struct %struct-flock
|
||||
(list (operation->int operation)
|
||||
SEEK_SET
|
||||
0 0 ; whole file
|
||||
0)))))
|
||||
(or (zero? err)
|
||||
|
||||
;; Presumably we got EAGAIN or so.
|
||||
(throw 'flock-error (errno)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Keyword arguments.
|
||||
|
|
|
|||
|
|
@ -29,6 +29,10 @@
|
|||
;; Test the (guix build syscalls) module, although there's not much that can
|
||||
;; actually be tested without being root.
|
||||
|
||||
(define temp-file
|
||||
(string-append "t-utils-" (number->string (getpid))))
|
||||
|
||||
|
||||
(test-begin "syscalls")
|
||||
|
||||
(test-equal "mount, ENOENT"
|
||||
|
|
@ -172,6 +176,88 @@
|
|||
(status:exit-val status))))
|
||||
(eq? #t result))))))))
|
||||
|
||||
(false-if-exception (delete-file temp-file))
|
||||
(test-equal "fcntl-flock wait"
|
||||
42 ; the child's exit status
|
||||
(let ((file (open-file temp-file "w0b")))
|
||||
;; Acquire an exclusive lock.
|
||||
(fcntl-flock file 'write-lock)
|
||||
(match (primitive-fork)
|
||||
(0
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
;; Reopen FILE read-only so we can have a read lock.
|
||||
(let ((file (open-file temp-file "r0b")))
|
||||
;; Wait until we can acquire the lock.
|
||||
(fcntl-flock file 'read-lock)
|
||||
(primitive-exit (read file)))
|
||||
(primitive-exit 1))
|
||||
(lambda ()
|
||||
(primitive-exit 2))))
|
||||
(pid
|
||||
;; Write garbage and wait.
|
||||
(display "hello, world!" file)
|
||||
(force-output file)
|
||||
(sleep 1)
|
||||
|
||||
;; Write the real answer.
|
||||
(seek file 0 SEEK_SET)
|
||||
(truncate-file file 0)
|
||||
(write 42 file)
|
||||
(force-output file)
|
||||
|
||||
;; Unlock, which should let the child continue.
|
||||
(fcntl-flock file 'unlock)
|
||||
|
||||
(match (waitpid pid)
|
||||
((_ . status)
|
||||
(let ((result (status:exit-val status)))
|
||||
(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 "w0")))
|
||||
(catch 'flock-error
|
||||
(lambda ()
|
||||
;; This attempt should throw EAGAIN.
|
||||
(fcntl-flock file 'write-lock #:wait? #f))
|
||||
(lambda (key errno)
|
||||
(primitive-exit (pk 'errno errno)))))
|
||||
(primitive-exit -1))
|
||||
(lambda ()
|
||||
(primitive-exit -2))))
|
||||
(pid
|
||||
(close-port input)
|
||||
(let ((file (open-file temp-file "w0")))
|
||||
;; 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)))))))))
|
||||
|
||||
(test-assert "all-network-interface-names"
|
||||
(match (all-network-interface-names)
|
||||
(((? string? names) ..1)
|
||||
|
|
@ -303,3 +389,5 @@
|
|||
0))
|
||||
|
||||
(test-end)
|
||||
|
||||
(false-if-exception (delete-file temp-file))
|
||||
|
|
|
|||
|
|
@ -168,88 +168,6 @@
|
|||
(call-with-decompressed-port 'xz (open-file temp-file "r0b")
|
||||
get-bytevector-all))))
|
||||
|
||||
(false-if-exception (delete-file temp-file))
|
||||
(test-equal "fcntl-flock wait"
|
||||
42 ; the child's exit status
|
||||
(let ((file (open-file temp-file "w0b")))
|
||||
;; Acquire an exclusive lock.
|
||||
(fcntl-flock file 'write-lock)
|
||||
(match (primitive-fork)
|
||||
(0
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
;; Reopen FILE read-only so we can have a read lock.
|
||||
(let ((file (open-file temp-file "r0b")))
|
||||
;; Wait until we can acquire the lock.
|
||||
(fcntl-flock file 'read-lock)
|
||||
(primitive-exit (read file)))
|
||||
(primitive-exit 1))
|
||||
(lambda ()
|
||||
(primitive-exit 2))))
|
||||
(pid
|
||||
;; Write garbage and wait.
|
||||
(display "hello, world!" file)
|
||||
(force-output file)
|
||||
(sleep 1)
|
||||
|
||||
;; Write the real answer.
|
||||
(seek file 0 SEEK_SET)
|
||||
(truncate-file file 0)
|
||||
(write 42 file)
|
||||
(force-output file)
|
||||
|
||||
;; Unlock, which should let the child continue.
|
||||
(fcntl-flock file 'unlock)
|
||||
|
||||
(match (waitpid pid)
|
||||
((_ . status)
|
||||
(let ((result (status:exit-val status)))
|
||||
(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 "w0")))
|
||||
(catch 'flock-error
|
||||
(lambda ()
|
||||
;; This attempt should throw EAGAIN.
|
||||
(fcntl-flock file 'write-lock #:wait? #f))
|
||||
(lambda (key errno)
|
||||
(primitive-exit (pk 'errno errno)))))
|
||||
(primitive-exit -1))
|
||||
(lambda ()
|
||||
(primitive-exit -2))))
|
||||
(pid
|
||||
(close-port input)
|
||||
(let ((file (open-file temp-file "w0")))
|
||||
;; 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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue