add `fs' backend

store.el

@@ -44,6 +44,9 @@
 ;;   cost for each persistent list operation should be independent of
 ;;   the total size of the list.
 
+;; - `fs': File-system based S-expr store.  Use a file per key-value
+;;   pair, with key S-expr as file name and value S-expr as content.
+
 ;;; Code:
 
 (require 'cl-lib)
@@ -80,7 +83,10 @@ storage when passed to `store-create'.")
 If LOCK is non nil, grab a lock of the backing storage when
 applicable.  If the backing storage is already locked, wait if
 NONBLOCK is nil or signal `file-locked' immediately if NONBLOCK
-is non nil.")
+is non nil."
+  ;; We provide a mock implementation for backends that do not support
+  ;; transaction.
+  (funcall function))
 (cl-defmacro store-with-transaction
     ((store &key (nonblock nil) (lock t)) &rest body)
   "Run BODY while holding a transaction for STORE.
@@ -94,31 +100,36 @@ is non nil."
 
 (cl-defgeneric store-put (key value store)
   "Associate KEY with VALUE in STORE.
-The operation is immediately persisted.")
+The operation is immediately persisted.
+Return VALUE.")
+(cl-defgeneric store-get (key store &optional dflt)
+  "Look up KEY in STORE and return its associated value.
+If KEY is not found, return DFLT which defaults to nil.")
 (cl-defgeneric store-rem (key store)
   "Remove KEY from STORE.
-The operation is immediately persisted.")
+The operation is immediately persisted.
+Return nil.")
+(gv-define-setter store-get (val key store &optional _dflt)
+  ;; TODO: can we detect if the place is used in `push', `cl-pushnew',
+  ;; etc and use the potentially more efficient `store-push' instead?
+  `(store-put ,key ,val ,store))
+
 (cl-defgeneric store-push (key value store)
   "Add VALUE to the list associated with KEY in STORE.
-The operation is immediately persisted."
+The operation is immediately persisted.
+Return the new list with VALUE added."
   ;; We provide a default implementation for backends not natively
   ;; supporting list operations.  Backends are encouraged to override
   ;; this with more efficient implementation.
   (store-put key (cons value (store-get key store)) store))
 (cl-defgeneric store-delete (key value store)
   "Remove VALUE from the list associated with KEY in STORE.
-The operation is immediately persisted."
+The operation is immediately persisted.
+Return the new list with VALUE removed."
   ;; We provide a default implementation for backends not natively
   ;; supporting list operations.  Backends are encouraged to override
   ;; this with more efficient implementation.
   (store-put key (delete value (store-get key store)) store))
-(cl-defgeneric store-get (key store &optional dflt)
-  "Look up KEY in STORE and return its associated value.
-If KEY is not found, return DFLT which defaults to nil.")
-(gv-define-setter store-get (val key store &optional _dflt)
-  ;; TODO: can we detect if the place is used in `push', `cl-pushnew',
-  ;; etc and use the potentially more efficient `store-push' instead?
-  `(store-put ,key ,val ,store))
 
 ;;; Automatic Compacting
 (defvar store-need-compacting-list nil
@@ -141,6 +152,12 @@ If KEY is not found, return DFLT which defaults to nil.")
   (unless (memq store-compact-idle-timer timer-list)
     (timer-activate-when-idle store-compact-idle-timer t)))
 
+;;; Serialization utility
+(defsubst store--print (form)
+  (let ((print-length nil) (print-level nil))
+    (prin1 form (current-buffer)))
+  (insert "\n"))
+
 ;;; `log' backend
 (defvar store-inhibit-ask-user-about-lock nil)
 (defun store-inhibit-ask-user-about-lock-advice (orig-func file opponent)
@@ -154,7 +171,7 @@ If KEY is not found, return DFLT which defaults to nil.")
     (funcall orig-func file)))
 (advice-add 'ask-user-about-supersession-threat :around #'store-inhibit-ask-user-about-supersession-threat-advice)
 
-(cl-defstruct (store-log (:constructor store--make-log))
+(cl-defstruct (store-log (:constructor store-log--make))
   path (table (make-hash-table :test 'equal)) (log-count 0) compact-ratio
   ;; I used to use a `gensym' redirection to exploit thread-safe
   ;; dynamic binding for `store-log-transaction-buffer', but currently
@@ -238,22 +255,18 @@ If file PATH exists, load its content into a key value store and return it.
 
 COMPACT-RATIO controls automatic compacting.  Arrange for
 compacting if log count exceeds (COMPACT-RATIO * size-of-table)."
-  (let* ((store-log (store--make-log :path path :compact-ratio compact-ratio)))
+  (let* ((store-log (store-log--make :path path :compact-ratio compact-ratio)))
     (when (file-exists-p path)
       (store-log-load store-log))
     store-log))
 (cl-defmethod store-path ((store store-log))
   (store-log-path store))
 
-(defsubst store-log--log (form)
-  (let ((print-length nil) (print-level nil))
-    (prin1 form (current-buffer)))
-  (insert "\n"))
 (cl-defmethod store-compact ((store store-log) &optional nonblock)
   (store-log--ensure-transaction-buffer (store :nonblock nonblock)
     (setf (store-log-log-count store) (hash-table-count (store-log-table store)))
     (with-temp-buffer
-      (maphash (lambda (key value) (store-log--log (list '++ key value)))
+      (maphash (lambda (key value) (store--print (list '++ key value)))
                (store-log-table store))
       (let ((file-precious-flag t))
         (write-region nil nil (store-log-path store) nil 'silent)))))
@@ -269,27 +282,61 @@ Arrange for compacting if log count exceeds (compact-ratio * size-of-table)."
     (store-compact-demon-summon)))
 (cl-defmethod store-put (key value (store store-log))
   (store-log--ensure-transaction-buffer (store)
-    (store-log--log (list '++ key value))
+    (store--print (list '++ key value))
     (store-log--inc-log-count store)
     (puthash key value (store-log-table store))))
 (cl-defmethod store-rem (key (store store-log))
   (store-log--ensure-transaction-buffer (store)
-    (store-log--log (list '-- key))
+    (store--print (list '-- key))
     (store-log--inc-log-count store)
     (remhash key (store-log-table store))))
 (cl-defmethod store-push (key value (store store-log))
   (store-log--ensure-transaction-buffer (store)
-    (store-log--log (list 'l+ key value))
+    (store--print (list 'l+ key value))
     (store-log--inc-log-count store)
     (push value (gethash key (store-log-table store)))))
 (cl-defmethod store-delete (key value (store store-log))
   (store-log--ensure-transaction-buffer (store)
-    (store-log--log (list 'l- key value))
+    (store--print (list 'l- key value))
     (store-log--inc-log-count store)
     (puthash key (delete value (gethash key (store-log-table store)))
              (store-log-table store))))
 (cl-defmethod store-get (key (store store-log) &optional dflt)
   (gethash key (store-log-table store) dflt))
 
+;; `fs' backend
+(cl-defstruct (store-fs (:constructor store-fs--make))
+  path)
+(cl-defmethod store-create (path (_backend (eql fs)) &key &allow-other-keys)
+  (if (file-exists-p path)
+      (unless (file-directory-p path)
+        (error "`fs' backend requires PATH to be a directory, but %s is not" path))
+    (mkdir path))
+  ;; We normalize PATH right away, saving future hassles.
+  (store-fs--make :path (file-name-as-directory path)))
+(cl-defmethod store-path ((store store-fs))
+  (store-fs-path store))
+
+(defsubst store-fs--key-to-path (key store)
+  ;; TODO: escape illegal characters
+  (concat (store-fs-path store) (prin1-to-string key)))
+(cl-defmethod store-put (key value (store store-fs))
+  (with-temp-buffer
+    (store--print value)
+    (let ((file-precious-flag t))
+      (write-region nil nil
+                    (store-fs--key-to-path key store)
+                    nil 'quiet)))
+  value)
+(cl-defmethod store-get (key (store store-fs) &optional dflt)
+  (let ((path (store-fs--key-to-path key store)))
+    (if (file-exists-p path)
+        (with-temp-buffer
+          (insert-file-contents path)
+          (read (current-buffer)))
+      dflt)))
+(cl-defmethod store-rem (key (store store-fs))
+  (delete-file (store-fs--key-to-path key store))
+  nil)
 (provide 'store)
 ;;; store.el ends here