diff options
Diffstat (limited to 'lisp/emacs-lisp/multisession.el')
| -rw-r--r-- | lisp/emacs-lisp/multisession.el | 446 |
1 files changed, 446 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el new file mode 100644 index 00000000000..6ef0da10f77 --- /dev/null +++ b/lisp/emacs-lisp/multisession.el @@ -0,0 +1,446 @@ +;;; multisession.el --- Multisession storage for variables -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'sqlite) +(require 'tabulated-list) + +(defcustom multisession-storage 'files + "Storage method for multisession variables. +Valid methods are `sqlite' and `files'." + :type '(choice (const :tag "SQLite" sqlite) + (const :tag "Files" files)) + :version "29.1" + :group 'files) + +(defcustom multisession-directory (expand-file-name "multisession/" + user-emacs-directory) + "Directory to store multisession variables." + :type 'file + :version "29.1" + :group 'files) + +;;;###autoload +(defmacro define-multisession-variable (name initial-value &optional doc + &rest args) + "Make NAME into a multisession variable initialized from INITIAL-VALUE. +DOC should be a doc string, and ARGS are keywords as applicable to +`make-multisession'." + (declare (indent defun)) + (unless (plist-get args :package) + (setq args (nconc (list :package + (replace-regexp-in-string "-.*" "" + (symbol-name name))) + args))) + `(defvar ,name + (make-multisession :key ,(symbol-name name) + :initial-value ,initial-value + ,@args) + ,@(list doc))) + +(defconst multisession--unbound (make-symbol "unbound")) + +(cl-defstruct (multisession + (:constructor nil) + (:constructor multisession--create) + (:conc-name multisession--)) + "A persistent variable that will live across Emacs invocations." + key + (initial-value nil) + package + (storage multisession-storage) + (synchronized nil) + (cached-value multisession--unbound) + (cached-sequence 0)) + +(cl-defun make-multisession (&key key initial-value package synchronized + storage) + "Create a multisession object." + (unless package + (error "No package for the multisession object")) + (unless key + (error "No key for the multisession object")) + (unless (stringp package) + (error "The package has to be a string")) + (unless (stringp key) + (error "The key has to be a string")) + (multisession--create + :key key + :synchronized synchronized + :initial-value initial-value + :package package + :storage (or storage multisession-storage))) + +(defun multisession-value (object) + "Return the value of the multisession OBJECT." + (if (null user-init-file) + ;; If we don't have storage, then just return the value from the + ;; object. + (if (eq (multisession--cached-value object) multisession--unbound) + (multisession--initial-value object) + (multisession--cached-value object)) + ;; We have storage, so we update from storage. + (multisession-backend-value (multisession--storage object) object))) + +(defun multisession--set-value (object value) + "Set the stored value of OBJECT to VALUE." + (if (null user-init-file) + ;; We have no backend, so just store the value. + (setf (multisession--cached-value object) value) + ;; We have a backend. + (multisession--backend-set-value (multisession--storage object) + object value))) + +(defun multisession-delete (object) + "Delete OBJECT from the backend storage." + (multisession--backend-delete (multisession--storage object) object)) + +(gv-define-simple-setter multisession-value multisession--set-value) + +;; SQLite Backend + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-pragma "sqlite.c") +(declare-function sqlite-transaction "sqlite.c") +(declare-function sqlite-commit "sqlite.c") + +(defvar multisession--db nil) + +(defun multisession--ensure-db () + (unless multisession--db + (let* ((file (expand-file-name "sqlite/multisession.sqlite" + multisession-directory)) + (dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t)) + (setq multisession--db (sqlite-open file))) + (with-sqlite-transaction multisession--db + ;; Use a write-ahead-log (available since 2010), which makes + ;; writes a lot faster. + (sqlite-pragma multisession--db "journal_mode = WAL") + (sqlite-pragma multisession--db "synchronous = NORMAL") + (unless (sqlite-select + multisession--db + "select name from sqlite_master where type = 'table' and name = 'multisession'") + ;; Tidy up the database automatically. + (sqlite-pragma multisession--db "auto_vacuum = FULL") + ;; Create the table. + (sqlite-execute + multisession--db + "create table multisession (package text not null, key text not null, sequence number not null default 1, value text not null)") + (sqlite-execute + multisession--db + "create unique index multisession_idx on multisession (package, key)"))))) + +(cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object) + (multisession--ensure-db) + (let ((id (list (multisession--package object) + (multisession--key object)))) + (cond + ;; We have no value yet; check the database. + ((eq (multisession--cached-value object) multisession--unbound) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where package = ? and key = ?" + id)))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing; return the initial value. + (multisession--initial-value object)))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where sequence > ? and package = ? and key = ?" + (cons (multisession--cached-sequence object) id))))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing, return the cached value. + (multisession--cached-value object)))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite)) + object value) + (catch 'done + (let ((i 0)) + (while (< i 10) + (condition-case nil + (throw 'done (multisession--set-value-sqlite object value)) + (sqlite-locked-error + (setq i (1+ i)) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal 'sqlite-locked-error "Database is locked")))) + +(defun multisession--set-value-sqlite (object value) + (multisession--ensure-db) + (with-sqlite-transaction multisession--db + (let ((id (list (multisession--package object) + (multisession--key object))) + (pvalue + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (prin1-to-string value)))) + (condition-case nil + (ignore (read-from-string pvalue)) + (error (error "Unable to store unreadable value: %s" pvalue))) + (sqlite-execute + multisession--db + "insert into multisession(package, key, sequence, value) values(?, ?, 1, ?) on conflict(package, key) do update set sequence = sequence + 1, value = ?" + (append id (list pvalue pvalue))) + (setf (multisession--cached-sequence object) + (caar (sqlite-select + multisession--db + "select sequence from multisession where package = ? and key = ?" + id))) + (setf (multisession--cached-value object) value)))) + +(cl-defmethod multisession--backend-values ((_type (eql 'sqlite))) + (multisession--ensure-db) + (sqlite-select + multisession--db + "select package, key, value from multisession order by package, key")) + +(cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object) + (sqlite-execute multisession--db + "delete from multisession where package = ? and key = ?" + (list (multisession--package object) + (multisession--key object)))) + +;; Files Backend + +(defun multisession--encode-file-name (name) + (url-hexify-string name)) + +(defun multisession--read-file-value (file object) + (catch 'done + (let ((i 0) + last-error) + (while (< i 10) + (condition-case err + (throw 'done + (with-temp-buffer + (let* ((time (file-attribute-modification-time + (file-attributes file))) + (coding-system-for-read 'utf-8)) + (insert-file-contents file) + (let ((stored (read (current-buffer)))) + (setf (multisession--cached-value object) stored + (multisession--cached-sequence object) time) + stored)))) + ;; Windows uses OS-level file locking that may preclude + ;; reading the file in some circumstances. So when that + ;; happens, wait a bit and try again. + (file-error + (setq i (1+ i) + last-error err) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal (car last-error) (cdr last-error))))) + +(defun multisession--object-file-name (object) + (expand-file-name + (concat "files/" + (multisession--encode-file-name (multisession--package object)) + "/" + (multisession--encode-file-name (multisession--key object)) + ".value") + multisession-directory)) + +(cl-defmethod multisession-backend-value ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (cond + ;; We have no value yet; see whether it's stored. + ((eq (multisession--cached-value object) multisession--unbound) + (if (file-exists-p file) + (multisession--read-file-value file object) + ;; Nope; return the initial value. + (multisession--initial-value object))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (if (and (file-exists-p file) + (time-less-p (multisession--cached-sequence object) + (file-attribute-modification-time + (file-attributes file)))) + (multisession--read-file-value file object) + ;; Nothing, return the cached value. + (multisession--cached-value object))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'files)) + object value) + (let ((file (multisession--object-file-name object)) + (time (current-time))) + ;; Ensure that the directory exists. + (let ((dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t))) + (with-temp-buffer + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (prin1 value (current-buffer))) + (goto-char (point-min)) + (condition-case nil + (read (current-buffer)) + (error (error "Unable to store unreadable value: %s" (buffer-string)))) + ;; Write to a temp file in the same directory and rename to the + ;; file for somewhat better atomicity. + (let ((coding-system-for-write 'utf-8) + (create-lockfiles nil) + (temp (make-temp-name file)) + (write-region-inhibit-fsync nil)) + (write-region (point-min) (point-max) temp nil 'silent) + (set-file-times temp time) + (rename-file temp file t))) + (setf (multisession--cached-sequence object) time + (multisession--cached-value object) value))) + +(cl-defmethod multisession--backend-values ((_type (eql 'files))) + (mapcar (lambda (file) + (let ((bits (file-name-split file))) + (list (url-unhex-string (car (last bits 2))) + (url-unhex-string + (file-name-sans-extension (car (last bits)))) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8)) + (insert-file-contents file) + (read (current-buffer))))))) + (directory-files-recursively + (expand-file-name "files" multisession-directory) + "\\.value\\'"))) + +(cl-defmethod multisession--backend-delete ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (when (file-exists-p file) + (delete-file file)))) + +;; Mode for editing. + +(defvar-keymap multisession-edit-mode-map + :parent tabulated-list-mode-map + "d" #'multisession-delete-value + "e" #'multisession-edit-value) + +(define-derived-mode multisession-edit-mode special-mode "Multisession" + "This mode lists all elements in the \"multisession\" database." + :interactive nil + (buffer-disable-undo) + (setq-local buffer-read-only t + truncate-lines t) + (setq tabulated-list-format + [("Package" 10) + ("Key" 30) + ("Value" 30)]) + (setq-local revert-buffer-function #'multisession-edit-mode--revert)) + +;;;###autoload +(defun list-multisession-values (&optional choose-storage) + "List all values in the \"multisession\" database. +If CHOOSE-STORAGE (interactively, the prefix), query for the +storage method to list." + (interactive "P") + (let ((storage + (if choose-storage + (intern (completing-read "Storage method: " '(sqlite files) nil t)) + multisession-storage))) + (pop-to-buffer (get-buffer-create (format "*Multisession %s*" storage))) + (multisession-edit-mode) + (setq-local multisession-storage storage) + (multisession-edit-mode--revert) + (goto-char (point-min)))) + +(defun multisession-edit-mode--revert (&rest _) + (let ((inhibit-read-only t) + (id (get-text-property (point) 'tabulated-list-id))) + (erase-buffer) + (tabulated-list-init-header) + (setq tabulated-list-entries + (mapcar (lambda (elem) + (list + (cons (car elem) (cadr elem)) + (vector (car elem) (cadr elem) + (string-replace "\n" "\\n" + (format "%s" (caddr elem)))))) + (multisession--backend-values multisession-storage))) + (tabulated-list-print t) + (goto-char (point-min)) + (when id + (when-let ((match + (text-property-search-forward 'tabulated-list-id id t))) + (goto-char (prop-match-beginning match)))))) + +(defun multisession-delete-value (id) + "Delete the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (unless (yes-or-no-p "Really delete this item? ") + (user-error "Not deleting")) + (multisession--backend-delete multisession-storage + (make-multisession :package (car id) + :key (cdr id))) + (let ((inhibit-read-only t)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))))) + +(defun multisession-edit-value (id) + "Edit the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (let* ((object (make-multisession + :package (car id) + :key (cdr id) + :storage multisession-storage)) + (value (multisession-value object))) + (setf (multisession-value object) + (car (read-from-string + (read-string "New value: " (prin1-to-string value)))))) + (multisession-edit-mode--revert)) + +(provide 'multisession) + +;;; multisession.el ends here |