+ New names for dot-locking procedures.

+ Optional retry interval and counter for obtain-dot-lock
+ Exported crypt

scsh/dot-locking.scm

@@ -1,10 +1,7 @@
 (define (make-lockname filename)
   (string-append filename ".lock"))
 
-(define (create-temp filename)
+(define (maybe-obtain-dot-lock tempname filename)
- (create-temp-file filename))
-
-(define (maybe-obtain-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)
+(define (obtain-dot-lock filename . args)
-  (let ((tempname (create-temp filename)))
+  (let-optionals args ((retry-interval 1000) (retry-number #f))
-    (delete-file tempname)
+     (let ((tempname (create-temp-file filename)))
-    (let loop ()
+       (delete-file tempname)
-      (or (maybe-obtain-lock tempname filename)
+       (let loop ((retry-number retry-number))
-	  (begin (sleep 1000)
+	 (or (maybe-obtain-dot-lock tempname filename)
-		 (loop))))))
+	     (begin (sleep retry-interval)
+		    (cond ((not retry-number)
+			   (loop retry-number))
+			  ((> retry-number 0)
+			   (loop (- retry-number 1)))
+			  (else #f))))))))
 
-(define-syntax with-lock
+(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-dot-lock filename body ...)
-    (with-handler
+    (with-dot-lock* filename (lambda () body ...)))))
-     (lambda (condition more)
+
-       (release-lock filename)
+
-       (more))
-     (lambda ()
-       (obtain-lock filename)
-       (call-with-values (lambda ()
-			   body ...)
-			 (lambda a
-			   (release-lock filename)
-			   (apply values a))))))))

scsh/scsh-interfaces.scm

@@ -1081,10 +1081,11 @@
 	  remove-interrupt
 	  full-interrupt-set))
 
-(define-interface locks-interface
+(define-interface dot-locking-interface
-  (export obtain-lock
+  (export obtain-dot-lock
-	  release-lock
+	  release-dot-lock
-	  (with-lock :syntax)))
+	  (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))

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,10 +460,10 @@
 	  threads-internal)
   (files threads))
 
-(define-structure dot-locking locks-interface
+(define-structure dot-locking dot-locking-interface
-  (open scsh
+  (open scsh-level-0
 	scheme
-	handle
+	let-opt
 	threads) ; sleep
   (files dot-locking))