Basically reimplement to my idea of dot-locking.

(Sorry, Martin ...)
This commit is contained in:
sperber 2001-12-27 17:29:17 +00:00
parent 0a31b98924
commit 29f7483d60
2 changed files with 66 additions and 45 deletions

View File

@ -1,56 +1,76 @@
(define (make-lockname filename)
(string-append filename ".lock"))
(define (make-lock-file-name file-name)
(string-append file-name ".lock"))
(define (maybe-obtain-dot-lock tempname filename)
(let ((port (open-file tempname (bitwise-ior open/write
open/create
open/exclusive))))
(close port)
(with-errno-handler
((errno packet)
((errno/exist)
(delete-file tempname)
#f))
(create-hard-link tempname (make-lockname filename))
(delete-file tempname)
#t)))
(define (release-dot-lock filename)
(define (release-dot-lock file-name)
(with-errno-handler
((errno packet)
(else #f))
(delete-file (make-lockname filename))
(delete-file (make-lock-file-name file-name))
#t))
(define (obtain-dot-lock filename . args)
(let-optionals args ((retry-interval 1000) (retry-number #f))
(let ((tempname (create-temp-file filename)))
(delete-file tempname)
(let loop ((retry-number retry-number))
(or (maybe-obtain-dot-lock tempname filename)
(begin (sleep retry-interval)
(cond ((not retry-number)
(loop retry-number))
((> retry-number 0)
(loop (- retry-number 1)))
(else #f))))))))
(define (maybe-obtain-dot-lock file-name)
(let ((temp-name (create-temp-file file-name)))
(with-errno-handler
((errno packet)
((errno/exist)
(delete-file temp-name)
#f))
(create-hard-link temp-name (make-lock-file-name file-name))
(delete-file temp-name)
#t)))
(define (with-dot-lock* filename thunk)
(define random
(let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
(lambda (limit)
(quotient (* (modulo (crank) 314159265)
limit)
314159265))))
;; 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))
(cond
((maybe-obtain-dot-lock file-name)
#t)
((and stale-time
(with-errno-handler
((errno packet)
(else #f))
(> (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))
(else
(sleep (+ (quotient (* retry-interval 3) 4)
(random (quotient retry-interval 2))))
(cond ((not retry-number)
(loop retry-number))
((> retry-number 0)
(loop (- retry-number 1)))
(else #f)))))))
(define (with-dot-lock* file-name thunk)
(dynamic-wind
(lambda ()
(obtain-dot-lock filename))
(lambda ()
(call-with-values thunk
(lambda a
(release-dot-lock filename)
(apply values a))))
(lambda ()
(release-dot-lock filename))))
(lambda ()
(obtain-dot-lock file-name))
(lambda ()
(call-with-values thunk
(lambda a
(release-dot-lock file-name)
(apply values a))))
(lambda ()
(release-dot-lock file-name))))
(define-syntax with-dot-lock
(syntax-rules
()
((with-dot-lock filename body ...)
(with-dot-lock* filename (lambda () body ...)))))
(syntax-rules ()
((with-dot-lock file-name body ...)
(with-dot-lock* file-name (lambda () body ...)))))

View File

@ -464,7 +464,8 @@
(open scsh-level-0
scheme
let-opt
threads) ; sleep
threads ; sleep
random)
(files dot-locking))
(define-structures ((syslog syslog-interface)