scsh-0.6/scsh/dot-locking.scm

51 lines
1.2 KiB
Scheme

(define (make-lockname filename)
(string-append filename ".lock"))
(define (create-temp filename)
(create-temp-file filename))
(define (maybe-obtain-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-lock filename)
(with-errno-handler
((errno packet)
(else #f))
(delete-file (make-lockname filename))
#t))
(define (obtain-lock filename)
(let ((tempname (create-temp filename)))
(delete-file tempname)
(let loop ()
(or (maybe-obtain-lock tempname filename)
(begin (sleep 1000)
(loop))))))
(define-syntax with-lock
(syntax-rules
()
((with-lock filename body ...)
(with-handler
(lambda (condition more)
(release-lock filename)
(more))
(lambda ()
(obtain-lock filename)
(call-with-values (lambda ()
body ...)
(lambda a
(release-lock filename)
(apply values a))))))))