diff options
| -rw-r--r-- | guix/utils.scm | 66 | ||||
| -rw-r--r-- | tests/utils.scm | 32 |
2 files changed, 95 insertions, 3 deletions
diff --git a/guix/utils.scm b/guix/utils.scm index 04a74ee29a..5fda2116de 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -34,7 +34,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:autoload (system foreign) (pointer->procedure) + #:use-module (system foreign) #:export (bytevector->base16-string base16-string->bytevector @@ -43,6 +43,7 @@ nixpkgs-derivation* compile-time-value + fcntl-flock memoize default-keyword-arguments substitute-keyword-arguments @@ -224,6 +225,67 @@ buffered data is lost." ;;; +;;; 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_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) + "Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION +must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." + (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 + F_SETLKW ; lock & wait + (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 fd)))))) + + +;;; ;;; Miscellaneous. ;;; diff --git a/tests/utils.scm b/tests/utils.scm index 017d9170fa..b5706aa792 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -139,6 +139,36 @@ (append pids1 pids2))) (equal? (get-bytevector-all decompressed) data))))) +(test-equal "fcntl-flock" + 0 ; the child's exit status + (let ((file (open-input-file (search-path %load-path "guix.scm")))) + (fcntl-flock file 'read-lock) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + ;; Taking a read lock should be OK. + (fcntl-flock file 'read-lock) + (fcntl-flock file 'unlock) + + (catch 'flock-error + (lambda () + ;; Taking an exclusive lock should raise an exception. + (fcntl-flock file 'write-lock)) + (lambda args + (primitive-exit 0))) + (primitive-exit 1)) + (lambda () + (primitive-exit 2)))) + (pid + (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" |