[elpa] externals/undo-tree 5da2a7aee9 1/9: Implement new undo-tree save format.

[Stefan Monnier]

branch: externals/undo-tree
commit 5da2a7aee98393d26a93c499dc79fcf793f161e1
Author: Toby S. Cubitt <toby-undo-tree@dr-qubit.org>
Commit: Toby S. Cubitt <toby-undo-tree@dr-qubit.org>

    Implement new undo-tree save format.
    
    Works around Emacs bug #27779: 
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27779
    
    New save format serialises the undo-tree, instead of directly writing out 
the
    Elisp object. This avoids triggering a stack overflow in the Emacs Lisp 
reader
    when loading large undo-tree history files, due to the Elisp reader not 
coping
    with deeply nested Elisp objects.
---
 undo-tree.el | 295 +++++++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 206 insertions(+), 89 deletions(-)

diff --git a/undo-tree.el b/undo-tree.el
index 6cd72f4dff..37deb15f9d 100644
--- a/undo-tree.el
+++ b/undo-tree.el
@@ -4,7 +4,7 @@
 
 ;; Author: Toby Cubitt <toby-undo-tree@dr-qubit.org>
 ;; Maintainer: Toby Cubitt <toby-undo-tree@dr-qubit.org>
-;; Version: 0.7.4
+;; Version: 0.8
 ;; Keywords: convenience, files, undo, redo, history, tree
 ;; URL: http://www.dr-qubit.org/emacs.php
 ;; Repository: http://www.dr-qubit.org/git/undo-tree.git
@@ -755,6 +755,7 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'queue)
 (require 'diff)
 (require 'gv)
 
@@ -939,7 +940,7 @@ within the current region."
   :type 'boolean)
 
 
-(defcustom undo-tree-auto-save-history nil
+(defcustom undo-tree-auto-save-history t
   "When non-nil, `undo-tree-mode' will save undo history to file
 when a buffer is saved to file.
 
@@ -1340,6 +1341,26 @@ in visualizer."
                   (timestamp (current-time))
                   (branch 0)))
    (:constructor undo-tree-make-empty-node ())
+   (:constructor undo-tree-copy-node-save-data
+                (node
+                 &aux
+                 (undo (let ((changeset (undo-tree-node-undo node)))
+                         (run-hook-wrapped
+                          'undo-tree-pre-save-element-functions
+                          (lambda (fun)
+                            (setq changeset (delq nil (mapcar fun changeset)))
+                            nil))
+                         changeset))
+                 (redo (let ((changeset (undo-tree-node-redo node)))
+                         (run-hook-wrapped
+                          'undo-tree-pre-save-element-functions
+                          (lambda (fun)
+                            (setq changeset (delq nil (mapcar fun changeset)))
+                            nil))
+                         changeset))
+                 (timestamp (undo-tree-node-timestamp node))
+                 (branch (undo-tree-node-branch node))
+                 (meta-data (undo-tree-node-meta-data node))))
    (:copier nil))
   previous next undo redo timestamp branch meta-data)
 
@@ -1349,7 +1370,7 @@ in visualizer."
     `(and (vectorp ,n) (= (length ,n) ,len))))
 
 (defun undo-tree-node-copy (node &optional tree current)
-  ;; Return a copy of undo-tree NODE, sans previous link or meta-data.
+  ;; Return a deep copy of undo-tree NODE, sans previous link or meta-data.
   ;; If TREE and CURRENT are supplied, set (undo-tree-current TREE) to the
   ;; copy of CURRENT node, if found.
   (let* ((new (undo-tree-make-empty-node))
@@ -3217,6 +3238,10 @@ Argument is a character, naming the register."
 ;;; =====================================================================
 ;;;                    Persistent storage commands
 
+(defvar undo-tree-save-format-version 1
+  "Undo-tree history file format version.")
+
+
 (defun undo-tree-make-history-save-file-name (file)
   "Create the undo history file name for FILE.
 Normally this is the file's name with \".\" prepended and
@@ -3231,6 +3256,111 @@ directory for the backup doesn't exist, it is created."
            ".~undo-tree~")))
 
 
+(defun undo-tree-serialize (tree)
+  "Serialise undo-tree TREE to current buffer."
+  ;; write root
+  (let ((data (undo-tree-copy-node-save-data (undo-tree-root tree))))
+    (when (eq (undo-tree-root tree) (undo-tree-current tree))
+      (setf (undo-tree-node-next data) 'current))
+    (prin1 data (current-buffer)))
+  (terpri (current-buffer))
+  ;; Note: We serialise in breadth-first order, as undo-trees are typically
+  ;;       much deeper than they are wide, so this is more memory-efficient.
+  (let ((queue (make-queue)))
+    (queue-enqueue queue (undo-tree-root tree))
+    (while (not (queue-empty queue))
+      (prin1 (mapcar
+             (lambda (n)
+               (queue-enqueue queue n)
+               (let ((data (undo-tree-copy-node-save-data n)))
+                 ;; use empty next field to mark current node
+                 (when (eq n (undo-tree-current tree))
+                   (setf (undo-tree-node-next data) 'current))
+                 data))
+             (undo-tree-node-next (queue-dequeue queue)))
+            (current-buffer))
+      (terpri (current-buffer)))))
+
+
+(defun undo-tree-deserialize ()
+  "Deserialize and return undo-tree from current buffer."
+  (let ((tree (make-undo-tree))
+       (queue (make-queue))
+       node)
+    ;; read root
+    (setf (undo-tree-root tree) (read (current-buffer)))
+    (queue-enqueue queue (undo-tree-root tree))
+    ;; reconstruct tree in breadth-first order
+    (while (not (queue-empty queue))
+      (setq node (queue-dequeue queue))
+      (when (eq (undo-tree-node-next node) 'current)
+       (setf (undo-tree-current tree) node))
+      (setf (undo-tree-node-next node) (read (current-buffer)))
+      (mapc (lambda (n) (queue-enqueue queue n))
+           (undo-tree-node-next node)))
+    ;; restore parent links
+    (undo-tree-recircle tree)
+    tree))
+
+
+(defun undo-tree-serialize-old-format (tree)
+  ;; make tmp copy of TREE
+  (setq tree (undo-tree-copy tree))
+  ;; decircle and discard object pool before saving
+  (undo-tree-decircle tree)
+  (setf (undo-tree-object-pool tree) nil)
+  ;; run pre-save transformer functions
+  (when undo-tree-pre-save-element-functions
+    (undo-tree-mapc
+     (lambda (node)
+       (let ((changeset (undo-tree-node-undo node)))
+        (run-hook-wrapped
+         'undo-tree-pre-save-element-functions
+         (lambda (fun)
+           (setq changeset (delq nil (mapcar fun changeset)))
+           nil))
+        (setf (undo-tree-node-undo node) changeset))
+       (let ((changeset (undo-tree-node-redo node)))
+        (run-hook-wrapped
+         'undo-tree-pre-save-element-functions
+         (lambda (fun)
+           (setq changeset (delq nil (mapcar fun changeset)))
+           nil))
+        (setf (undo-tree-node-redo node) changeset)))
+     (undo-tree-root tree)))
+  ;; write tree
+  (let ((print-circle t)) (prin1 tree (current-buffer))))
+
+
+(defun undo-tree-deserialize-old-format ()
+  ;; read tree
+  (let ((tree (read (current-buffer))))
+    ;; run post-load transformer functions
+    (when undo-tree-post-load-element-functions
+      (undo-tree-mapc
+       (lambda (node)
+        (let ((changeset (undo-tree-node-undo node)))
+          (run-hook-wrapped
+           'undo-tree-post-load-element-functions
+           (lambda (fun)
+             (setq changeset (delq nil (mapcar fun changeset)))))
+          (setf (undo-tree-node-undo node) changeset))
+        (let ((changeset (undo-tree-node-redo node)))
+          (run-hook-wrapped
+           'undo-tree-post-load-element-functions
+           (lambda (fun)
+             (setq changeset (delq nil (mapcar fun changeset)))))
+          (setf (undo-tree-node-redo node) changeset)))
+       (undo-tree-root tree)))
+    ;; initialise empty undo-tree object pool
+    (setf (undo-tree-object-pool tree)
+         (make-hash-table :test 'eq :weakness 'value))
+    ;; restore parent links
+    (undo-tree-recircle tree)
+    tree))
+
+
+
 (defun undo-tree-save-history (&optional filename overwrite)
   "Store undo-tree history to file.
 
@@ -3247,12 +3377,12 @@ without asking for confirmation."
     (user-error "No undo information in this buffer"))
   (undo-list-transfer-to-tree)
   (when (and buffer-undo-tree (not (eq buffer-undo-tree t)))
-    (undo-tree-kill-visualizer)
-    ;; should be cleared already by killing the visualizer, but writes
-    ;; unreasable data if not for some reason, so just in case...
-    (undo-tree-clear-visualizer-data buffer-undo-tree)
+    ;; (undo-tree-kill-visualizer)
+    ;; ;; should be cleared already by killing the visualizer, but writes
+    ;; ;; unreasable data if not for some reason, so just in case...
+    ;; (undo-tree-clear-visualizer-data buffer-undo-tree)
     (let ((buff (current-buffer))
-         tree)
+         (tree buffer-undo-tree))
       ;; get filename
       (unless filename
        (setq filename
@@ -3262,42 +3392,40 @@ without asking for confirmation."
       (when (or (not (file-exists-p filename))
                overwrite
                (yes-or-no-p (format "Overwrite \"%s\"? " filename)))
-       ;; transform undo-tree into non-circular structure, and make tmp copy
-       (setq tree (undo-tree-copy buffer-undo-tree))
-       (undo-tree-decircle tree)
-       ;; discard undo-tree object pool before saving
-       (setf (undo-tree-object-pool tree) nil)
-       ;; run pre-save transformer functions
-       (when undo-tree-pre-save-element-functions
-         (undo-tree-mapc
-          (lambda (node)
-            (let ((changeset (undo-tree-node-undo node)))
-              (run-hook-wrapped
-               'undo-tree-pre-save-element-functions
-               (lambda (fun)
-                 (setq changeset (delq nil (mapcar fun changeset)))))
-               (setf (undo-tree-node-undo node) changeset))
-            (let ((changeset (undo-tree-node-redo node)))
-              (run-hook-wrapped
-               'undo-tree-pre-save-element-functions
-               (lambda (fun)
-                 (setq changeset (delq nil (mapcar fun changeset)))))
-              (setf (undo-tree-node-redo node) changeset)))
-          (undo-tree-root tree)))
+
        ;; print undo-tree to file
-       ;; NOTE: We use `with-temp-buffer' instead of `with-temp-file' to
+       ;; Note: We use `with-temp-buffer' instead of `with-temp-file' to
        ;;       allow `auto-compression-mode' to take effect, in case user
        ;;       has overridden or advised the default
        ;;       `undo-tree-make-history-save-file-name' to add a compressed
        ;;       file extension.
-       (with-auto-compression-mode
-         (with-temp-buffer
-           (prin1 (sha1 buff) (current-buffer))
-           (terpri (current-buffer))
-           (let ((print-circle t)) (prin1 tree (current-buffer)))
+       (with-temp-buffer
+         ;; write version number; (original save file format (version 0) has 
no version string)
+         (unless (= undo-tree-save-format-version 0)
+           (prin1 (cons 'undo-tree-save-format-version 
undo-tree-save-format-version)
+                  (current-buffer))
+           (terpri (current-buffer)))
+         ;; write hash
+         (prin1 (sha1 buff) (current-buffer))
+         (terpri (current-buffer))
+         ;; write tree
+         (cl-case undo-tree-save-format-version
+           (0 (undo-tree-serialize-old-format tree))
+           (1 (undo-tree-serialize tree))
+           (t (error "Unknown `undo-tree-save-format-version'; undo-tree 
history *not* saved")))
+         ;; write file
+         (with-auto-compression-mode
            (write-region nil nil filename)))))))
 
 
+(defmacro undo-tree--catch-load-history-error (error-fmt &rest body)
+  `(condition-case nil
+       (progn ,@body)
+     (error
+      (kill-buffer nil)
+      (funcall (if noerror #'message #'user-error) ,error-fmt filename)
+      (throw 'load-error nil))))
+
 
 (defun undo-tree-load-history (&optional filename noerror)
   "Load undo-tree history from file, for the current buffer.
@@ -3320,65 +3448,54 @@ Note this will overwrite any existing undo history."
              (undo-tree-make-history-save-file-name buffer-file-name)
            (expand-file-name (read-file-name "File to load from: ") nil))))
 
-  ;; attempt to read undo-tree from FILENAME
+  ;; attempt to read undo-tree
   (catch 'load-error
     (unless (file-exists-p filename)
       (if noerror
          (throw 'load-error nil)
-       (error "File \"%s\" does not exist; could not load undo-tree history"
-              filename)))
-    (let (buff hash tree)
-      (setq buff (current-buffer))
-      (with-auto-compression-mode
+       (user-error "File \"%s\" does not exist; could not load undo-tree 
history"
+                   filename)))
+
+    ;; read file contents
+    (let ((buff (current-buffer))
+         version hash tree)
        (with-temp-buffer
-         (insert-file-contents filename)
+         (with-auto-compression-mode (insert-file-contents filename))
          (goto-char (point-min))
-         (condition-case nil
-             (setq hash (read (current-buffer)))
-           (error
-            (kill-buffer nil)
-            (funcall (if noerror #'message #'user-error)
-                     "Error reading undo-tree history from \"%s\"" filename)
-            (throw 'load-error nil)))
-         (unless (string= (sha1 buff) hash)
-           (kill-buffer nil)
-           (funcall (if noerror 'message 'user-error)
-                    "Buffer has been modified; could not load undo-tree 
history")
-           (throw 'load-error nil))
-         (condition-case nil
-             (setq tree (read (current-buffer)))
-           (error
-            (kill-buffer nil)
-            (funcall (if noerror #'message #'error)
-                     "Error reading undo-tree history from \"%s\"" filename)
-            (throw 'load-error nil)))
-         (kill-buffer nil)))
-       ;; run post-load transformer functions
-       (when undo-tree-post-load-element-functions
-         (undo-tree-mapc
-          (lambda (node)
-            (let ((changeset (undo-tree-node-undo node)))
-              (run-hook-wrapped
-               'undo-tree-post-load-element-functions
-               (lambda (fun)
-                 (setq changeset (delq nil (mapcar fun changeset)))))
-               (setf (undo-tree-node-undo node) changeset))
-            (let ((changeset (undo-tree-node-redo node)))
-              (run-hook-wrapped
-               'undo-tree-post-load-element-functions
-               (lambda (fun)
-                 (setq changeset (delq nil (mapcar fun changeset)))))
-              (setf (undo-tree-node-redo node) changeset)))
-          (undo-tree-root tree)))      ;; initialise empty undo-tree object 
pool
-      (setf (undo-tree-object-pool tree)
-           (make-hash-table :test 'eq :weakness 'value))
-      ;; restore circular undo-tree data structure
-      (undo-tree-recircle tree)
-      ;; create undo-tree object pool
-      (setf (undo-tree-object-pool tree)
-           (make-hash-table :test 'eq :weakness 'value))
-      (setq buffer-undo-tree tree
-           buffer-undo-list '(nil undo-tree-canary)))))
+
+         (undo-tree--catch-load-history-error
+          "Error reading undo-tree history from \"%s\""
+          ;; read version number
+          (setq version (read (current-buffer)))
+          ;; read hash
+          (cond
+           ((eq (car-safe version) 'undo-tree-save-format-version)
+            (setq version (cdr version))
+            (setq hash (read (current-buffer))))
+           ;; original save file format (version 0) has no version string
+           ((stringp version)
+            (setq hash version
+                  version 0))
+           (t (error "Error"))))
+
+         ;; check hash
+         (undo-tree--catch-load-history-error
+           "Buffer has been modified since undo-tree history was saved to
+         \"%s\"; could not load undo-tree history"
+           (unless (string= (sha1 buff) hash) (error "Error")))
+
+         ;; read tree
+         (undo-tree--catch-load-history-error
+          "Error reading undo-tree history from \"%s\""
+          (setq tree
+                (cl-case version
+                  (0 (undo-tree-deserialize-old-format))
+                  (1 (undo-tree-deserialize))
+                  (t (error "Error")))))
+         (kill-buffer nil))
+
+       (setq buffer-undo-tree tree
+             buffer-undo-list '(nil undo-tree-canary)))))