103 lines
4.0 KiB
Scheme
103 lines
4.0 KiB
Scheme
(define (make-lock-file-name file-name) (string-append file-name ".lock"))
|
|
(define (sleep time)
|
|
(letrec*
|
|
((end-time (+ (current-second) time))
|
|
(looper (lambda () (when (> (current-second) 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
|
|
(+ (current-second) stale-time-seconds)
|
|
#f))
|
|
(lock-file-name (make-lock-file-name file-name))
|
|
(lock-time (lambda ()
|
|
(if (file-exists? lock-file-name)
|
|
(guard (condition (else 0))
|
|
(string->number
|
|
(with-input-from-file
|
|
lock-file-name
|
|
(lambda () (read)))))
|
|
0)))
|
|
(write-lock-file
|
|
(lambda ()
|
|
(with-output-to-file
|
|
lock-file-name
|
|
(lambda ()
|
|
(write (current-second)))))))
|
|
(letrec
|
|
((locker
|
|
(lambda (try-count)
|
|
(cond ((not (file-exists? lock-file-name))
|
|
(guard (condition (else (locker (+ try-count 1))))
|
|
(write-lock-file)
|
|
#t))
|
|
((and retry-number (> try-count retry-number)) #f)
|
|
((and stale-time (> (lock-time) stale-time))
|
|
(break-dot-lock file-name)
|
|
(write-lock-file)
|
|
(guard (condition (else #f))
|
|
(write-lock-file)
|
|
'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 ...)))))
|