The following is a modified version of
As the code in the first version of your question I don't write to a file but output the undo tree as a string. I hope that is okay.
The most important changes w.r.t.
- a recursive copy of the undo tree via
(copy-tree buffer-undo-tree t) to avoid effects on the original
- a deep recursion into the tree copy removing text properties on strings via
(:constructor copy-tree*-mem (&optional stack stack-new (hash (make-hash-table)))))
stack stack-new hash)
(defmacro copy-tree*--push (el el-new mem &optional hash)
(let ((my-el (make-symbol "my-el"))
(my-el-new (make-symbol "my-el-new"))) ; makes sure `el' is only evaluated once
(append `(let ((,my-el ,el)
(push ,my-el (copy-tree*-stack ,mem))
(push ,my-el-new (copy-tree*-stack-new ,mem)))
`((puthash ,my-el ,my-el-new (copy-tree*-hash ,mem))))
(defmacro copy-tree*--pop (el el-new mem)
`(setq ,el (pop (copy-tree*-stack ,mem))
,el-new (pop (copy-tree*-stack-new mem))))
(defun copy-tree*--copy-node (node mem vecp)
(if (or (consp node)
(and vecp (vectorp node)))
(let ((existing-node (gethash node (copy-tree*-hash mem))))
(copy-tree*--push node (if (consp node)
(cons nil nil)
(make-vector (length node) nil))
(defun copy-tree* (tree &optional vecp)
"Structure preserving version of `cl-copy-tree'."
(if (or (consp tree)
(and vecp (vectorp tree)))
(let* ((tree-new (if (consp tree) (cons nil nil)
(make-vector (length tree) nil)))
(copy-tree*--push tree tree-new mem t)
(while (copy-tree*--pop next next-new mem)
(setcar next-new (copy-tree*--copy-node (car next) mem vecp))
(setcdr next-new (copy-tree*--copy-node (cdr next) mem vecp)))
((and vecp (vectorp next))
(cl-loop for i from 0 below (length next) do
(aset next-new i (copy-tree*--copy-node (aref next i) mem vecp))))))
(defun undo-tree-seq-unprop (x)
"Remove text properties on all strings of seq."
(cons (undo-tree-seq-unprop (car x)) (undo-tree-seq-unprop (cdr x))))
(apply (type-of x) (seq-map (lambda (x) (undo-tree-seq-unprop x)) x)))
(defun undo-tree-string (&optional filename)
"Return undo-tree as a string.
If FILENAME is a string save this string in file with name FILENAME.
Ask for the file name in the interactive case."
(interactive "FFile name: ") ;; just to ease testing
(when (eq buffer-undo-list t)
(user-error "No undo information in this buffer"))
(when (and buffer-undo-tree (not (eq buffer-undo-tree t)))
(error (undo-tree-clear-visualizer-data buffer-undo-tree)))
(let ((buff (current-buffer))
;; transform undo-tree into non-circular structure, and make
;; temporary copy
(setq tree (copy-tree* buffer-undo-tree t))
;; discard undo-tree object pool before saving
(setf (undo-tree-object-pool tree) nil)
(undo-tree-mapc (lambda (node)
(setf (undo-tree-node-undo node) (undo-tree-seq-unprop (undo-tree-node-undo node)))
(setf (undo-tree-node-redo node) (undo-tree-seq-unprop (undo-tree-node-redo node)))
(prin1 (sha1 buff) (current-buffer))
(let ((print-circle t)) (prin1 tree (current-buffer)))
(setq return-string (buffer-string))
;; restore circular undo-tree data structure
- I added
copy-tree* as a structure-preserving version of
undo-tree-string should work but it is only tested for a few cases.
- User lawlist has detected an error with killing the visualizer. I just put in his solution to call
undo-tree-clear-visualizer-data buffer-undo-tree before
undo-tree-kill-visualizer. Hopefully, the code works much better now thanks to lawlist!