Basically reimplement to my idea of dot-locking.

(Sorry, Martin ...)

scsh/dot-locking.scm

@@ -1,56 +1,76 @@
-(define (make-lockname filename)
+(define (make-lock-file-name file-name)
-  (string-append filename ".lock"))
+  (string-append file-name ".lock"))
 
-(define (maybe-obtain-dot-lock tempname filename)
+(define (release-dot-lock file-name)
- (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-dot-lock filename)
   (with-errno-handler
    ((errno packet)
     (else #f))
-   (delete-file (make-lockname filename))
+   (delete-file (make-lock-file-name file-name))
    #t))
 
-(define (obtain-dot-lock filename . args)
+(define (maybe-obtain-dot-lock file-name)
-  (let-optionals args ((retry-interval 1000) (retry-number #f))
+  (let ((temp-name (create-temp-file file-name)))
-     (let ((tempname (create-temp-file filename)))
+    (with-errno-handler
-       (delete-file tempname)
+     ((errno packet)
-       (let loop ((retry-number retry-number))
+      ((errno/exist)
-	 (or (maybe-obtain-dot-lock tempname filename)
+       (delete-file temp-name)
-	     (begin (sleep retry-interval)
+       #f))
-		    (cond ((not retry-number)
+     (create-hard-link temp-name (make-lock-file-name file-name))
-			   (loop retry-number))
+     (delete-file temp-name)
-			  ((> retry-number 0)
+     #t)))
-			   (loop (- retry-number 1)))
-			  (else #f))))))))
 
-(define (with-dot-lock* filename thunk)
+(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 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 (with-dot-lock* file-name thunk)
   (dynamic-wind
-     (lambda () 
+   (lambda () 
-       (obtain-dot-lock filename))
+     (obtain-dot-lock file-name))
-     (lambda ()
+   (lambda ()
-       (call-with-values thunk
+     (call-with-values thunk
-			 (lambda a
+		       (lambda a
-			   (release-dot-lock filename)
+			 (release-dot-lock file-name)
-			   (apply values a))))
+			 (apply values a))))
-     (lambda ()
+   (lambda ()
-       (release-dot-lock filename))))
+     (release-dot-lock file-name))))
 
 (define-syntax with-dot-lock
-  (syntax-rules 
+  (syntax-rules ()
-   ()
+   ((with-dot-lock file-name body ...)
-   ((with-dot-lock filename body ...)
+    (with-dot-lock* file-name (lambda () body ...)))))
-    (with-dot-lock* filename (lambda () body ...)))))
 
 

scsh/scsh-package.scm

@@ -464,7 +464,8 @@
   (open scsh-level-0
 	scheme
 	let-opt
-	threads) ; sleep
+	threads  ; sleep
+	random)
   (files dot-locking))
 
 (define-structures ((syslog syslog-interface)