51 lines
1.2 KiB
Scheme
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))))))))
|