From 8f3c22b40dc16e9a92b0211f71d86029d44f330d Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Mon, 17 Dec 2001 09:24:05 +0000
Subject: [PATCH] + New names for dot-locking procedures. + Optional retry
 interval and counter for obtain-dot-lock + Exported crypt

---
 scsh/dot-locking.scm     | 58 ++++++++++++++++++++++------------------
 scsh/scsh-interfaces.scm | 12 +++++----
 scsh/scsh-package.scm    | 10 ++++---
 3 files changed, 45 insertions(+), 35 deletions(-)

diff --git a/scsh/dot-locking.scm b/scsh/dot-locking.scm
index 985f5bc..cc4bfd3 100644
--- a/scsh/dot-locking.scm
+++ b/scsh/dot-locking.scm
@@ -1,10 +1,7 @@
 (define (make-lockname filename)
   (string-append filename ".lock"))
 
-(define (create-temp filename)
- (create-temp-file filename))
-
-(define (maybe-obtain-lock tempname filename)
+(define (maybe-obtain-dot-lock tempname filename)
  (let ((port (open-file tempname (bitwise-ior open/write 
 					      open/create 
 					      open/exclusive))))
@@ -18,33 +15,42 @@
     (delete-file tempname)
     #t)))
 
-(define (release-lock filename)
+(define (release-dot-lock filename)
   (with-errno-handler
    ((errno packet)
     (else #f))
    (delete-file (make-lockname filename))
    #t))
 
-(define (obtain-lock filename)
-  (let ((tempname (create-temp filename)))
-    (delete-file tempname)
-    (let loop ()
-      (or (maybe-obtain-lock tempname filename)
-	  (begin (sleep 1000)
-		 (loop))))))
-	
-(define-syntax with-lock
+(define (obtain-dot-lock filename . args)
+  (let-optionals args ((retry-interval 1000) (retry-number #f))
+     (let ((tempname (create-temp-file filename)))
+       (delete-file tempname)
+       (let loop ((retry-number retry-number))
+	 (or (maybe-obtain-dot-lock tempname filename)
+	     (begin (sleep retry-interval)
+		    (cond ((not retry-number)
+			   (loop retry-number))
+			  ((> retry-number 0)
+			   (loop (- retry-number 1)))
+			  (else #f))))))))
+
+(define (with-dot-lock* filename thunk)
+  (dynamic-wind
+     (lambda () 
+       (obtain-dot-lock filename))
+     (lambda ()
+       (call-with-values thunk
+			 (lambda a
+			   (release-dot-lock filename)
+			   (apply values a))))
+     (lambda ()
+       (release-dot-lock filename))))
+
+(define-syntax with-dot-lock
   (syntax-rules 
    ()
-   ((with-lock filename body ...)
-    (with-handler
-     (lambda (condition more)
-       (release-lock filename)
-       (more))
-     (lambda ()
-       (obtain-lock filename)
-       (call-with-values (lambda ()
-			   body ...)
-			 (lambda a
-			   (release-lock filename)
-			   (apply values a))))))))
+   ((with-dot-lock filename body ...)
+    (with-dot-lock* filename (lambda () body ...)))))
+
+
diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm
index 7e144d4..b73d4d1 100644
--- a/scsh/scsh-interfaces.scm
+++ b/scsh/scsh-interfaces.scm
@@ -1081,10 +1081,11 @@
 	  remove-interrupt
 	  full-interrupt-set))
 
-(define-interface locks-interface
-  (export obtain-lock
-	  release-lock
-	  (with-lock :syntax)))
+(define-interface dot-locking-interface
+  (export obtain-dot-lock
+	  release-dot-lock
+	  (with-dot-lock :syntax)
+	  with-dot-lock*))
 
 (define-interface syslog-interface
   (export (syslog-option :syntax)
@@ -1117,4 +1118,5 @@
 	  set-syslog-channel!
 	  with-syslog-channel))
 
-
+(define-interface crypt-interface
+  (export crypt))
\ No newline at end of file
diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm
index 878bdeb..bc6708e 100644
--- a/scsh/scsh-package.scm
+++ b/scsh/scsh-package.scm
@@ -132,6 +132,7 @@
 			(interface-of ascii) ; char<->ascii
 			string-ports-interface
 			syslog-interface
+			crypt-interface
 			))
    (scsh-level-0-internals (export set-command-line-args!
 				   init-scsh-hindbrain
@@ -385,6 +386,7 @@
 		      awk-interface
 		      char-predicates-interface; Urk -- Some of this is R5RS!
 		      obsolete-char-set-interface
+		      dot-locking-interface
 		      )
 
   (open structure-refs
@@ -458,12 +460,12 @@
 	  threads-internal)
   (files threads))
 
-(define-structure dot-locking locks-interface
-  (open scsh
+(define-structure dot-locking dot-locking-interface
+  (open scsh-level-0
 	scheme
-	handle
+	let-opt
 	threads) ; sleep
-  (files dot-locking)) 
+  (files dot-locking))
 
 (define-structures ((syslog syslog-interface)
 		    (syslog-channels syslog-channels-interface))