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))