summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-05-06 13:12:45 +0200
committerLudovic Courtès <ludo@gnu.org>2016-05-06 13:25:30 +0200
commit4e0ea3eb288c2143b44bf324c64047762c72d3b3 (patch)
treea261da4f5d972b0a90827347a3a987534ab80ac7 /guix
parentba2613bb4e47938044a3c96b92debf1bddcf0140 (diff)
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.scm69
-rw-r--r--guix/nar.scm4
-rw-r--r--guix/utils.scm75
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.
;;;