From 4e0ea3eb288c2143b44bf324c64047762c72d3b3 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
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/build/syscalls.scm | 69 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 69 insertions(+)

(limited to 'guix/build')

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 @@ (define-module (guix build syscalls)
             processes
             mkdtemp!
             pivot-root
+            fcntl-flock
 
             CLONE_CHILD_CLEARTID
             CLONE_CHILD_SETTID
@@ -637,6 +638,74 @@ (define pivot-root
                  (list new-root put-old (strerror err))
                  (list err)))))))
 
+
+;;;
+;;; 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.
-- 
cgit v1.2.3