From 2cd5c0380ed36f334114904bacf9562fc98e2090 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 10 Jan 2014 23:27:39 +0100 Subject: utils: Add 'fcntl-flock'. * guix/utils.scm (%struct-flock, F_SETLKW, F_xxLCK): New variables. (fcntl-flock): New procedure. * tests/utils.scm ("fcntl-flock"): New test. --- tests/utils.scm | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) (limited to 'tests/utils.scm') diff --git a/tests/utils.scm b/tests/utils.scm index 017d9170fa..b5706aa792 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -139,6 +139,36 @@ (append pids1 pids2))) (equal? (get-bytevector-all decompressed) data))))) +(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) + (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))) + (primitive-exit 1)) + (lambda () + (primitive-exit 2)))) + (pid + (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" -- cgit v1.2.3