Made arguments to OBTAIN-DOT-LOCK optional and supply sensible

defaults.
All timings are now in seconds.
Add interface procedure BREAK-DOT-LOCK.
Indicate broken lock by BROKEN return value from OBTAIN-DOT-LOCK.
This commit is contained in:
sperber 2002-01-07 13:11:26 +00:00
parent 1f08335a4d
commit 50b49a7068
1 changed files with 37 additions and 26 deletions

View File

@ -29,12 +29,19 @@
;; STALE-TIME is the minimum age of a lock to be broken
;; if #f, don't break the lock
(define (obtain-dot-lock file-name retry-interval retry-number stale-time)
(let ((lock-file-name (make-lock-file-name file-name)))
(let loop ((retry-number retry-number))
(define (obtain-dot-lock file-name . args)
(let-optionals args ((retry-seconds 1)
(retry-number #f)
(stale-time 300))
(let ((lock-file-name (make-lock-file-name file-name))
(retry-interval (* retry-seconds 1000)))
(let loop ((retry-number retry-number)
(broken? #f))
(cond
((maybe-obtain-dot-lock file-name)
#t)
(if broken?
'broken
#t))
((and stale-time
(with-errno-handler
((errno packet)
@ -42,19 +49,23 @@
(> (time)
(+ (file-last-status-change (make-lock-file-name file-name))
stale-time))))
(with-errno-handler
((errno packet)
((errno/noent) 'dont-care))
(delete-file lock-file-name))
(loop retry-number))
(break-dot-lock file-name)
(loop retry-number #t))
(else
(sleep (+ (quotient (* retry-interval 3) 4)
(random (quotient retry-interval 2))))
(cond ((not retry-number)
(loop retry-number))
(loop retry-number broken?))
((> retry-number 0)
(loop (- retry-number 1)))
(else #f)))))))
(loop (- retry-number 1) broken?))
(else
#f))))))))
(define (break-dot-lock file-name)
(with-errno-handler
((errno packet)
((errno/noent) 'dont-care))
(delete-file (make-lock-file-name file-name))))
(define (with-dot-lock* file-name thunk)
(dynamic-wind