diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-05-06 13:12:45 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-05-06 13:25:30 +0200 |
commit | 4e0ea3eb288c2143b44bf324c64047762c72d3b3 (patch) | |
tree | a261da4f5d972b0a90827347a3a987534ab80ac7 /guix | |
parent | ba2613bb4e47938044a3c96b92debf1bddcf0140 (diff) | |
download | gnu-guix-4e0ea3eb288c2143b44bf324c64047762c72d3b3.tar gnu-guix-4e0ea3eb288c2143b44bf324c64047762c72d3b3.tar.gz |
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.
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build/syscalls.scm | 69 | ||||
-rw-r--r-- | guix/nar.scm | 4 | ||||
-rw-r--r-- | guix/utils.scm | 75 |
3 files changed, 72 insertions, 76 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a9cd6e93c8..86723c23c7 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -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. ;;; diff --git a/guix/nar.scm b/guix/nar.scm index 43e5210752..739d3d3a57 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -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) diff --git a/guix/utils.scm b/guix/utils.scm index f18bbd19ac..d924e434bd 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -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. ;;; |