diff --git a/.gitignore b/.gitignore
index c527276..e386030 100644
--- a/.gitignore
+++ b/.gitignore
@@ -26,3 +26,4 @@ venv*
retropikzel/wasm/plus.sld
retropikzel/*.c
retropikzel/*.meta
+test-program
diff --git a/Makefile b/Makefile
index 0178015..7155f5c 100644
--- a/Makefile
+++ b/Makefile
@@ -12,7 +12,7 @@ LIBRARY_FILE=retropikzel/${LIBRARY}.sld
TESTFILE=retropikzel/${LIBRARY}/test.scm
VERSION != cat retropikzel/${LIBRARY}/VERSION
DESCRIPTION != head -n1 retropikzel/${LIBRARY}/README.md
-README=retropikzel/${LIBRARY}/README.html
+DOCFILE=retropikzel/${LIBRARY}/README.html
ifeq "${SCHEME}" "capyscheme"
DOCKER_TAG=head
@@ -32,12 +32,12 @@ endif
all: package
package: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md
- echo "$$(cat retropikzel/${LIBRARY}/README.md)" > ${README}
+ echo "$$(cat retropikzel/${LIBRARY}/README.md)" > ${DOCFILE}
snow-chibi package \
--always-yes \
--version=${VERSION} \
--authors=${AUTHOR} \
- --doc-from-scribble=1 \
+ --doc=${DOCFILE} \
--description="${DESCRIPTION}" \
--test=${TESTFILE} \
${LIBRARY_FILE}
@@ -47,16 +47,12 @@ ${PKG}: package
install: ${PKG}
snow-chibi install --impls=${SCHEME} --always-yes --install-tests?=1 --show-tests?=1 ${PKG}
-test: package
- snow-chibi install --impls=${SCHEME} --always-yes --install-tests?=1 --show-tests?=1 ${PKG}
- snow-chibi install --impls=${SCHEME} --always-yes --install-tests?=1 --show-tests?=1 ${PKG}
-
-old-test:
- cd ${tmpdir} && COMPILE_R7RS=${SCHEME} CSC_OPIONS="-L -lcurl" compile-r7rs -o test-program test.${SFX}
- cd ${tmpdir} && ./test-program
+test:
+ COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program ${TESTFILE}
+ ./test-program
test-docker:
- SNOW_PACKAGES="srfi.19 srfi.64 srfi.180 ${PKG}" \
+ SNOW_PACKAGES="srfi.19 srfi.64 srfi.180 retropikzel.tap ${PKG}" \
APT_PACKAGES="libcurl4-openssl-dev" \
AKKU_PACKAGES="${AKKU_PACKAGES}" \
DOCKER_TAG=${DOCKER_TAG} \
diff --git a/retropikzel/dot-locking.scm b/retropikzel/dot-locking.scm
new file mode 100644
index 0000000..3d70702
--- /dev/null
+++ b/retropikzel/dot-locking.scm
@@ -0,0 +1,100 @@
+(define (make-lock-file-name file-name) (string-append file-name ".lock"))
+(define (sleep time)
+ (letrec*
+ ((end-time
+ (let ((end-time (current-time))
+ (seconds (quotient time 1000))
+ (nanoseconds (* (remainder time 1000) 1000000)))
+ (set-time-second! end-time (+ (time-second end-time) seconds))
+ (set-time-nanosecond! end-time (+ (time-nanosecond end-time) nanoseconds))
+ end-time))
+ (looper (lambda () (when (time= (length args) 1)
+ (let ((interval (list-ref args 0)))
+ (when (not (integer? interval))
+ (error (string-append "obtain-dot-lock error: interval must"
+ " be integer"
+ interval)))
+ interval)
+ 1000)))
+ (retry-number
+ (if (>= (length args) 2)
+ (let ((retry-number (list-ref args 1)))
+ (when (and (not (integer? retry-number))
+ (not (equal? retry-number #f)))
+ (error (string-append "obtain-dot-lock error: retry-number must"
+ " be integer or #f")
+ retry-number))
+ retry-number)
+ #f))
+ (stale-time-seconds
+ (if (>= (length args) 3)
+ (let ((stale-time (list-ref args 2)))
+ (when (and (not (integer? stale-time))
+ (not (equal? stale-time #f)))
+ (error (string-append "obtain-dot-lock error: stale time must"
+ " be integer or #f")
+ stale-time))
+ stale-time)
+ 300))
+ (stale-time
+ (if stale-time-seconds
+ (add-duration (current-time time-utc)
+ (make-time time-duration 0 stale-time-seconds))
+ #f))
+ (lock-file-name (make-lock-file-name file-name))
+ (lock-time (lambda ()
+ (guard (condition (else #f))
+ (file-info:ctime (file-info lock-file-name))))))
+ (letrec
+ ((locker
+ (lambda (try-count)
+ (cond ((not (file-exists? lock-file-name))
+ (guard (condition (else (locker (+ try-count 1))))
+ (create-hard-link file-name lock-file-name)
+ #t))
+ ((and retry-number (> try-count retry-number)) #f)
+ ((and stale-time (time>? lock-time stale-time))
+ (break-dot-lock file-name)
+ (create-hard-link file-name lock-file-name)
+ (guard (condition (else #f))
+ (create-hard-link file-name lock-file-name)
+ 'broken))
+ ((or (not retry-number)
+ (<= try-count retry-number))
+ (sleep interval)
+ (locker (+ try-count)))))))
+ (locker 0))))
+
+(define (break-dot-lock file-name)
+ (let ((lock-file-name (make-lock-file-name file-name)))
+ (when (file-exists? lock-file-name) (delete-file lock-file-name))))
+
+(define (release-dot-lock file-name)
+ (let ((lock-file-name (make-lock-file-name file-name)))
+ (guard (condition (else #f))
+ (when (file-exists? lock-file-name)
+ (delete-file lock-file-name))
+ #t)))
+
+(define-syntax with-dot-lock*
+ (syntax-rules ()
+ ((_ file-name thunk)
+ (letrec* ((locked? (obtain-dot-lock file-name))
+ (unlock (lambda ()
+ (when locked? (break-dot-lock file-name))
+ (set! locked? #f))))
+ (when locked?
+ (dynamic-wind (lambda () #t)
+ (lambda () (guard (condition (else (unlock))) (thunk)))
+ unlock))
+ (unlock)))))
+
+(define-syntax with-dot-lock
+ (syntax-rules ()
+ ((_ file-name body ...)
+ (with-dot-lock* file-name (lambda () body ...)))))
diff --git a/retropikzel/dot-locking.sld b/retropikzel/dot-locking.sld
new file mode 100644
index 0000000..afa0f4c
--- /dev/null
+++ b/retropikzel/dot-locking.sld
@@ -0,0 +1,13 @@
+(define-library
+ (retropikzel dot-locking)
+ (import (scheme base)
+ (scheme write)
+ (scheme file)
+ (srfi 19)
+ (srfi 170))
+ (export obtain-dot-lock
+ break-dot-lock
+ release-dot-lock
+ with-dot-lock*
+ with-dot-lock)
+ (include "dot-locking.scm"))
diff --git a/retropikzel/dot-locking/LICENSE b/retropikzel/dot-locking/LICENSE
new file mode 100644
index 0000000..0a04128
--- /dev/null
+++ b/retropikzel/dot-locking/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/retropikzel/dot-locking/README.md b/retropikzel/dot-locking/README.md
new file mode 100644
index 0000000..98f9598
--- /dev/null
+++ b/retropikzel/dot-locking/README.md
@@ -0,0 +1,55 @@
+Dot locking for files
+
+This is an implementation of dot-locking from [scsh](https://scsh.net/).
+
+## Documentation
+
+From [https://scsh.net/docu/html/man-Z-H-11.html#node_sec_10.3](https://scsh.net/docu/html/man-Z-H-11.html#node_sec_10.3)
+
+Copied here for convenience.
+
+
+(__obtain-dot-lock__ file-name)
+
+Tries to obtain the lock for file-name. If the file is already locked, the thread
+sleeps for interval seconds (default is 1) before it retries. If the lock cannot
+be obtained after retry-number attempts, the procedure returns #f, other-
+wise #t. The default value of retry-number is #f which corresponds to an
+infinite number of retires.
+If stale-time is non-#f, it specifies the minimum age a lock may have
+(in seconds) before it is considered stale. Obtain-dot-lock attempts to
+delete stale locks. If it was succcessful obtaining a lock after breaking
+it, obtain-dot-lock returns broken. If stale-time is #f, obtain-dot-lock
+never considers a lock stale. The default for stale-time is 300.
+Note that it is possible that obtain-dot-lock breaks a lock but never-
+theless fails to obtain it otherwise. If it is necessary to handle this case
+specially, use break-dot-lock directly (see below) rather than specifying
+a non-#f stale-time
+
+
+(__break-dot-lock__ file-name)
+
+Breaks the lock for file-name if one exists. Note that breaking a lock
+does not imply a subsequent obtain-dot-lock will succeed, as an-
+other party may have acquired the lock between break-dot-lock and
+obtain-dot-lock.
+
+
+(__release-dot-lock__ file-name)
+
+Releases the lock for file-name. On success, release-dot-lock returns #t,
+otherwise #f. Note that this procedure can also be used to break the lock
+for file-name.
+
+
+(__with-dot-lock*__ file-name thunk)
+(__with-dot-lock__ file-name body ...)
+
+The procedure with-dot-lock* obtains the requested lock, and then calls
+(thunk). When thunk returns, the lock is released. A non-local exit (e.g.,
+throwing to a saved continuation or raising an exception) also causes the
+lock to be released.
+After a normal return from thunk, its return values are returned by
+with-dot-lock*. The with-dot-lock special form is equivalent syntac-
+tic sugar.
+
diff --git a/retropikzel/dot-locking/VERSION b/retropikzel/dot-locking/VERSION
new file mode 100644
index 0000000..3eefcb9
--- /dev/null
+++ b/retropikzel/dot-locking/VERSION
@@ -0,0 +1 @@
+1.0.0
diff --git a/retropikzel/dot-locking/test.scm b/retropikzel/dot-locking/test.scm
new file mode 100644
index 0000000..6337a41
--- /dev/null
+++ b/retropikzel/dot-locking/test.scm
@@ -0,0 +1,73 @@
+(import (scheme base)
+ (scheme write)
+ (scheme read)
+ (scheme char)
+ (scheme file)
+ (scheme process-context)
+ (retropikzel tap)
+ (retropikzel dot-locking)
+ (srfi 64))
+
+(test-runner-current (tap-runner))
+
+(test-begin "dot-locking")
+
+
+(test-begin "obtain-dot-lock")
+(let* ((testfile "/tmp/scshtestfile.txt")
+ (lockfile (string-append testfile ".lock")))
+ (when (file-exists? testfile) (delete-file testfile))
+ (when (file-exists? lockfile) (delete-file lockfile))
+ (with-output-to-file testfile (lambda () (display 1)))
+ (obtain-dot-lock testfile)
+ (test-assert (file-exists? lockfile)))
+(test-end "obtain-dot-lock")
+
+
+(test-begin "break-dot-lock")
+(let* ((testfile "/tmp/scshtestfile.txt")
+ (lockfile (string-append testfile ".lock")))
+ (when (file-exists? testfile) (delete-file testfile))
+ (when (file-exists? lockfile) (delete-file lockfile))
+ (with-output-to-file testfile (lambda () (display 1)))
+ (obtain-dot-lock testfile)
+ (break-dot-lock testfile)
+ (test-assert (not (file-exists? lockfile))))
+(test-end "break-dot-lock")
+
+
+(test-begin "release-dot-lock")
+(let* ((testfile "/tmp/scshtestfile.txt")
+ (lockfile (string-append testfile ".lock")))
+ (when (file-exists? testfile) (delete-file testfile))
+ (when (file-exists? lockfile) (delete-file lockfile))
+ (with-output-to-file testfile (lambda () (display 1)))
+ (obtain-dot-lock testfile)
+ (test-assert (release-dot-lock testfile)))
+(test-end "release-dot-lock")
+
+
+(test-begin "with-dot-lock*")
+(let* ((testfile "/tmp/scshtestfile.txt")
+ (lockfile (string-append testfile ".lock")))
+ (when (file-exists? testfile) (delete-file testfile))
+ (when (file-exists? lockfile) (delete-file lockfile))
+ (with-output-to-file testfile (lambda () (display 1)))
+ (with-dot-lock*
+ testfile
+ (lambda ()
+ (test-assert (file-exists? lockfile)))))
+(test-end "with-dot-lock*")
+
+
+(test-begin "with-dot-lock")
+(let* ((testfile "/tmp/scshtestfile.txt")
+ (lockfile (string-append testfile ".lock")))
+ (when (file-exists? testfile) (delete-file testfile))
+ (when (file-exists? lockfile) (delete-file lockfile))
+ (with-output-to-file testfile (lambda () (display 1)))
+ (with-dot-lock testfile (test-assert (file-exists? lockfile))))
+(test-end "with-dot-lock")
+
+
+(test-end "dot-locking")