ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: Rewrite 'fcntl-lock' test.

Browse source 
* tests/utils.scm (temp-file): New variable.
  ("fcntl-flock"): Rewrite to actually test whether the child process
  waits for the lock to be released.  The previous test was wrong
  because (1) it expected F_SETLK semantics, not F_SETLKW, and (2) it
  got EBADF because of a mismatch between the open mode and the lock
  style.
This commit is contained in:
Ludovic Courtès 2014-03-06 18:38:19 +01:00
parent 56c72822a8
commit 827d556311
1 changed files with 29 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
tests/utils.scm
View file

@ -27,6 +27,9 @@ (define-module (test-utils)
#:use-module (rnrs io ports)
#:use-module (ice-9 match))
(define temp-file
(string-append "t-utils-" (number->string (getpid))))
(test-begin "utils")
(test-assert "bytevector->base16-string->bytevector"
@ -139,33 +142,43 @@ (define-module (test-utils)
(append pids1 pids2)))
(equal? (get-bytevector-all decompressed) data)))))
(false-if-exception (delete-file temp-file))
(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)
42 ; the child's exit status
(let ((file (open-file temp-file "w0")))
;; Acquire an exclusive lock.
(fcntl-flock file 'write-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)))
;; Reopen FILE read-only so we can have a read lock.
(let ((file (open-file temp-file "r")))
;; 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)))
(fcntl-flock file 'unlock)
(close-port file)
result)))))))
@ -178,5 +191,7 @@ (define-module (test-utils)
(test-end)
(false-if-exception (delete-file temp-file))
(exit (= (test-runner-fail-count (test-runner-current)) 0))