diff --git a/scsh/dot-locking.scm b/scsh/dot-locking.scm index 92813b1..d85f405 100644 --- a/scsh/dot-locking.scm +++ b/scsh/dot-locking.scm @@ -29,32 +29,43 @@ ;; STALE-TIME is the minimum age of a lock to be broken ;; if #f, don't break the lock -(define (obtain-dot-lock file-name retry-interval retry-number stale-time) - (let ((lock-file-name (make-lock-file-name file-name))) - (let loop ((retry-number retry-number)) - (cond - ((maybe-obtain-dot-lock file-name) - #t) - ((and stale-time - (with-errno-handler - ((errno packet) - (else #f)) - (> (time) - (+ (file-last-status-change (make-lock-file-name file-name)) - stale-time)))) - (with-errno-handler - ((errno packet) - ((errno/noent) 'dont-care)) - (delete-file lock-file-name)) - (loop retry-number)) - (else - (sleep (+ (quotient (* retry-interval 3) 4) - (random (quotient retry-interval 2)))) - (cond ((not retry-number) - (loop retry-number)) - ((> retry-number 0) - (loop (- retry-number 1))) - (else #f))))))) +(define (obtain-dot-lock file-name . args) + (let-optionals args ((retry-seconds 1) + (retry-number #f) + (stale-time 300)) + (let ((lock-file-name (make-lock-file-name file-name)) + (retry-interval (* retry-seconds 1000))) + (let loop ((retry-number retry-number) + (broken? #f)) + (cond + ((maybe-obtain-dot-lock file-name) + (if broken? + 'broken + #t)) + ((and stale-time + (with-errno-handler + ((errno packet) + (else #f)) + (> (time) + (+ (file-last-status-change (make-lock-file-name file-name)) + stale-time)))) + (break-dot-lock file-name) + (loop retry-number #t)) + (else + (sleep (+ (quotient (* retry-interval 3) 4) + (random (quotient retry-interval 2)))) + (cond ((not retry-number) + (loop retry-number broken?)) + ((> retry-number 0) + (loop (- retry-number 1) broken?)) + (else + #f)))))))) + +(define (break-dot-lock file-name) + (with-errno-handler + ((errno packet) + ((errno/noent) 'dont-care)) + (delete-file (make-lock-file-name file-name)))) (define (with-dot-lock* file-name thunk) (dynamic-wind