1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
|
;;; multisession.el --- Multisession storage for variables -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2025 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:
;; This library provides multisession variables for Emacs Lisp, to
;; make them persist between sessions.
;;
;; Use `define-multisession-variable' to define a multisession
;; variable, and `multisession-value' to read its value. Use
;; `list-multisession-values' to list multisession variables.
;;
;; Users might want to customize `multisession-storage' and
;; `multisession-directory'.
;;
;; See Info node `(elisp) Multisession Variables' for more
;; information.
;;; 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-commit "sqlite.c")
(declare-function sqlite-transaction "sqlite.c")
(declare-function sqlite-rollback "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))
(readablep value))))
(when (and value (not pvalue))
(error "Unable to store unreadable value: %s" value))
(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-emacs-unix))
(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. In addition,
;; rename-file is not an atomic operation on MS-Windows,
;; when the target file already exists, so there could be a
;; small race window when the file to read doesn't yet
;; exist. So when these problems happen, wait a bit and retry.
((permission-denied file-missing)
(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-emacs-unix)
(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-emacs-unix))
(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 (or
;; If the multisession variable already exists, use
;; it (so that we update it).
(if-let (sym (intern-soft (cdr id)))
(and (boundp sym) (symbol-value sym))
nil)
;; Create a new 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
|
