101 lines
4.0 KiB
Scheme
101 lines
4.0 KiB
Scheme
(define (make-lock-file-name file-name) (string-append file-name ".lock"))
|
|
(define (sleep time)
|
|
(letrec*
|
|
((end-time
|
|
(let ((end-time (current-time))
|
|
(seconds (quotient time 1000))
|
|
(nanoseconds (* (remainder time 1000) 1000000)))
|
|
(set-time-second! end-time (+ (time-second end-time) seconds))
|
|
(set-time-nanosecond! end-time (+ (time-nanosecond end-time) nanoseconds))
|
|
end-time))
|
|
(looper (lambda () (when (time<? (current-time) end-time) (looper)))))
|
|
(looper)))
|
|
|
|
(define (obtain-dot-lock file-name . args)
|
|
(let* ((interval
|
|
(* (if (>= (length args) 1)
|
|
(let ((interval (list-ref args 0)))
|
|
(when (not (integer? interval))
|
|
(error (string-append "obtain-dot-lock error: interval must"
|
|
" be integer"
|
|
interval)))
|
|
interval)
|
|
1000)))
|
|
(retry-number
|
|
(if (>= (length args) 2)
|
|
(let ((retry-number (list-ref args 1)))
|
|
(when (and (not (integer? retry-number))
|
|
(not (equal? retry-number #f)))
|
|
(error (string-append "obtain-dot-lock error: retry-number must"
|
|
" be integer or #f")
|
|
retry-number))
|
|
retry-number)
|
|
#f))
|
|
(stale-time-seconds
|
|
(if (>= (length args) 3)
|
|
(let ((stale-time (list-ref args 2)))
|
|
(when (and (not (integer? stale-time))
|
|
(not (equal? stale-time #f)))
|
|
(error (string-append "obtain-dot-lock error: stale time must"
|
|
" be integer or #f")
|
|
stale-time))
|
|
stale-time)
|
|
300))
|
|
(stale-time
|
|
(if stale-time-seconds
|
|
(add-duration (current-time time-utc)
|
|
(make-time time-duration 0 stale-time-seconds))
|
|
#f))
|
|
(lock-file-name (make-lock-file-name file-name))
|
|
(lock-time (lambda ()
|
|
(guard (condition (else #f))
|
|
(file-info:ctime (file-info lock-file-name))))))
|
|
(letrec
|
|
((locker
|
|
(lambda (try-count)
|
|
(cond ((not (file-exists? lock-file-name))
|
|
(guard (condition (else (locker (+ try-count 1))))
|
|
(create-hard-link file-name lock-file-name)
|
|
#t))
|
|
((and retry-number (> try-count retry-number)) #f)
|
|
((and stale-time (time>? lock-time stale-time))
|
|
(break-dot-lock file-name)
|
|
(create-hard-link file-name lock-file-name)
|
|
(guard (condition (else #f))
|
|
(create-hard-link file-name lock-file-name)
|
|
'broken))
|
|
((or (not retry-number)
|
|
(<= try-count retry-number))
|
|
(sleep interval)
|
|
(locker (+ try-count)))))))
|
|
(locker 0))))
|
|
|
|
(define (break-dot-lock file-name)
|
|
(let ((lock-file-name (make-lock-file-name file-name)))
|
|
(when (file-exists? lock-file-name) (delete-file lock-file-name))))
|
|
|
|
(define (release-dot-lock file-name)
|
|
(let ((lock-file-name (make-lock-file-name file-name)))
|
|
(guard (condition (else #f))
|
|
(when (file-exists? lock-file-name)
|
|
(delete-file lock-file-name))
|
|
#t)))
|
|
|
|
(define-syntax with-dot-lock*
|
|
(syntax-rules ()
|
|
((_ file-name thunk)
|
|
(letrec* ((locked? (obtain-dot-lock file-name))
|
|
(unlock (lambda ()
|
|
(when locked? (break-dot-lock file-name))
|
|
(set! locked? #f))))
|
|
(when locked?
|
|
(dynamic-wind (lambda () #t)
|
|
(lambda () (guard (condition (else (unlock))) (thunk)))
|
|
unlock))
|
|
(unlock)))))
|
|
|
|
(define-syntax with-dot-lock
|
|
(syntax-rules ()
|
|
((_ file-name body ...)
|
|
(with-dot-lock* file-name (lambda () body ...)))))
|