scsh-0.6/scsh/dot-locking.scm

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 ...)))))