source: project/release/4/dot-locking/tags/0.2/dot-locking.scm @ 26394

Last change on this file since 26394 was 26394, checked in by felix winkelmann, 8 years ago

dot-locking 0.2: incorporated fixed by Claude Marinier

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