From 4e0ea3eb288c2143b44bf324c64047762c72d3b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 6 May 2016 13:12:45 +0200 Subject: 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. --- guix/utils.scm | 75 +--------------------------------------------------------- 1 file changed, 1 insertion(+), 74 deletions(-) (limited to 'guix/utils.scm') 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 @@ -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 . - (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. -- cgit v1.2.3