summaryrefslogtreecommitdiff
path: root/tests/syscalls.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-05-06 13:12:45 +0200
committerLudovic Courtès <ludo@gnu.org>2016-05-06 13:25:30 +0200
commit4e0ea3eb288c2143b44bf324c64047762c72d3b3 (patch)
treea261da4f5d972b0a90827347a3a987534ab80ac7 /tests/syscalls.scm
parentba2613bb4e47938044a3c96b92debf1bddcf0140 (diff)
downloadpatches-4e0ea3eb288c2143b44bf324c64047762c72d3b3.tar
patches-4e0ea3eb288c2143b44bf324c64047762c72d3b3.tar.gz
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.
Diffstat (limited to 'tests/syscalls.scm')
-rw-r--r--tests/syscalls.scm88
1 files changed, 88 insertions, 0 deletions
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 0b73fb4b0c..73fa8a7acf 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))