source: project/release/4/dot-locking/trunk/dot-locking.scm @ 19482

Last change on this file since 19482 was 19482, checked in by felix winkelmann, 10 years ago

added dot-locking

File size: 2.0 KB
Line 
1;;;; dot-locking.scm
2
3
4(module dot-locking (break-dot-lock
5                     obtain-dot-lock
6                     release-dot-lock
7                     with-dot-lock*
8                     with-dot-lock)
9
10(import scheme chicken)
11(use posix extras srfi-18 files)
12
13
14(define (make-lock-file-name file-name)
15  (string-append file-name ".lock"))
16
17(define (release-dot-lock file-name)
18  (delete-file* (make-lock-file-name file-name)))
19
20(define (maybe-obtain-dot-lock file-name)
21  (let ((temp-name (create-temporary-file file-name)))
22    (handle-exceptions ex
23        (begin
24          (delete-file temp-name)
25          #f)
26      (file-link temp-name (make-lock-file-name file-name))
27      (delete-file temp-name)
28      #t)))
29
30;; STALE-TIME is the minimum age of a lock to be broken
31;; if #f, don't break the lock
32
33(define (obtain-dot-lock file-name . args)
34  (let-optionals args ((retry-seconds 1)
35                       (retry-number #f)
36                       (stale-time 300))
37    (let ((lock-file-name (make-lock-file-name file-name))
38          (retry-interval retry-seconds))
39      (let loop ((retry-number retry-number)
40                 (broken? #f))
41        (cond
42         ((maybe-obtain-dot-lock file-name)
43          (if broken?
44              'broken
45              #t))
46         ((and stale-time
47               (handle-exceptions ex #f
48                 (> (current-seconds)
49                    (+ (file-modification-time (make-lock-file-name file-name))
50                       stale-time))))
51          (break-dot-lock file-name)
52          (loop retry-number #t))
53         (else
54          (thread-sleep!
55           (+ (quotient (* retry-interval 3) 4)
56              (random (quotient retry-interval 2))))
57          (cond ((not retry-number)
58                 (loop retry-number broken?))
59                ((> retry-number 0)
60                 (loop (- retry-number 1) broken?))
61                (else
62                 #f))))))))
63
64(define (break-dot-lock file-name)
65  (delete-file* (make-lock-file-name file-name)))
66
67(define (with-dot-lock* file-name thunk)
68  (dynamic-wind
69   (lambda () 
70     (obtain-dot-lock file-name))
71   (lambda ()
72     (call-with-values thunk
73       (lambda a
74         (release-dot-lock file-name)
75         (apply values a))))
76   (lambda ()
77     (release-dot-lock file-name))))
78
79(define-syntax with-dot-lock
80  (syntax-rules ()
81   ((with-dot-lock file-name body ...)
82    (with-dot-lock* file-name (lambda () body ...)))))
83
84
85)
Note: See TracBrowser for help on using the repository browser.