diff --git a/scsh/dot-locking.scm b/scsh/dot-locking.scm new file mode 100644 index 0000000..985f5bc --- /dev/null +++ b/scsh/dot-locking.scm @@ -0,0 +1,50 @@ +(define (make-lockname filename) + (string-append filename ".lock")) + +(define (create-temp filename) + (create-temp-file filename)) + +(define (maybe-obtain-lock tempname filename) + (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-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 + (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)))))))) diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index 7a6b1c5..cafb7eb 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -1157,4 +1157,5 @@ (define-interface locks-interface (export obtain-lock - release-lock)) \ No newline at end of file + release-lock + (with-lock :syntax))) \ No newline at end of file diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index d1f9c80..453bc24 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -382,6 +382,7 @@ ; dbm awk-package field-reader-package + dot-locking scheme) (access scsh-top-package) @@ -445,3 +446,11 @@ threads threads-internal) (files threads)) + +(define-structure dot-locking locks-interface + (open scsh + scheme + handle + threads) ; sleep + (files dot-locking)) + \ No newline at end of file