M guix/build/syscalls.scm => guix/build/syscalls.scm +69 -0
@@ 65,6 65,7 @@
processes
mkdtemp!
pivot-root
+ fcntl-flock
CLONE_CHILD_CLEARTID
CLONE_CHILD_SETTID
@@ 639,6 640,74 @@ system to PUT-OLD."
;;;
+;;; 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.
;;;
M guix/nar.scm => guix/nar.scm +2 -2
@@ 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)
M guix/utils.scm => guix/utils.scm +1 -74
@@ 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
@@ 340,78 339,6 @@ This procedure returns #t on success."
;;;
-;;; 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.
;;;
M tests/syscalls.scm => tests/syscalls.scm +88 -0
@@ 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))
M tests/utils.scm => tests/utils.scm +0 -82
@@ 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"