scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
scsh/dot-locking.scm
View File

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