5 files changed, 160 insertions, 158 deletions

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index a9cd6e93c89..86723c23c7c 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 43e52107521..739d3d3a57c 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 f18bbd19acf..d924e434bd1 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.
 ;;;
 
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 0b73fb4b0cd..73fa8a7acfa 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -29,6 +29,10 @@
 ;; Test the (guix build syscalls) module, although there's not much that can
 ;; actually be tested without being root.
 
+(define temp-file
+  (string-append "t-utils-" (number->string (getpid))))
+
+
 (test-begin "syscalls")
 
 (test-equal "mount, ENOENT"
@@ -172,6 +176,88 @@
                          (status:exit-val status))))
                (eq? #t result))))))))
 
+(false-if-exception (delete-file temp-file))
+(test-equal "fcntl-flock wait"
+  42                                              ; the child's exit status
+  (let ((file (open-file temp-file "w0b")))
+    ;; Acquire an exclusive lock.
+    (fcntl-flock file 'write-lock)
+    (match (primitive-fork)
+      (0
+       (dynamic-wind
+         (const #t)
+         (lambda ()
+           ;; Reopen FILE read-only so we can have a read lock.
+           (let ((file (open-file temp-file "r0b")))
+             ;; Wait until we can acquire the lock.
+             (fcntl-flock file 'read-lock)
+             (primitive-exit (read file)))
+           (primitive-exit 1))
+         (lambda ()
+           (primitive-exit 2))))
+      (pid
+       ;; Write garbage and wait.
+       (display "hello, world!"  file)
+       (force-output file)
+       (sleep 1)
+
+       ;; Write the real answer.
+       (seek file 0 SEEK_SET)
+       (truncate-file file 0)
+       (write 42 file)
+       (force-output file)
+
+       ;; Unlock, which should let the child continue.
+       (fcntl-flock file 'unlock)
+
+       (match (waitpid pid)
+         ((_  . status)
+          (let ((result (status:exit-val status)))
+            (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 "w0")))
+              (catch 'flock-error
+                (lambda ()
+                  ;; This attempt should throw EAGAIN.
+                  (fcntl-flock file 'write-lock #:wait? #f))
+                (lambda (key errno)
+                  (primitive-exit (pk 'errno errno)))))
+            (primitive-exit -1))
+          (lambda ()
+            (primitive-exit -2))))
+       (pid
+        (close-port input)
+        (let ((file (open-file temp-file "w0")))
+          ;; 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)))))))))
+
 (test-assert "all-network-interface-names"
   (match (all-network-interface-names)
     (((? string? names) ..1)
@@ -303,3 +389,5 @@
      0))
 
 (test-end)
+
+(false-if-exception (delete-file temp-file))
diff --git a/tests/utils.scm b/tests/utils.scm
index a54482e94ce..6590ed91cf8 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -168,88 +168,6 @@
                   (call-with-decompressed-port 'xz (open-file temp-file "r0b")
                     get-bytevector-all))))
 
-(false-if-exception (delete-file temp-file))
-(test-equal "fcntl-flock wait"
-  42                                              ; the child's exit status
-  (let ((file (open-file temp-file "w0b")))
-    ;; Acquire an exclusive lock.
-    (fcntl-flock file 'write-lock)
-    (match (primitive-fork)
-      (0
-       (dynamic-wind
-         (const #t)
-         (lambda ()
-           ;; Reopen FILE read-only so we can have a read lock.
-           (let ((file (open-file temp-file "r0b")))
-             ;; Wait until we can acquire the lock.
-             (fcntl-flock file 'read-lock)
-             (primitive-exit (read file)))
-           (primitive-exit 1))
-         (lambda ()
-           (primitive-exit 2))))
-      (pid
-       ;; Write garbage and wait.
-       (display "hello, world!"  file)
-       (force-output file)
-       (sleep 1)
-
-       ;; Write the real answer.
-       (seek file 0 SEEK_SET)
-       (truncate-file file 0)
-       (write 42 file)
-       (force-output file)
-
-       ;; Unlock, which should let the child continue.
-       (fcntl-flock file 'unlock)
-
-       (match (waitpid pid)
-         ((_  . status)
-          (let ((result (status:exit-val status)))
-            (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 "w0")))
-              (catch 'flock-error
-                (lambda ()
-                  ;; This attempt should throw EAGAIN.
-                  (fcntl-flock file 'write-lock #:wait? #f))
-                (lambda (key errno)
-                  (primitive-exit (pk 'errno errno)))))
-            (primitive-exit -1))
-          (lambda ()
-            (primitive-exit -2))))
-       (pid
-        (close-port input)
-        (let ((file (open-file temp-file "w0")))
-          ;; 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"