/usr/share/scsh-0.6/scsh/dot-locking.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | (define (make-lock-file-name file-name)
(string-append file-name ".lock"))
(define (release-dot-lock file-name)
(with-errno-handler
((errno packet)
(else #f))
(delete-file (make-lock-file-name file-name))
#t))
(define (maybe-obtain-dot-lock file-name)
(let ((temp-name (create-temp-file file-name)))
(with-errno-handler
((errno packet)
((errno/exist)
(delete-file temp-name)
#f))
(create-hard-link temp-name (make-lock-file-name file-name))
(delete-file temp-name)
#t)))
(define random
(let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
(lambda (limit)
(quotient (* (modulo (crank) 314159265)
limit)
314159265))))
;; 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 . 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
(lambda ()
(obtain-dot-lock file-name))
(lambda ()
(call-with-values thunk
(lambda a
(release-dot-lock file-name)
(apply values a))))
(lambda ()
(release-dot-lock file-name))))
(define-syntax with-dot-lock
(syntax-rules ()
((with-dot-lock file-name body ...)
(with-dot-lock* file-name (lambda () body ...)))))
|