57 lines
1.4 KiB
Scheme
57 lines
1.4 KiB
Scheme
(define (make-lockname filename)
|
|
(string-append filename ".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)
|
|
(with-errno-handler
|
|
((errno packet)
|
|
(else #f))
|
|
(delete-file (make-lockname filename))
|
|
#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 (with-dot-lock* filename 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))))
|
|
|
|
(define-syntax with-dot-lock
|
|
(syntax-rules
|
|
()
|
|
((with-dot-lock filename body ...)
|
|
(with-dot-lock* filename (lambda () body ...)))))
|
|
|
|
|