emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
blob 613290afcf536941e6ee05b408e69e13f23c72bd 16326 bytes (raw)
name: lisp/org-persist.el 	 # note: path name is non-authoritative(*)

  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
 
;;; org-persist.el --- Persist data across Emacs sessions         -*- lexical-binding: t; -*-

;; Copyright (C) 2021-2021 Free Software Foundation, Inc.

;; Author: Ihor Radchenko <yantar92 at gmail dot com>
;; Keywords: cache, storage

;; 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 file implements persistant data storage across Emacs sessions.
;; Both global and buffer-local data can be stored.

;;; Code:

(require 'org-compat)
(require 'org-id)
(require 'xdg nil t)

(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-next-visible-heading "org" (arg))
(declare-function org-at-heading-p "org" (&optional invisible-not-ok))


(defgroup org-persist nil
  "Persistent cache for Org mode."
  :tag "Org persist"
  :group 'org)

(defcustom org-persist-directory (expand-file-name
                       (org-file-name-concat
                        (let ((cache-dir (when (fboundp 'xdg-cache-home)
                                           (xdg-cache-home))))
                          (if (or (seq-empty-p cache-dir)
                                  (not (file-exists-p cache-dir))
                                  (file-exists-p (org-file-name-concat
                                                  user-emacs-directory
                                                  "org-persist")))
                              user-emacs-directory
                            cache-dir))
                        "org-persist/"))
  "Directory where the data is stored."
  :group 'org-persist
  :type 'directory)

(defcustom org-persist-remote-files 100
  "Whether to keep persistent data for remote files.

When this variable is nil, never save persitent data associated with
remote files.  When `t', always keep the data.  When
`check-existance', contact remote server containing the file and only
keep the data when the file exists on the server.

Note that the last option `check-existance' may cause Emacs to show
password prompts to log in."
  :group 'org-persist
  :type '(choice (const :tag "Never" nil)
                 (const :tag "Always" t)
                 (number :tag "Keep note more than X files")
                 (const :tag "Check if exist on remote" 'check-existence)))

(defvar org-persist-index-file "index"
  "File name used to store the data index.")

(defvar org-persist-before-write-hook nil
  "Abnormal hook ran before saving data for a single variable in a buffer.
The hook must accept the same arguments as `org-persist-write'.
The hooks will be evaluated until a hook returns non-nil.
If any of the hooks return non-nil, do not save the data.")

(defvar org-persist-before-read-hook nil
  "Abnormal hook ran before reading data for a single variable in a buffer.
The hook must accept the same arguments as `org-persist-read'.
The hooks will be evaluated until a hook returns non-nil.
If any of the hooks return non-nil, do not read the data.")

(defvar org-persist-after-read-hook nil
  "Abnormal hook ran after reading data for a single variable in a buffer.
The hook must accept the same arguments as `org-persist-read'.")

(defvar org-persist--index nil
  "Global index.

The index is a list of plists.  Each plist contains information about
a data variable.  Each plist contains the following properties:

  - `:variable'    list of variables to be stored in single file
  - `:persist-file': data file name
  - `:path':       buffer file path, if any
  - `:inode':      buffer file inode, if any
  - `:hash':       buffer hash, if any")

(defun org-persist--get-index (var &optional buffer)
  "Return plist used to store VAR in BUFFER.
When BUFFER is nil, return plist for global VAR."
  (org-persist--read-index)
  (let* ((buffer-file (when buffer (buffer-file-name (or (buffer-base-buffer buffer)
                                                         buffer))))
         (inode (when buffer-file (file-attribute-inode-number (file-attributes buffer-file))))
         (buffer-hash (when buffer (secure-hash 'md5 buffer))))
    (let ((result (seq-find (lambda (plist)
                              (and (or (memq var (plist-get plist :variable))
                                       (eq var (plist-get plist :variable)))
                                   (or (and inode (equal inode (plist-get plist :inode)))
                                       (and buffer-file (equal buffer-file (plist-get plist :path)))
                                       (and buffer-hash (equal buffer-hash (plist-get plist :hash))))))
                            org-persist--index)))
      (when result
        (unless (equal buffer-file (plist-get result :path))
          (setf result (plist-put result :path buffer-file))))
      (unless result
        (push (list :variable (if (listp var) var (list var))
                    :persist-file (replace-regexp-in-string "^.." "\\&/" (org-id-uuid))
                    :path buffer-file
                    :inode inode
                    :hash buffer-hash)
              org-persist--index)
        (setf result (car org-persist--index)))
      result)))

(defun org-persist--read-index ()
  "Read `org-persist--index'"
  (unless org-persist--index
    (when (file-exists-p (org-file-name-concat org-persist-directory org-persist-index-file))
      (with-temp-buffer
        (insert-file-contents (org-file-name-concat org-persist-directory org-persist-index-file))
        (setq org-persist--index
              (condition-case err
                  (read (current-buffer))
                ;; Recover gracefully if index file is corrupted.
                (error
                 (warn "Emacs reader failed to read data for `org-persist--index' from %S. The error was: %S"
                       (org-file-name-concat org-persist-directory org-persist-index-file)
                       (error-message-string err))
                 nil)))))))

(cl-defun org-persist-register (var &optional buffer &key inherit)
  "Register VAR in BUFFER to be persistent.
Optional key INHERIT make VAR dependent on another variable.  Such
dependency means that data shared between variables will be preserved
(see elisp#Circular Objects)."
  (unless org-persist--index (org-persist--read-index))
  (when inherit
    (let ((inherited-index (org-persist--get-index inherit buffer)))
      (unless (memq var (plist-get inherited-index :variable))
        (setq inherited-index
              (plist-put inherited-index :variable
                         (cons var (plist-get inherited-index :variable)))))))
  (org-persist--get-index var buffer)
  (when buffer
    (add-hook 'kill-buffer-hook #'org-persist-write-all-buffer nil 'local)))

(defun org-persist-unregister (var &optional buffer)
  "Unregister VAR in BUFFER to be persistent.
When BUFFER is `all', unregister VAR in all buffers."
  (unless org-persist--index (org-persist--read-index))
  (setq org-persist--index
        (seq-remove
         (lambda (plist)
           (when (and (memq var (plist-get plist :variable))
                      (or (eq buffer 'all)
                          (eq (buffer-file-name
                               (or (buffer-base-buffer buffer)
                                   buffer))
                              (plist-get plist :path))))
             (if (> (length (plist-get plist :variable)) 1)
                 (progn
                   (setq plist
                         (plist-put plist :variable
                                    (delq var (plist-get plist :variable))))
                   ;; Do not remove the index though.
                   nil)
               (let ((persist-file (org-file-name-concat org-persist-directory (plist-get plist :persist-file))))
                 (delete-file persist-file)
                 (when (org-directory-empty-p (file-name-directory persist-file))
                   (delete-directory (file-name-directory persist-file))))
               'delete-from-index)))
         org-persist--index))
  (org-persist-gc))

(defun org-persist-write (var &optional buffer)
  "Save buffer-local data in BUFFER for VAR."
  (unless (and buffer (not (get-buffer buffer)))
    (unless (listp var) (setq var (list var)))
    (with-current-buffer (or buffer (current-buffer))
      (let ((index (org-persist--get-index var buffer)))
        (setf index (plist-put index :hash (when buffer (secure-hash 'md5 buffer))))
        (let ((print-circle t)
              print-level
              print-length
              print-quoted
              (print-escape-control-characters t)
              (print-escape-nonascii t)
              (print-continuous-numbering t)
              print-number-table)
          (unless (seq-find (lambda (v)
                              (run-hook-with-args-until-success 'org-persist-before-write-hook v buffer))
                            (plist-get index :variable))
            (unless (file-exists-p org-persist-directory)
              (make-directory org-persist-directory))
            (unless (file-exists-p org-persist-directory)
              (warn "Failed to create org-persist storage in %s."
                    org-persist-directory)
              (let ((dir (directory-file-name
                          (file-name-as-directory org-persist-directory))))
                (while (and (not (file-exists-p dir))
                            (not (equal dir (setq dir (directory-file-name
                                                     (file-name-directory dir)))))))
                (unless (file-writable-p dir)
                  (message "Missing write access rights to org-persist-directory: %S"
                           org-persist-directory))))
            (when (file-exists-p org-persist-directory)
              (with-temp-file (org-file-name-concat org-persist-directory org-persist-index-file)
                (prin1 org-persist--index (current-buffer)))
              (let ((file (org-file-name-concat org-persist-directory (plist-get index :persist-file)))
                    (data (mapcar (lambda (s) (cons s (symbol-value s)))
                                  (plist-get index :variable))))
                (unless (file-exists-p (file-name-directory file))
                  (make-directory (file-name-directory file) t))
                (with-temp-file file
                  (prin1 data (current-buffer)))))))))))

(defun org-persist-write-all (&optional buffer)
  "Save all the persistent data."
  (unless (and buffer (not (buffer-file-name buffer)))
    (dolist (index org-persist--index)
      (when (or (and (not (plist-get index :path))
                     (not buffer))
                (and (plist-get index :path)
                     (get-file-buffer (plist-get index :path))
                     (equal (buffer-file-name
                             (or buffer
                                 (get-file-buffer (plist-get index :path))))
                            (plist-get index :path))))
        (org-persist-write (plist-get index :variable)
                (when (plist-get index :path)
                  (get-file-buffer (plist-get index :path))))))))

(defun org-persist-write-all-buffer ()
  "Call `org-persist-write-all' in current buffer."
  (org-persist-write-all (current-buffer)))

(defun org-persist-read (var &optional buffer)
  "Restore VAR data in BUFFER."
  (let* ((index (org-persist--get-index var buffer))
         (persist-file (org-file-name-concat org-persist-directory (plist-get index :persist-file)))
         (data nil))
    (when (and index
               (file-exists-p persist-file)
               (or (not buffer)
                   (equal (secure-hash 'md5 buffer) (plist-get index :hash))))
      (unless (seq-find (lambda (v)
                          (run-hook-with-args-until-success 'org-persist-before-read-hook v buffer))
                        (plist-get index :variable))
        (with-temp-buffer
          (let ((coding-system-for-read 'utf-8)
                (read-circle t))
            (insert-file-contents persist-file))
          ;; FIXME: Reading sometimes fails to read circular objects.
          ;; I suspect that it happens when we have object reference
          ;; #N# read before object definition #N=.  If it is really
          ;; so, it should be Emacs bug - either in `read' or in
          ;; `prin1'.  Meanwhile, just fail silently when `read'
          ;; fails to parse the saved cache object.
          (condition-case err
              (setq data (read (current-buffer)))
            (error
             ;; Do not report the known error to user.
             (unless (string-match-p "Invalid read syntax" (error-message-string err))
               (warn "Emacs reader failed to read data for %S:%S. The error was: %S"
                     (or buffer "global") var (error-message-string err)))
             (setq data nil))))
        (with-current-buffer (or buffer (current-buffer))
          (cl-loop for var1 in (plist-get index :variable)
                   do
                   (when (alist-get var1 data)
                     (setf (symbol-value var1) (alist-get var1 data)))
                   (run-hook-with-args 'org-persist-after-read-hook var1 buffer)))))))

(defun org-persist-read-all (&optional buffer)
  "Restore all the persistent data in BUFFER."
  (unless org-persist--index (org-persist--read-index))
  (dolist (index org-persist--index)
    (org-persist-read (plist-get index :variable) buffer)))

(defun org-persist-read-all-buffer ()
  "Call `org-persist-read-all' in current buffer."
  (org-persist-read-all (current-buffer)))

(defun org-persist-gc ()
  "Remove stored data for not existing files or unregistered variables."
  (let (new-index (remote-files-num 0))
    (dolist (index org-persist--index)
      (let* ((file (plist-get index :path))
             (file-remote (when file (file-remote-p file)))
             (persist-file (when (plist-get index :persist-file)
                             (org-file-name-concat
                              org-persist-directory
                              (plist-get index :persist-file)))))
        (when (and file persist-file)
          (when (and file-remote persist-file)
            (cl-incf remote-files-num))
          (if (if (not file-remote)
                  (file-exists-p file)
                (pcase org-persist-remote-files
                  ('t t)
                  ('check-existence
                   (file-exists-p file))
                  ((pred #'numberp)
                   (<= org-persist-remote-files remote-files-num))
                  (_ nil)))
              (push index new-index)
            (when (file-exists-p persist-file)
              (delete-file persist-file)
              (when (org-directory-empty-p (file-name-directory persist-file))
                (delete-directory (file-name-directory persist-file))))))))
    (setq org-persist--index (nreverse new-index))))

;; Automatically write the data, but only when we have write access.
(let ((dir (directory-file-name
            (file-name-as-directory org-persist-directory))))
  (while (and (not (file-exists-p dir))
              (not (equal dir (setq dir (directory-file-name
                                       (file-name-directory dir)))))))
  (if (not (file-writable-p dir))
      (message "Missing write access rights to org-persist-directory: %S"
               org-persist-directory)
    (add-hook 'kill-emacs-hook #'org-persist-write-all)
    ;; `org-persist-gc' should run before `org-persist-write-all'.  So we are adding the
    ;; hook after `org-persist-write-all'.
    (add-hook 'kill-emacs-hook #'org-persist-gc)))

(add-hook 'after-init-hook #'org-persist-read-all)

(provide 'org-persist)

;;; org-persist.el ends here

debug log:

solving 613290afc ...
found 613290afc in https://list.orgmode.org/orgmode/87y24i2dv1.fsf@localhost/
found 90f9a3bc9 in https://git.savannah.gnu.org/cgit/emacs/org-mode.git
preparing index
index prepared:
100644 90f9a3bc9bc1d0d8bee4b8cf9e80ef0d42b6b5b3	lisp/org-persist.el

applying [1/1] https://list.orgmode.org/orgmode/87y24i2dv1.fsf@localhost/
diff --git a/lisp/org-persist.el b/lisp/org-persist.el
index 90f9a3bc9..613290afc 100644

Checking patch lisp/org-persist.el...
Applied patch lisp/org-persist.el cleanly.

index at:
100644 613290afcf536941e6ee05b408e69e13f23c72bd	lisp/org-persist.el

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).