utils: Add a non-blocking option for 'fcntl-flock'.

* guix/utils.scm (F_SETLK): New variable.
  (fcntl-flock): Add 'wait?' keyword parameter; honor it.
* tests/utils.scm ("fcntl-flock non-blocking"): New test.

2 files changed, 57 insertions, 4 deletions

diff --git a/guix/utils.scm b/guix/utils.scm
index 38f9ad0f61..68329ec915 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -244,6 +244,13 @@ buffered data is lost."
          ((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
@@ -271,9 +278,11 @@ buffered data is lost."
 (define fcntl-flock
   (let* ((ptr  (dynamic-func "fcntl" (dynamic-link)))
          (proc (pointer->procedure int ptr `(,int ,int *))))
-    (lambda (fd-or-port operation)
+    (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."
+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))
@@ -289,7 +298,9 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
       ;; XXX: 'fcntl' is a vararg function, but here we happily use the
       ;; standard ABI; crossing fingers.
       (let ((err (proc fd
-                       F_SETLKW                   ; lock & wait
+                       (if wait?
+                           F_SETLKW               ; lock & wait
+                           F_SETLK)               ; non-blocking attempt
                        (make-c-struct %struct-flock
                                       (list (operation->int operation)
                                             SEEK_SET
diff --git a/tests/utils.scm b/tests/utils.scm
index 5be7baf016..adac5d4381 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -143,7 +143,7 @@
            (equal? (get-bytevector-all decompressed) data)))))
 
 (false-if-exception (delete-file temp-file))
-(test-equal "fcntl-flock"
+(test-equal "fcntl-flock wait"
   42                                              ; the child's exit status
   (let ((file (open-file temp-file "w0")))
     ;; Acquire an exclusive lock.
@@ -182,6 +182,48 @@
             (close-port file)
             result)))))))
 
+(test-equal "fcntl-flock non-blocking"
+  EAGAIN                                          ; the child's exit status
+  (match (pipe)
+    ((input . output)
+     (match (primitive-fork)
+       (0
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (close-port output)
+
+            ;; Wait for the green light.
+            (read-char input)
+
+            ;; Open FILE read-only so we can have a read lock.
+            (let ((file (open-file temp-file "w")))
+              (catch 'flock-error
+                (lambda ()
+                  ;; This attempt should throw EAGAIN.
+                  (fcntl-flock file 'write-lock #:wait? #f))
+                (lambda (key errno)
+                  (primitive-exit errno))))
+            (primitive-exit -1))
+          (lambda ()
+            (primitive-exit -2))))
+       (pid
+        (close-port input)
+        (let ((file (open-file temp-file "w")))
+          ;; Acquire an exclusive lock.
+          (fcntl-flock file 'write-lock)
+
+          ;; Tell the child to continue.
+          (write 'green-light output)
+          (force-output output)
+
+          (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"