1 ;;; undo-tree.el --- Treat undo history as a tree
4 ;; Copyright (C) 2009-2012 Free Software Foundation, Inc
6 ;; Author: Toby Cubitt <toby-undo-tree@dr-qubit.org>
8 ;; Keywords: convenience, files, undo, redo, history, tree
9 ;; URL: http://www.dr-qubit.org/emacs.php
10 ;; Git Repository: http://www.dr-qubit.org/git/undo-tree.git
12 ;; This file is part of Emacs.
14 ;; This file is free software: you can redistribute it and/or modify it under
15 ;; the terms of the GNU General Public License as published by the Free
16 ;; Software Foundation, either version 3 of the License, or (at your option)
19 ;; This program is distributed in the hope that it will be useful, but WITHOUT
20 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
21 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
24 ;; You should have received a copy of the GNU General Public License along
25 ;; with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
30 ;; Emacs has a powerful undo system. Unlike the standard undo/redo system in
31 ;; most software, it allows you to recover *any* past state of a buffer
32 ;; (whereas the standard undo/redo system can lose past states as soon as you
33 ;; redo). However, this power comes at a price: many people find Emacs' undo
34 ;; system confusing and difficult to use, spawning a number of packages that
35 ;; replace it with the less powerful but more intuitive undo/redo system.
37 ;; Both the loss of data with standard undo/redo, and the confusion of Emacs'
38 ;; undo, stem from trying to treat undo history as a linear sequence of
39 ;; changes. It's not. The `undo-tree-mode' provided by this package replaces
40 ;; Emacs' undo system with a system that treats undo history as what it is: a
41 ;; branching tree of changes. This simple idea allows the more intuitive
42 ;; behaviour of the standard undo/redo system to be combined with the power of
43 ;; never losing any history. An added side bonus is that undo history can in
44 ;; some cases be stored more efficiently, allowing more changes to accumulate
45 ;; before Emacs starts discarding history.
47 ;; The only downside to this more advanced yet simpler undo system is that it
48 ;; was inspired by Vim. But, after all, most successful religions steal the
49 ;; best ideas from their competitors!
55 ;; This package has only been tested with Emacs versions 22, 23 and CVS. It
56 ;; will not work without modifications in earlier versions of Emacs.
58 ;; To install `undo-tree-mode', make sure this file is saved in a directory in
59 ;; your `load-path', and add the line:
61 ;; (require 'undo-tree)
63 ;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using
64 ;; "M-x byte-compile-file" from within emacs).
66 ;; If you want to replace the standard Emacs' undo system with the
67 ;; `undo-tree-mode' system in all buffers, you can enable it globally by
70 ;; (global-undo-tree-mode)
72 ;; to your .emacs file.
78 ;; If you're the kind of person who likes to jump in the car and drive,
79 ;; without bothering to first figure out whether the button on the left dips
80 ;; the headlights or operates the ejector seat (after all, you'll soon figure
81 ;; it out when you push it), then here's the minimum you need to know:
83 ;; `undo-tree-mode' and `global-undo-tree-mode'
84 ;; Enable undo-tree mode (either in the current buffer or globally).
86 ;; C-_ C-/ (`undo-tree-undo')
89 ;; M-_ C-? (`undo-tree-redo')
92 ;; `undo-tree-switch-branch'
93 ;; Switch undo-tree branch.
94 ;; (What does this mean? Better press the button and see!)
96 ;; C-x u (`undo-tree-visualize')
97 ;; Visualize the undo tree.
98 ;; (Better try pressing this button too!)
100 ;; C-x r u (`undo-tree-save-state-to-register')
101 ;; Save current buffer state to register.
103 ;; C-x r U (`undo-tree-restore-state-from-register')
104 ;; Restore buffer state from register.
107 ;; In the undo-tree visualizer:
109 ;; <up> p C-p (`undo-tree-visualize-undo')
112 ;; <down> n C-n (`undo-tree-visualize-redo')
115 ;; <left> b C-b (`undo-tree-visualize-switch-branch-left')
116 ;; Switch to previous undo-tree branch.
118 ;; <right> f C-f (`undo-tree-visualize-switch-branch-right')
119 ;; Switch to next undo-tree branch.
121 ;; t (`undo-tree-visualizer-toggle-timestamps')
122 ;; Toggle display of time-stamps.
124 ;; q C-q (`undo-tree-visualizer-quit')
125 ;; Quit undo-tree-visualizer.
144 ;; To understand the different undo systems, it's easiest to consider an
145 ;; example. Imagine you make a few edits in a buffer. As you edit, you
146 ;; accumulate a history of changes, which we might visualize as a string of
147 ;; past buffer states, growing downwards:
149 ;; o (initial buffer state)
158 ;; x (current buffer state)
161 ;; Now imagine that you undo the last two changes. We can visualize this as
162 ;; rewinding the current state back two steps:
164 ;; o (initial buffer state)
167 ;; x (current buffer state)
176 ;; However, this isn't a good representation of what Emacs' undo system
177 ;; does. Instead, it treats the undos as *new* changes to the buffer, and adds
178 ;; them to the history:
180 ;; o (initial buffer state)
189 ;; x (buffer state before undo)
198 ;; Actually, since the buffer returns to a previous state after an undo,
199 ;; perhaps a better way to visualize it is to imagine the string of changes
200 ;; turning back on itself:
202 ;; (initial buffer state) o
205 ;; (first edit) o x (second undo)
208 ;; (second edit) o o (first undo)
211 ;; o (buffer state before undo)
213 ;; Treating undos as new changes might seem a strange thing to do. But the
214 ;; advantage becomes clear as soon as we imagine what happens when you edit
215 ;; the buffer again. Since you've undone a couple of changes, new edits will
216 ;; branch off from the buffer state that you've rewound to. Conceptually, it
219 ;; o (initial buffer state)
230 ;; The standard undo/redo system only lets you go backwards and forwards
231 ;; linearly. So as soon as you make that new edit, it discards the old
232 ;; branch. Emacs' undo just keeps adding changes to the end of the string. So
233 ;; the undo history in the two systems now looks like this:
235 ;; Undo/Redo: Emacs' undo
243 ;; . x (new edit) o o |
244 ;; (discarded . | / |
251 ;; Now, what if you change your mind about those undos, and decide you did
252 ;; like those other changes you'd made after all? With the standard undo/redo
253 ;; system, you're lost. There's no way to recover them, because that branch
254 ;; was discarded when you made the new edit.
256 ;; However, in Emacs' undo system, those old buffer states are still there in
257 ;; the undo history. You just have to rewind back through the new edit, and
258 ;; back through the changes made by the undos, until you reach them. Of
259 ;; course, since Emacs treats undos (even undos of undos!) as new changes,
260 ;; you're really weaving backwards and forwards through the history, all the
261 ;; time adding new changes to the end of the string as you go:
266 ;; o o o (undo new edit)
269 ;; o o | | o (undo the undo)
272 ;; (trying to get o | | x (undo the undo)
273 ;; to this state) | /
277 ;; So far, this is still reasonably intuitive to use. It doesn't behave so
278 ;; differently to standard undo/redo, except that by going back far enough you
279 ;; can access changes that would be lost in standard undo/redo.
281 ;; However, imagine that after undoing as just described, you decide you
282 ;; actually want to rewind right back to the initial state. If you're lucky,
283 ;; and haven't invoked any command since the last undo, you can just keep on
284 ;; undoing until you get back to the start:
286 ;; (trying to get o x (got there!)
287 ;; to this state) | |
289 ;; o o o o (keep undoing)
292 ;; o o | | o o (keep undoing)
295 ;; (already undid o | | o (got this far)
296 ;; to this state) | /
300 ;; But if you're unlucky, and you happen to have moved the point (say) after
301 ;; getting to the state labelled "got this far", then you've "broken the undo
302 ;; chain". Hold on to something solid, because things are about to get
303 ;; hairy. If you try to undo now, Emacs thinks you're trying to undo the
304 ;; undos! So to get back to the initial state you now have to rewind through
305 ;; *all* the changes, including the undos you just did:
307 ;; (trying to get o x (finally got there!)
308 ;; to this state) | |
312 ;; | | \ | \ | \ | \ |
313 ;; o o | | o o o | o o
314 ;; | / | | | / | | | /
316 ;; (already undid o | | o<. | | o
317 ;; to this state) | / : | /
321 ;; (got this far, but
322 ;; broke the undo chain)
326 ;; In practice you can just hold down the undo key until you reach the buffer
327 ;; state that you want. But whatever you do, don't move around in the buffer
328 ;; to *check* that you've got back to where you want! Because you'll break the
329 ;; undo chain, and then you'll have to traverse the entire string of undos
330 ;; again, just to get back to the point at which you broke the
331 ;; chain. Undo-in-region and commands such as `undo-only' help to make using
332 ;; Emacs' undo a little easier, but nonetheless it remains confusing for many
336 ;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent
337 ;; the history we've been discussing (make a few edits, undo a couple of them,
338 ;; and edit again)? The diagram that conceptually represented our undo
339 ;; history, before we started discussing specific undo systems? It looked like
342 ;; o (initial buffer state)
348 ;; o x (current state)
353 ;; Well, that's *exactly* what the undo history looks like to
354 ;; `undo-tree-mode'. It doesn't discard the old branch (as standard undo/redo
355 ;; does), nor does it treat undos as new changes to be added to the end of a
356 ;; linear string of buffer states (as Emacs' undo does). It just keeps track
357 ;; of the tree of branching changes that make up the entire undo history.
359 ;; If you undo from this point, you'll rewind back up the tree to the previous
373 ;; If you were to undo again, you'd rewind back to the initial state. If on
374 ;; the other hand you redo the change, you'll end up back at the bottom of the
375 ;; most recent branch:
377 ;; o (undo takes you here)
383 ;; o x (redo takes you here)
388 ;; So far, this is just like the standard undo/redo system. But what if you
389 ;; want to return to a buffer state located on a previous branch of the
390 ;; history? Since `undo-tree-mode' keeps the entire history, you simply need
391 ;; to tell it to switch to a different branch, and then redo the changes you
397 ;; o (start here, but switch
398 ;; |\ to the other branch)
405 ;; Now you're on the other branch, if you undo and redo changes you'll stay on
406 ;; that branch, moving up and down through the buffer states located on that
407 ;; branch. Until you decide to switch branches again, of course.
409 ;; Real undo trees might have multiple branches and sub-branches:
422 ;; Trying to imagine what Emacs' undo would do as you move about such a tree
423 ;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're
424 ;; just moving around this undo history tree. Most of the time, you'll
425 ;; probably only need to stay on the most recent branch, in which case it
426 ;; behaves like standard undo/redo, and is just as simple to understand. But
427 ;; if you ever need to recover a buffer state on a different branch, the
428 ;; possibility of switching between branches and accessing the full undo
429 ;; history is still there.
433 ;; The Undo-Tree Visualizer
434 ;; ========================
436 ;; Actually, it gets better. You don't have to imagine all these tree
437 ;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which
438 ;; draws them for you! In fact, it draws even better diagrams: it highlights
439 ;; the node representing the current buffer state, it highlights the current
440 ;; branch, and (by hitting "t") you can toggle the display of
441 ;; time-stamps. (There's one other tiny difference: the visualizer puts the
442 ;; most recent branch on the left rather than the right.)
444 ;; In the visualizer, the usual keys for moving up and down a buffer instead
445 ;; move up and down the undo history tree (e.g. the up and down arrow keys, or
446 ;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo
447 ;; history you are visualizing) is updated as you move around the undo tree in
448 ;; the visualizer. If you reach a branch point in the visualizer, the usual
449 ;; keys for moving forward and backward in a buffer instead switch branch
450 ;; (e.g. the left and right arrow keys, or "C-f" and "C-b"). And clicking with
451 ;; the mouse on any node in the visualizer will take you directly to that
452 ;; node, resetting the state of the parent buffer to the state represented by
455 ;; It can be useful to see how long ago the parent buffer was in the state
456 ;; represented by a particular node in the visualizer. Hitting "t" in the
457 ;; visualizer toggles the display of time-stamps for all the nodes. (Note
458 ;; that, because of the way `undo-tree-mode' works, these time-stamps may be
459 ;; somewhat later than the true times, especially if it's been a long time
460 ;; since you last undid any changes.)
462 ;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in
463 ;; whatever state you ended at.
470 ;; Emacs allows a very useful and powerful method of undoing only selected
471 ;; changes: when a region is active, only changes that affect the text within
472 ;; that region will be undone. With the standard Emacs undo system, changes
473 ;; produced by undoing-in-region naturally get added onto the end of the
474 ;; linear undo history:
478 ;; | x (second undo-in-region)
481 ;; | o (first undo-in-region)
487 ;; You can of course redo these undos-in-region as usual, by undoing the
495 ;; | o o (undo the undo-in-region)
499 ;; o x (undo the undo-in-region)
502 ;; In `undo-tree-mode', undo-in-region works similarly: when there's an active
503 ;; region, undoing only undoes changes that affect that region. However, the
504 ;; way these undos-in-region are recorded in the undo history is quite
505 ;; different. In `undo-tree-mode', undo-in-region creates a new branch in the
506 ;; undo history. The new branch consists of an undo step that undoes some of
507 ;; the changes that affect the current region, and another step that undoes
508 ;; the remaining changes needed to rejoin the previous undo history.
510 ;; Previous undo history Undo-in-region
518 ;; o o x (undo-in-region)
523 ;; As long as you don't change the active region after undoing-in-region,
524 ;; continuing to undo-in-region extends the new branch, pulling more changes
525 ;; that affect the current region into an undo step immediately above your
526 ;; current location in the undo tree, and pushing the point at which the new
527 ;; branch is attached further up the tree:
529 ;; First undo-in-region Second undo-in-region
534 ;; o o x (undo-in-region)
542 ;; Redoing takes you back down the undo tree, as usual (as long as you haven't
543 ;; changed the active region after undoing-in-region, it doesn't matter if it
558 ;; What about redo-in-region? Obviously, this only makes sense if you have
559 ;; already undone some changes, so that there are some changes to redo!
560 ;; Redoing-in-region splits off a new branch of the undo history below your
561 ;; current location in the undo tree. This time, the new branch consists of a
562 ;; redo step that redoes some of the redo changes that affect the current
563 ;; region, followed by all the remaining redo changes.
565 ;; Previous undo history Redo-in-region
573 ;; o o x (redo-in-region)
578 ;; As long as you don't change the active region after redoing-in-region,
579 ;; continuing to redo-in-region extends the new branch, pulling more redo
580 ;; changes into a redo step immediately below your current location in the
583 ;; First redo-in-region Second redo-in-region
591 ;; o x (redo-in-region) o o
594 ;; o o o x (redo-in-region)
599 ;; Note that undo-in-region and redo-in-region only ever add new changes to
600 ;; the undo tree, they *never* modify existing undo history. So you can always
601 ;; return to previous buffer states by switching to a previous branch of the
609 ;; * set `permanent-local' property on `buffer-undo-tree', to prevent history
610 ;; being discarded when switching major-mode
611 ;; * added `undo-tree-enable-undo-in-region' customization option to allow
612 ;; undo-in-region to be disabled.
613 ;; * fixed bug in `undo-list-pop-changeset' which, through a subtle chain of
614 ;; consequences, occasionally caused undo-tree-mode to lose large amounts of
615 ;; undo history (thanks to Magnar Sveen for his sterling efforts in helping
619 ;; * added `term-mode' to `undo-tree-incompatible-major-modes'
622 ;; * added additional check in `undo-list-GCd-marker-elt-p' to guard against
623 ;; undo elements being mis-identified as marker elements
624 ;; * fixed bug in `undo-list-transfer-to-tree'
627 ;; * use `get-buffer-create' when creating the visualizer buffer in
628 ;; `undo-tree-visualize', to fix bug caused by `global-undo-tree-mode' being
629 ;; enabled in the visualizer when `default-major-mode' is set to something
630 ;; other than `fundamental-mode' (thanks to Michael Heerdegen for suggesting
632 ;; * modified `turn-on-undo-tree-mode' to avoid turning on `undo-tree-mode' if
633 ;; the buffer's `major-mode' implements its own undo system, by checking
634 ;; whether `undo' is remapped, the default "C-/" or "C-_" bindings have been
635 ;; overridden, or the `major-mode' is listed in
636 ;; `undo-tree-incompatible-major-modes'
637 ;; * discard position entries from `buffer-undo-list' changesets created by
638 ;; undoing or redoing, to ensure point is always moved to where the change
639 ;; is (standard Emacs `undo' also does this)
640 ;; * fixed `undo-tree-draw-node' to use correct faces and indicate registers
641 ;; when displaying timestamps in visualizer
644 ;; * implemented undo-in-region
645 ;; * fixed bugs in `undo-list-transfer-to-tree' and
646 ;; `undo-list-rebuild-from-tree' which caused errors when undo history was
648 ;; * defun `region-active-p' if not already defined, for compatibility with
652 ;; * modified `undo-tree-node' defstruct and macros to allow arbitrary
653 ;; meta-data to be stored in a plist associated with a node, and
654 ;; reimplemented storage of visualizer data on top of this
655 ;; * display registers storing undo-tree state in visualizer
656 ;; * implemented keyboard selection in visualizer
657 ;; * rebuild `buffer-undo-list' from tree when disabling `undo-tree-mode'
660 ;; * added support for marker undo entries
663 ;; * pass null argument to `kill-buffer' call in `undo-tree-visualizer-quit',
664 ;; since the argument's not optional in earlier Emacs versions
665 ;; * added match for "No further redo information" to
666 ;; `debug-ignored-errors' to prevent debugger being called on this error
667 ;; * made `undo-tree-visualizer-quit' select the window displaying the
668 ;; visualizer's parent buffer, or switch to the parent buffer if no window
670 ;; * fixed bug in `undo-tree-switch-branch'
671 ;; * general code tidying and reorganisation
672 ;; * fixed bugs in history-discarding logic
673 ;; * fixed bug in `undo-tree-insert' triggered by `undo-tree-visualizer-set'
674 ;; by ensuring mark is deactivated
677 ;; * added `undo-tree-mode-lighter' customization option to allow the
678 ;; mode-line lighter to be changed
679 ;; * bug-fix in `undo-tree-discard-node'
680 ;; * added `undo-tree-save-state-to-register' and
681 ;; `undo-tree-restore-state-from-register' commands and keybindings for
682 ;; saving/restoring undo-tree states using registers
685 ;; * modified `undo-tree-visualize' to mark the visualizer window as
686 ;; soft-dedicated, and changed `undo-tree-visualizer-quit' to use
687 ;; `kill-buffer', so that the visualizer window is deleted along with its
688 ;; buffer if the visualizer buffer was displayed in a new window, but not if
689 ;; it was displayed in an existing window.
692 ;; * modified `undo-tree-undo' and `undo-tree-redo' to always replace
693 ;; redo/undo entries with new ones generated by `primitive-undo', as the new
694 ;; changesets will restore the point more reliably
697 ;; * fixed `undo-tree-visualizer-quit' to remove `after-change-functions'
698 ;; hook there, rather than in `undo-tree-kill-visualizer'
701 ;; * fixed keybindings
702 ;; * renamed `undo-tree-visualizer-switch-previous-branch' and
703 ;; `undo-tree-visualizer-switch-next-branch' to
704 ;; `undo-tree-visualizer-switch-branch-left' and
705 ;; `undo-tree-visualizer-switch-branch-right'
708 ;; * prevented `undo-tree-kill-visualizer' from killing visualizer when
709 ;; undoing/redoing from the visualizer, which completely broke the
711 ;; * changed one redo binding, so that at least one set of undo/redo bindings
712 ;; works in a terminal
713 ;; * bound vertical scrolling commands in `undo-tree-visualizer-map', in case
714 ;; they aren't bound globally
715 ;; * added missing :group argument to `defface's
724 (eval-when-compile (require 'cl))
726 ;; `characterp' isn't defined in Emacs versions <= 22
727 (unless (fboundp 'characterp)
728 (defalias 'characterp 'char-valid-p))
730 ;; `region-active-p' isn't defined in Emacs versions <= 22
731 (unless (fboundp 'region-active-p)
732 (defun region-active-p () (and transient-mark-mode mark-active)))
736 ;;; =====================================================================
737 ;;; Global variables and customization options
739 (defvar buffer-undo-tree nil
740 "Tree of undo entries in current buffer.")
741 (make-variable-buffer-local 'buffer-undo-tree)
742 (put 'buffer-undo-tree 'permanent-local t)
745 (defgroup undo-tree nil
749 (defcustom undo-tree-mode-lighter " Undo-Tree"
750 "Lighter displayed in mode line
751 when `undo-tree-mode' is enabled."
755 (defcustom undo-tree-enable-undo-in-region t
756 "When non-nil, enable undo-in-region.
758 When undo-in-region is enabled, undoing or redoing when the
759 region is active (in `transient-mark-mode') or with a prefix
760 argument (not in `transient-mark-mode') only undoes changes
761 within the current region."
765 (defcustom undo-tree-incompatible-major-modes '(term-mode)
766 "List of major-modes in which `undo-tree-mode' should not be enabled.
767 \(See `turn-on-undo-tree-mode'.\)"
769 :type '(repeat symbol))
771 (defcustom undo-tree-visualizer-spacing 3
772 "Horizontal spacing in undo-tree visualization.
773 Must be a postivie odd integer."
776 :match (lambda (w n) (and (integerp n) (> n 0) (= (mod n 2) 1)))))
777 (make-variable-buffer-local 'undo-tree-visualizer-spacing)
779 (defvar undo-tree-map nil
780 "Keymap used in undo-tree-mode.")
783 (defface undo-tree-visualizer-default-face
784 '((((class color)) :foreground "gray"))
785 "*Face used to draw undo-tree in visualizer."
788 (defface undo-tree-visualizer-current-face
789 '((((class color)) :foreground "red"))
790 "*Face used to highlight current undo-tree node in visualizer."
793 (defface undo-tree-visualizer-active-branch-face
794 '((((class color) (background dark))
795 (:foreground "white" :weight bold))
796 (((class color) (background light))
797 (:foreground "black" :weight bold)))
798 "*Face used to highlight active undo-tree branch
802 (defface undo-tree-visualizer-register-face
803 '((((class color)) :foreground "yellow"))
804 "*Face used to highlight undo-tree nodes saved to a register
808 (defvar undo-tree-visualizer-map nil
809 "Keymap used in undo-tree visualizer.")
811 (defvar undo-tree-visualizer-selection-map nil
812 "Keymap used in undo-tree visualizer selection mode.")
815 (defvar undo-tree-visualizer-parent-buffer nil
816 "Parent buffer in visualizer.")
817 (make-variable-buffer-local 'undo-tree-visualizer-parent-buffer)
819 (defvar undo-tree-visualizer-timestamps nil
820 "Non-nil when visualizer is displaying time-stamps.")
821 (make-variable-buffer-local 'undo-tree-visualizer-timestamps)
823 (defconst undo-tree-visualizer-buffer-name " *undo-tree*")
825 ;; prevent debugger being called on "No further redo information"
826 (add-to-list 'debug-ignored-errors "^No further redo information")
831 ;;; =================================================================
832 ;;; Setup default keymaps
834 (unless undo-tree-map
835 (setq undo-tree-map (make-sparse-keymap))
836 ;; remap `undo' and `undo-only' to `undo-tree-undo'
837 (define-key undo-tree-map [remap undo] 'undo-tree-undo)
838 (define-key undo-tree-map [remap undo-only] 'undo-tree-undo)
839 ;; bind standard undo bindings (since these match redo counterparts)
840 (define-key undo-tree-map (kbd "C-/") 'undo-tree-undo)
841 (define-key undo-tree-map "\C-_" 'undo-tree-undo)
842 ;; redo doesn't exist normally, so define our own keybindings
843 (define-key undo-tree-map (kbd "C-?") 'undo-tree-redo)
844 (define-key undo-tree-map (kbd "M-_") 'undo-tree-redo)
845 ;; just in case something has defined `redo'...
846 (define-key undo-tree-map [remap redo] 'undo-tree-redo)
847 ;; we use "C-x u" for the undo-tree visualizer
848 (define-key undo-tree-map (kbd "\C-x u") 'undo-tree-visualize)
849 ;; bind register commands
850 (define-key undo-tree-map (kbd "C-x r u")
851 'undo-tree-save-state-to-register)
852 (define-key undo-tree-map (kbd "C-x r U")
853 'undo-tree-restore-state-from-register))
856 (unless undo-tree-visualizer-map
857 (setq undo-tree-visualizer-map (make-keymap))
858 ;; vertical motion keys undo/redo
859 (define-key undo-tree-visualizer-map [remap previous-line]
860 'undo-tree-visualize-undo)
861 (define-key undo-tree-visualizer-map [remap next-line]
862 'undo-tree-visualize-redo)
863 (define-key undo-tree-visualizer-map [up]
864 'undo-tree-visualize-undo)
865 (define-key undo-tree-visualizer-map "p"
866 'undo-tree-visualize-undo)
867 (define-key undo-tree-visualizer-map "\C-p"
868 'undo-tree-visualize-undo)
869 (define-key undo-tree-visualizer-map [down]
870 'undo-tree-visualize-redo)
871 (define-key undo-tree-visualizer-map "n"
872 'undo-tree-visualize-redo)
873 (define-key undo-tree-visualizer-map "\C-n"
874 'undo-tree-visualize-redo)
875 ;; horizontal motion keys switch branch
876 (define-key undo-tree-visualizer-map [remap forward-char]
877 'undo-tree-visualize-switch-branch-right)
878 (define-key undo-tree-visualizer-map [remap backward-char]
879 'undo-tree-visualize-switch-branch-left)
880 (define-key undo-tree-visualizer-map [right]
881 'undo-tree-visualize-switch-branch-right)
882 (define-key undo-tree-visualizer-map "f"
883 'undo-tree-visualize-switch-branch-right)
884 (define-key undo-tree-visualizer-map "\C-f"
885 'undo-tree-visualize-switch-branch-right)
886 (define-key undo-tree-visualizer-map [left]
887 'undo-tree-visualize-switch-branch-left)
888 (define-key undo-tree-visualizer-map "b"
889 'undo-tree-visualize-switch-branch-left)
890 (define-key undo-tree-visualizer-map "\C-b"
891 'undo-tree-visualize-switch-branch-left)
892 ;; mouse sets buffer state to node at click
893 (define-key undo-tree-visualizer-map [mouse-1]
894 'undo-tree-visualizer-mouse-set)
896 (define-key undo-tree-visualizer-map "t"
897 'undo-tree-visualizer-toggle-timestamps)
899 (define-key undo-tree-visualizer-map "s"
900 'undo-tree-visualizer-selection-mode)
901 ;; horizontal scrolling may be needed if the tree is very wide
902 (define-key undo-tree-visualizer-map ","
903 'undo-tree-visualizer-scroll-left)
904 (define-key undo-tree-visualizer-map "."
905 'undo-tree-visualizer-scroll-right)
906 (define-key undo-tree-visualizer-map "<"
907 'undo-tree-visualizer-scroll-left)
908 (define-key undo-tree-visualizer-map ">"
909 'undo-tree-visualizer-scroll-right)
910 ;; vertical scrolling may be needed if the tree is very tall
911 (define-key undo-tree-visualizer-map [next] 'scroll-up)
912 (define-key undo-tree-visualizer-map [prior] 'scroll-down)
914 (define-key undo-tree-visualizer-map "q"
915 'undo-tree-visualizer-quit)
916 (define-key undo-tree-visualizer-map "\C-q"
917 'undo-tree-visualizer-quit))
920 (unless undo-tree-visualizer-selection-map
921 (setq undo-tree-visualizer-selection-map (make-keymap))
922 ;; vertical motion keys move up and down tree
923 (define-key undo-tree-visualizer-selection-map [remap previous-line]
924 'undo-tree-visualizer-select-previous)
925 (define-key undo-tree-visualizer-selection-map [remap next-line]
926 'undo-tree-visualizer-select-next)
927 (define-key undo-tree-visualizer-selection-map [up]
928 'undo-tree-visualizer-select-previous)
929 (define-key undo-tree-visualizer-selection-map "p"
930 'undo-tree-visualizer-select-previous)
931 (define-key undo-tree-visualizer-selection-map "\C-p"
932 'undo-tree-visualizer-select-previous)
933 (define-key undo-tree-visualizer-selection-map [down]
934 'undo-tree-visualizer-select-next)
935 (define-key undo-tree-visualizer-selection-map "n"
936 'undo-tree-visualizer-select-next)
937 (define-key undo-tree-visualizer-selection-map "\C-n"
938 'undo-tree-visualizer-select-next)
939 ;; vertical scroll keys move up and down quickly
940 (define-key undo-tree-visualizer-selection-map [next]
941 (lambda () (interactive) (undo-tree-visualizer-select-next 10)))
942 (define-key undo-tree-visualizer-selection-map [prior]
943 (lambda () (interactive) (undo-tree-visualizer-select-previous 10)))
944 ;; horizontal motion keys move to left and right siblings
945 (define-key undo-tree-visualizer-selection-map [remap forward-char]
946 'undo-tree-visualizer-select-right)
947 (define-key undo-tree-visualizer-selection-map [remap backward-char]
948 'undo-tree-visualizer-select-left)
949 (define-key undo-tree-visualizer-selection-map [right]
950 'undo-tree-visualizer-select-right)
951 (define-key undo-tree-visualizer-selection-map "f"
952 'undo-tree-visualizer-select-right)
953 (define-key undo-tree-visualizer-selection-map "\C-f"
954 'undo-tree-visualizer-select-right)
955 (define-key undo-tree-visualizer-selection-map [left]
956 'undo-tree-visualizer-select-left)
957 (define-key undo-tree-visualizer-selection-map "b"
958 'undo-tree-visualizer-select-left)
959 (define-key undo-tree-visualizer-selection-map "\C-b"
960 'undo-tree-visualizer-select-left)
961 ;; horizontal scroll keys move left or right quickly
962 (define-key undo-tree-visualizer-selection-map ","
963 (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
964 (define-key undo-tree-visualizer-selection-map "."
965 (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
966 (define-key undo-tree-visualizer-selection-map "<"
967 (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
968 (define-key undo-tree-visualizer-selection-map ">"
969 (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
970 ;; mouse or <enter> sets buffer state to node at point/click
971 (define-key undo-tree-visualizer-selection-map "\r"
972 'undo-tree-visualizer-set)
973 (define-key undo-tree-visualizer-selection-map [mouse-1]
974 'undo-tree-visualizer-mouse-set)
976 (define-key undo-tree-visualizer-selection-map "t"
977 'undo-tree-visualizer-toggle-timestamps)
978 ;; quit visualizer selection mode
979 (define-key undo-tree-visualizer-selection-map "s"
980 'undo-tree-visualizer-mode)
982 (define-key undo-tree-visualizer-selection-map "q"
983 'undo-tree-visualizer-quit)
984 (define-key undo-tree-visualizer-selection-map "\C-q"
985 'undo-tree-visualizer-quit))
990 ;;; =====================================================================
991 ;;; Undo-tree data structure
997 (:constructor make-undo-tree
999 (root (make-undo-tree-node nil nil))
1002 (object-pool (make-hash-table :test 'eq :weakness 'value))))
1004 root current size object-pool)
1010 (:type vector) ; create unnamed struct
1012 (:constructor make-undo-tree-node
1016 (timestamp (current-time))
1018 (:constructor make-undo-tree-node-backwards
1022 (next (list next-node))
1023 (timestamp (current-time))
1026 previous next undo redo timestamp branch meta-data)
1029 (defmacro undo-tree-node-p (n)
1030 (let ((len (length (make-undo-tree-node nil nil))))
1031 `(and (vectorp ,n) (= (length ,n) ,len))))
1036 (undo-tree-region-data
1037 (:type vector) ; create unnamed struct
1039 (:constructor make-undo-tree-region-data
1040 (&optional undo-beginning undo-end
1041 redo-beginning redo-end))
1042 (:constructor make-undo-tree-undo-region-data
1043 (undo-beginning undo-end))
1044 (:constructor make-undo-tree-redo-region-data
1045 (redo-beginning redo-end))
1047 undo-beginning undo-end redo-beginning redo-end)
1050 (defmacro undo-tree-region-data-p (r)
1051 (let ((len (length (make-undo-tree-region-data))))
1052 `(and (vectorp ,r) (= (length ,r) ,len))))
1054 (defmacro undo-tree-node-clear-region-data (node)
1055 `(setf (undo-tree-node-meta-data ,node)
1058 (plist-put (undo-tree-node-meta-data ,node)
1062 (defmacro undo-tree-node-undo-beginning (node)
1063 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1064 (when (undo-tree-region-data-p r)
1065 (undo-tree-region-data-undo-beginning r))))
1067 (defmacro undo-tree-node-undo-end (node)
1068 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1069 (when (undo-tree-region-data-p r)
1070 (undo-tree-region-data-undo-end r))))
1072 (defmacro undo-tree-node-redo-beginning (node)
1073 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1074 (when (undo-tree-region-data-p r)
1075 (undo-tree-region-data-redo-beginning r))))
1077 (defmacro undo-tree-node-redo-end (node)
1078 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1079 (when (undo-tree-region-data-p r)
1080 (undo-tree-region-data-redo-end r))))
1083 (defsetf undo-tree-node-undo-beginning (node) (val)
1084 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1085 (unless (undo-tree-region-data-p r)
1086 (setf (undo-tree-node-meta-data ,node)
1087 (plist-put (undo-tree-node-meta-data ,node) :region
1088 (setq r (make-undo-tree-region-data)))))
1089 (setf (undo-tree-region-data-undo-beginning r) ,val)))
1091 (defsetf undo-tree-node-undo-end (node) (val)
1092 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1093 (unless (undo-tree-region-data-p r)
1094 (setf (undo-tree-node-meta-data ,node)
1095 (plist-put (undo-tree-node-meta-data ,node) :region
1096 (setq r (make-undo-tree-region-data)))))
1097 (setf (undo-tree-region-data-undo-end r) ,val)))
1099 (defsetf undo-tree-node-redo-beginning (node) (val)
1100 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1101 (unless (undo-tree-region-data-p r)
1102 (setf (undo-tree-node-meta-data ,node)
1103 (plist-put (undo-tree-node-meta-data ,node) :region
1104 (setq r (make-undo-tree-region-data)))))
1105 (setf (undo-tree-region-data-redo-beginning r) ,val)))
1107 (defsetf undo-tree-node-redo-end (node) (val)
1108 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1109 (unless (undo-tree-region-data-p r)
1110 (setf (undo-tree-node-meta-data ,node)
1111 (plist-put (undo-tree-node-meta-data ,node) :region
1112 (setq r (make-undo-tree-region-data)))))
1113 (setf (undo-tree-region-data-redo-end r) ,val)))
1118 (undo-tree-visualizer-data
1119 (:type vector) ; create unnamed struct
1121 (:constructor make-undo-tree-visualizer-data
1122 (&optional lwidth cwidth rwidth marker))
1124 lwidth cwidth rwidth marker)
1127 (defmacro undo-tree-visualizer-data-p (v)
1128 (let ((len (length (make-undo-tree-visualizer-data))))
1129 `(and (vectorp ,v) (= (length ,v) ,len))))
1131 (defmacro undo-tree-node-clear-visualizer-data (node)
1132 `(setf (undo-tree-node-meta-data ,node)
1135 (plist-put (undo-tree-node-meta-data ,node)
1136 :visualizer nil)))))
1139 (defmacro undo-tree-node-lwidth (node)
1140 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1141 (when (undo-tree-visualizer-data-p v)
1142 (undo-tree-visualizer-data-lwidth v))))
1144 (defmacro undo-tree-node-cwidth (node)
1145 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1146 (when (undo-tree-visualizer-data-p v)
1147 (undo-tree-visualizer-data-cwidth v))))
1149 (defmacro undo-tree-node-rwidth (node)
1150 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1151 (when (undo-tree-visualizer-data-p v)
1152 (undo-tree-visualizer-data-rwidth v))))
1154 (defmacro undo-tree-node-marker (node)
1155 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1156 (when (undo-tree-visualizer-data-p v)
1157 (undo-tree-visualizer-data-marker v))))
1160 (defsetf undo-tree-node-lwidth (node) (val)
1161 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1162 (unless (undo-tree-visualizer-data-p v)
1163 (setf (undo-tree-node-meta-data ,node)
1164 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1165 (setq v (make-undo-tree-visualizer-data)))))
1166 (setf (undo-tree-visualizer-data-lwidth v) ,val)))
1168 (defsetf undo-tree-node-cwidth (node) (val)
1169 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1170 (unless (undo-tree-visualizer-data-p v)
1171 (setf (undo-tree-node-meta-data ,node)
1172 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1173 (setq v (make-undo-tree-visualizer-data)))))
1174 (setf (undo-tree-visualizer-data-cwidth v) ,val)))
1176 (defsetf undo-tree-node-rwidth (node) (val)
1177 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1178 (unless (undo-tree-visualizer-data-p v)
1179 (setf (undo-tree-node-meta-data ,node)
1180 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1181 (setq v (make-undo-tree-visualizer-data)))))
1182 (setf (undo-tree-visualizer-data-rwidth v) ,val)))
1184 (defsetf undo-tree-node-marker (node) (val)
1185 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1186 (unless (undo-tree-visualizer-data-p v)
1187 (setf (undo-tree-node-meta-data ,node)
1188 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1189 (setq v (make-undo-tree-visualizer-data)))))
1190 (setf (undo-tree-visualizer-data-marker v) ,val)))
1194 (defmacro undo-tree-node-register (node)
1195 `(plist-get (undo-tree-node-meta-data ,node) :register))
1197 (defsetf undo-tree-node-register (node) (val)
1198 `(setf (undo-tree-node-meta-data ,node)
1199 (plist-put (undo-tree-node-meta-data ,node) :register ,val)))
1204 ;;; =====================================================================
1205 ;;; Basic undo-tree data structure functions
1207 (defun undo-tree-grow (undo)
1208 "Add an UNDO node to current branch of `buffer-undo-tree'."
1209 (let* ((current (undo-tree-current buffer-undo-tree))
1210 (new (make-undo-tree-node current undo)))
1211 (push new (undo-tree-node-next current))
1212 (setf (undo-tree-current buffer-undo-tree) new)))
1215 (defun undo-tree-grow-backwards (node undo &optional redo)
1216 "Add new node *above* undo-tree NODE, and return new node.
1217 Note that this will overwrite NODE's \"previous\" link, so should
1218 only be used on a detached NODE, never on nodes that are already
1219 part of `buffer-undo-tree'."
1220 (let ((new (make-undo-tree-node-backwards node undo redo)))
1221 (setf (undo-tree-node-previous node) new)
1225 (defun undo-tree-splice-node (node splice)
1226 "Splice NODE into undo tree, below node SPLICE.
1227 Note that this will overwrite NODE's \"next\" and \"previous\"
1228 links, so should only be used on a detached NODE, never on nodes
1229 that are already part of `buffer-undo-tree'."
1230 (setf (undo-tree-node-next node) (undo-tree-node-next splice)
1231 (undo-tree-node-branch node) (undo-tree-node-branch splice)
1232 (undo-tree-node-previous node) splice
1233 (undo-tree-node-next splice) (list node)
1234 (undo-tree-node-branch splice) 0)
1235 (dolist (n (undo-tree-node-next node))
1236 (setf (undo-tree-node-previous n) node)))
1239 (defun undo-tree-snip-node (node)
1240 "Snip NODE out of undo tree."
1241 (let* ((parent (undo-tree-node-previous node))
1243 ;; if NODE is only child, replace parent's next links with NODE's
1244 (if (= (length (undo-tree-node-next parent)) 0)
1245 (setf (undo-tree-node-next parent) (undo-tree-node-next node)
1246 (undo-tree-node-branch parent) (undo-tree-node-branch node))
1248 (setq position (undo-tree-position node (undo-tree-node-next parent)))
1250 ;; if active branch used do go via NODE, set parent's branch to active
1252 ((= (undo-tree-node-branch parent) position)
1253 (setf (undo-tree-node-branch parent)
1254 (+ position (undo-tree-node-branch node))))
1255 ;; if active branch didn't go via NODE, update parent's branch to point
1256 ;; to same node as before
1257 ((> (undo-tree-node-branch parent) position)
1258 (incf (undo-tree-node-branch parent)
1259 (1- (length (undo-tree-node-next node))))))
1260 ;; replace NODE in parent's next list with NODE's entire next list
1262 (setf (undo-tree-node-next parent)
1263 (nconc (undo-tree-node-next node)
1264 (cdr (undo-tree-node-next parent))))
1265 (setq p (nthcdr (1- position) (undo-tree-node-next parent)))
1266 (setcdr p (nconc (undo-tree-node-next node) (cddr p)))))
1267 ;; update previous links of NODE's children
1268 (dolist (n (undo-tree-node-next node))
1269 (setf (undo-tree-node-previous n) parent))))
1272 (defun undo-tree-mapc (--undo-tree-mapc-function-- undo-tree)
1273 ;; Apply FUNCTION to each node in UNDO-TREE.
1274 (let ((stack (list (undo-tree-root undo-tree)))
1277 (setq node (pop stack))
1278 (funcall --undo-tree-mapc-function-- node)
1279 (setq stack (append (undo-tree-node-next node) stack)))))
1282 (defmacro undo-tree-num-branches ()
1283 "Return number of branches at current undo tree node."
1284 '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree))))
1287 (defun undo-tree-position (node list)
1288 "Find the first occurrence of NODE in LIST.
1289 Return the index of the matching item, or nil of not found.
1290 Comparison is done with `eq'."
1294 (when (eq node (car list)) (throw 'found i))
1296 (setq list (cdr list))))
1300 (defvar *undo-tree-id-counter* 0)
1301 (make-variable-buffer-local '*undo-tree-id-counter*)
1303 (defmacro undo-tree-generate-id ()
1304 ;; Generate a new, unique id (uninterned symbol).
1305 ;; The name is made by appending a number to "undo-tree-id".
1306 ;; (Copied from CL package `gensym'.)
1307 `(let ((num (prog1 *undo-tree-id-counter* (incf *undo-tree-id-counter*))))
1308 (make-symbol (format "undo-tree-id%d" num))))
1313 ;;; =====================================================================
1314 ;;; Utility functions for handling `buffer-undo-list' and changesets
1316 (defmacro undo-list-marker-elt-p (elt)
1317 `(markerp (car-safe ,elt)))
1319 (defmacro undo-list-GCd-marker-elt-p (elt)
1320 ;; Return t if ELT is a marker element whose marker has been moved to the
1321 ;; object-pool, so may potentially have been garbage-collected.
1322 ;; Note: Valid marker undo elements should be uniquely identified as cons
1323 ;; cells with a symbol in the car (replacing the marker), and a number in
1324 ;; the cdr. However, to guard against future changes to undo element
1325 ;; formats, we perform an additional redundant check on the symbol name.
1326 `(and (car-safe ,elt)
1327 (symbolp (car ,elt))
1328 (let ((str (symbol-name (car ,elt))))
1329 (and (> (length str) 12)
1330 (string= (substring str 0 12) "undo-tree-id")))
1331 (numberp (cdr-safe ,elt))))
1334 (defun undo-tree-move-GC-elts-to-pool (elt)
1335 ;; Move elements that can be garbage-collected into `buffer-undo-tree'
1336 ;; object pool, substituting a unique id that can be used to retrieve them
1337 ;; later. (Only markers require this treatment currently.)
1338 (when (undo-list-marker-elt-p elt)
1339 (let ((id (undo-tree-generate-id)))
1340 (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree))
1344 (defun undo-tree-restore-GC-elts-from-pool (elt)
1345 ;; Replace object id's in ELT with corresponding objects from
1346 ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if
1347 ;; any object in ELT has been garbage-collected.
1348 (if (undo-list-GCd-marker-elt-p elt)
1349 (when (setcar elt (gethash (car elt)
1350 (undo-tree-object-pool buffer-undo-tree)))
1355 (defun undo-list-clean-GCd-elts (undo-list)
1356 ;; Remove object id's from UNDO-LIST that refer to elements that have been
1357 ;; garbage-collected. UNDO-LIST is modified by side-effect.
1358 (while (undo-list-GCd-marker-elt-p (car undo-list))
1359 (unless (gethash (caar undo-list)
1360 (undo-tree-object-pool buffer-undo-tree))
1361 (setq undo-list (cdr undo-list))))
1362 (let ((p undo-list))
1364 (when (and (undo-list-GCd-marker-elt-p (cadr p))
1365 (null (gethash (car (cadr p))
1366 (undo-tree-object-pool buffer-undo-tree))))
1367 (setcdr p (cddr p)))
1372 (defun undo-list-pop-changeset (&optional discard-pos)
1373 ;; Pop changeset from `buffer-undo-list'. If DISCARD-POS is non-nil, discard
1374 ;; any position entries from changeset.
1376 ;; discard undo boundaries and (if DISCARD-POS is non-nil) position entries
1377 ;; at head of undo list
1378 (while (or (null (car buffer-undo-list))
1379 (and discard-pos (integerp (car buffer-undo-list))))
1380 (setq buffer-undo-list (cdr buffer-undo-list)))
1381 ;; pop elements up to next undo boundary, discarding position entries if
1382 ;; DISCARD-POS is non-nil
1383 (if (eq (car buffer-undo-list) 'undo-tree-canary)
1384 (push nil buffer-undo-list)
1385 (let* ((changeset (list (pop buffer-undo-list)))
1388 (undo-tree-move-GC-elts-to-pool (car p))
1389 (while (and discard-pos (integerp (car buffer-undo-list)))
1390 (setq buffer-undo-list (cdr buffer-undo-list)))
1391 (car buffer-undo-list))
1392 (setcdr p (list (pop buffer-undo-list)))
1397 (defun undo-tree-copy-list (undo-list)
1398 ;; Return a deep copy of first changeset in `undo-list'. Object id's are
1399 ;; replaced by corresponding objects from `buffer-undo-tree' object-pool.
1402 ;; if first element contains an object id, replace it with object from
1403 ;; pool, discarding element entirely if it's been GC'd
1406 (undo-tree-restore-GC-elts-from-pool (pop undo-list))))
1407 (setq copy (list copy)
1409 ;; copy remaining elements, replacing object id's with objects from
1410 ;; pool, or discarding them entirely if they've been GC'd
1412 (when (setcdr p (undo-tree-restore-GC-elts-from-pool
1413 (undo-copy-list-1 (pop undo-list))))
1414 (setcdr p (list (cdr p)))
1420 (defun undo-list-transfer-to-tree ()
1421 ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'.
1423 ;; if `buffer-undo-tree' is empty, create initial undo-tree
1424 (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree)))
1425 ;; make sure there's a canary at end of `buffer-undo-list'
1426 (when (null buffer-undo-list)
1427 (setq buffer-undo-list '(nil undo-tree-canary)))
1429 (unless (eq (cadr buffer-undo-list) 'undo-tree-canary)
1430 ;; create new node from first changeset in `buffer-undo-list', save old
1431 ;; `buffer-undo-tree' current node, and make new node the current node
1432 (let* ((node (make-undo-tree-node nil (undo-list-pop-changeset)))
1433 (splice (undo-tree-current buffer-undo-tree))
1434 (size (undo-list-byte-size (undo-tree-node-undo node))))
1435 (setf (undo-tree-current buffer-undo-tree) node)
1436 ;; grow tree fragment backwards using `buffer-undo-list' changesets
1437 (while (and buffer-undo-list
1438 (not (eq (cadr buffer-undo-list) 'undo-tree-canary)))
1440 (undo-tree-grow-backwards node (undo-list-pop-changeset)))
1441 (incf size (undo-list-byte-size (undo-tree-node-undo node))))
1442 ;; if no undo history has been discarded from `buffer-undo-list' since
1443 ;; last transfer, splice new tree fragment onto end of old
1444 ;; `buffer-undo-tree' current node
1445 (if (eq (cadr buffer-undo-list) 'undo-tree-canary)
1447 (setf (undo-tree-node-previous node) splice)
1448 (push node (undo-tree-node-next splice))
1449 (setf (undo-tree-node-branch splice) 0)
1450 (incf (undo-tree-size buffer-undo-tree) size))
1451 ;; if undo history has been discarded, replace entire
1452 ;; `buffer-undo-tree' with new tree fragment
1453 (setq node (undo-tree-grow-backwards node nil))
1454 (setf (undo-tree-root buffer-undo-tree) node)
1455 (setq buffer-undo-list '(nil undo-tree-canary))
1456 (setf (undo-tree-size buffer-undo-tree) size)
1457 (setq buffer-undo-list '(nil undo-tree-canary))))
1458 ;; discard undo history if necessary
1459 (undo-tree-discard-history)))
1462 (defun undo-list-byte-size (undo-list)
1463 ;; Return size (in bytes) of UNDO-LIST
1464 (let ((size 0) (p undo-list))
1466 (incf size 8) ; cons cells use up 8 bytes
1467 (when (and (consp (car p)) (stringp (caar p)))
1468 (incf size (string-bytes (caar p))))
1474 (defun undo-list-rebuild-from-tree ()
1475 "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'."
1476 (unless (eq buffer-undo-list t)
1477 (undo-list-transfer-to-tree)
1478 (setq buffer-undo-list nil)
1479 (when buffer-undo-tree
1480 (let ((stack (list (list (undo-tree-root buffer-undo-tree)))))
1481 (push (sort (mapcar 'identity (undo-tree-node-next (caar stack)))
1483 (time-less-p (undo-tree-node-timestamp a)
1484 (undo-tree-node-timestamp b))))
1486 ;; Traverse tree in depth-and-oldest-first order, but add undo records
1487 ;; on the way down, and redo records on the way up.
1488 (while (or (car stack)
1489 (not (eq (car (nth 1 stack))
1490 (undo-tree-current buffer-undo-tree))))
1493 (setq buffer-undo-list
1494 (append (undo-tree-node-undo (caar stack))
1497 (push (sort (mapcar 'identity
1498 (undo-tree-node-next (caar stack)))
1500 (time-less-p (undo-tree-node-timestamp a)
1501 (undo-tree-node-timestamp b))))
1504 (setq buffer-undo-list
1505 (append (undo-tree-node-redo (caar stack))
1508 (pop (car stack))))))))
1513 ;;; =====================================================================
1514 ;;; History discarding functions
1516 (defun undo-tree-oldest-leaf (node)
1517 ;; Return oldest leaf node below NODE.
1518 (while (undo-tree-node-next node)
1520 (car (sort (mapcar 'identity (undo-tree-node-next node))
1522 (time-less-p (undo-tree-node-timestamp a)
1523 (undo-tree-node-timestamp b)))))))
1527 (defun undo-tree-discard-node (node)
1528 ;; Discard NODE from `buffer-undo-tree', and return next in line for
1531 ;; don't discard current node
1532 (unless (eq node (undo-tree-current buffer-undo-tree))
1534 ;; discarding root node...
1535 (if (eq node (undo-tree-root buffer-undo-tree))
1537 ;; should always discard branches before root
1538 ((> (length (undo-tree-node-next node)) 1)
1539 (error "Trying to discard undo-tree root which still\
1540 has multiple branches"))
1541 ;; don't discard root if current node is only child
1542 ((eq (car (undo-tree-node-next node))
1543 (undo-tree-current buffer-undo-tree))
1547 ;; clear any register referring to root
1548 (let ((r (undo-tree-node-register node)))
1549 (when (and r (eq (get-register r) node))
1550 (set-register r nil)))
1551 ;; make child of root into new root
1552 (setq node (setf (undo-tree-root buffer-undo-tree)
1553 (car (undo-tree-node-next node))))
1554 ;; update undo-tree size
1555 (decf (undo-tree-size buffer-undo-tree)
1556 (+ (undo-list-byte-size (undo-tree-node-undo node))
1557 (undo-list-byte-size (undo-tree-node-redo node))))
1558 ;; discard new root's undo data
1559 (setf (undo-tree-node-undo node) nil
1560 (undo-tree-node-redo node) nil)
1561 ;; if new root has branches, or new root is current node, next node
1562 ;; to discard is oldest leaf, otherwise it's new root
1563 (if (or (> (length (undo-tree-node-next node)) 1)
1564 (eq (car (undo-tree-node-next node))
1565 (undo-tree-current buffer-undo-tree)))
1566 (undo-tree-oldest-leaf node)
1569 ;; discarding leaf node...
1570 (let* ((parent (undo-tree-node-previous node))
1571 (current (nth (undo-tree-node-branch parent)
1572 (undo-tree-node-next parent))))
1573 ;; clear any register referring to the discarded node
1574 (let ((r (undo-tree-node-register node)))
1575 (when (and r (eq (get-register r) node))
1576 (set-register r nil)))
1577 ;; update undo-tree size
1578 (decf (undo-tree-size buffer-undo-tree)
1579 (+ (undo-list-byte-size (undo-tree-node-undo node))
1580 (undo-list-byte-size (undo-tree-node-redo node))))
1581 (setf (undo-tree-node-next parent)
1582 (delq node (undo-tree-node-next parent))
1583 (undo-tree-node-branch parent)
1584 (undo-tree-position current (undo-tree-node-next parent)))
1585 ;; if parent has branches, or parent is current node, next node to
1586 ;; discard is oldest leaf, otherwise it's parent
1587 (if (or (eq parent (undo-tree-current buffer-undo-tree))
1588 (and (undo-tree-node-next parent)
1589 (or (not (eq parent (undo-tree-root buffer-undo-tree)))
1590 (> (length (undo-tree-node-next parent)) 1))))
1591 (undo-tree-oldest-leaf parent)
1596 (defun undo-tree-discard-history ()
1597 "Discard undo history until we're within memory usage limits
1598 set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'."
1600 (when (> (undo-tree-size buffer-undo-tree) undo-limit)
1601 ;; if there are no branches off root, first node to discard is root;
1602 ;; otherwise it's leaf node at botom of oldest branch
1603 (let ((node (if (> (length (undo-tree-node-next
1604 (undo-tree-root buffer-undo-tree))) 1)
1605 (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree))
1606 (undo-tree-root buffer-undo-tree))))
1608 ;; discard nodes until memory use is within `undo-strong-limit'
1610 (> (undo-tree-size buffer-undo-tree) undo-strong-limit))
1611 (setq node (undo-tree-discard-node node)))
1613 ;; discard nodes until next node to discard would bring memory use
1614 ;; within `undo-limit'
1616 ;; check first if last discard has brought us within
1617 ;; `undo-limit', in case we can avoid more expensive
1618 ;; `undo-strong-limit' calculation
1619 ;; Note: this assumes undo-strong-limit > undo-limit;
1620 ;; if not, effectively undo-strong-limit = undo-limit
1621 (> (undo-tree-size buffer-undo-tree) undo-limit)
1622 (> (- (undo-tree-size buffer-undo-tree)
1623 ;; if next node to discard is root, the memory we
1624 ;; free-up comes from discarding changesets from its
1626 (if (eq node (undo-tree-root buffer-undo-tree))
1627 (+ (undo-list-byte-size
1628 (undo-tree-node-undo
1629 (car (undo-tree-node-next node))))
1630 (undo-list-byte-size
1631 (undo-tree-node-redo
1632 (car (undo-tree-node-next node)))))
1633 ;; ...otherwise, it comes from discarding changesets
1634 ;; from along with the node itself
1635 (+ (undo-list-byte-size (undo-tree-node-undo node))
1636 (undo-list-byte-size (undo-tree-node-redo node)))
1639 (setq node (undo-tree-discard-node node)))
1641 ;; if we're still over the `undo-outer-limit', discard entire history
1642 (when (> (undo-tree-size buffer-undo-tree) undo-outer-limit)
1643 ;; query first if `undo-ask-before-discard' is set
1644 (if undo-ask-before-discard
1647 "Buffer `%s' undo info is %d bytes long; discard it? "
1648 (buffer-name) (undo-tree-size buffer-undo-tree)))
1649 (setq buffer-undo-tree nil))
1650 ;; otherwise, discard and display warning
1652 '(undo discard-info)
1654 (format "Buffer `%s' undo info was %d bytes long.\n"
1655 (buffer-name) (undo-tree-size buffer-undo-tree))
1656 "The undo info was discarded because it exceeded\
1659 This is normal if you executed a command that made a huge change
1660 to the buffer. In that case, to prevent similar problems in the
1661 future, set `undo-outer-limit' to a value that is large enough to
1662 cover the maximum size of normal changes you expect a single
1663 command to make, but not so large that it might exceed the
1664 maximum memory allotted to Emacs.
1666 If you did not execute any such command, the situation is
1667 probably due to a bug and you should report it.
1669 You can disable the popping up of this buffer by adding the entry
1670 \(undo discard-info) to the user option `warning-suppress-types',
1671 which is defined in the `warnings' library.\n")
1673 (setq buffer-undo-tree nil)))
1679 ;;; =====================================================================
1680 ;;; Visualizer-related functions
1682 (defun undo-tree-compute-widths (undo-tree)
1683 "Recursively compute widths for all UNDO-TREE's nodes."
1684 (let ((stack (list (undo-tree-root undo-tree)))
1687 ;; try to compute widths for node at top of stack
1688 (if (undo-tree-node-p
1689 (setq res (undo-tree-node-compute-widths (car stack))))
1690 ;; if computation fails, it returns a node whose widths still need
1691 ;; computing, which we push onto the stack
1693 ;; otherwise, store widths and remove it from stack
1694 (setf (undo-tree-node-lwidth (car stack)) (aref res 0)
1695 (undo-tree-node-cwidth (car stack)) (aref res 1)
1696 (undo-tree-node-rwidth (car stack)) (aref res 2))
1700 (defun undo-tree-node-compute-widths (node)
1701 ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths
1702 ;; (in a vector) if successful. Otherwise, returns a node whose widths need
1703 ;; calculating before NODE's can be calculated.
1704 (let ((num-children (length (undo-tree-node-next node)))
1705 (lwidth 0) (cwidth 0) (rwidth 0)
1709 ;; leaf nodes have 0 width
1712 (undo-tree-node-lwidth node) 0
1713 (undo-tree-node-cwidth node) 1
1714 (undo-tree-node-rwidth node) 0))
1716 ;; odd number of children
1717 ((= (mod num-children 2) 1)
1718 (setq p (undo-tree-node-next node))
1719 ;; compute left-width
1720 (dotimes (i (/ num-children 2))
1721 (if (undo-tree-node-lwidth (car p))
1722 (incf lwidth (+ (undo-tree-node-lwidth (car p))
1723 (undo-tree-node-cwidth (car p))
1724 (undo-tree-node-rwidth (car p))))
1725 ;; if child's widths haven't been computed, return that child
1726 (throw 'need-widths (car p)))
1728 (if (undo-tree-node-lwidth (car p))
1729 (incf lwidth (undo-tree-node-lwidth (car p)))
1730 (throw 'need-widths (car p)))
1731 ;; centre-width is inherited from middle child
1732 (setf cwidth (undo-tree-node-cwidth (car p)))
1733 ;; compute right-width
1734 (incf rwidth (undo-tree-node-rwidth (car p)))
1736 (dotimes (i (/ num-children 2))
1737 (if (undo-tree-node-lwidth (car p))
1738 (incf rwidth (+ (undo-tree-node-lwidth (car p))
1739 (undo-tree-node-cwidth (car p))
1740 (undo-tree-node-rwidth (car p))))
1741 (throw 'need-widths (car p)))
1744 ;; even number of children
1746 (setq p (undo-tree-node-next node))
1747 ;; compute left-width
1748 (dotimes (i (/ num-children 2))
1749 (if (undo-tree-node-lwidth (car p))
1750 (incf lwidth (+ (undo-tree-node-lwidth (car p))
1751 (undo-tree-node-cwidth (car p))
1752 (undo-tree-node-rwidth (car p))))
1753 (throw 'need-widths (car p)))
1755 ;; centre-width is 0 when number of children is even
1757 ;; compute right-width
1758 (dotimes (i (/ num-children 2))
1759 (if (undo-tree-node-lwidth (car p))
1760 (incf rwidth (+ (undo-tree-node-lwidth (car p))
1761 (undo-tree-node-cwidth (car p))
1762 (undo-tree-node-rwidth (car p))))
1763 (throw 'need-widths (car p)))
1766 ;; return left-, centre- and right-widths
1767 (vector lwidth cwidth rwidth))))
1770 (defun undo-tree-clear-visualizer-data (undo-tree)
1771 ;; Clear visualizer data from UNDO-TREE.
1773 (lambda (node) (undo-tree-node-clear-visualizer-data node))
1779 ;;; =====================================================================
1780 ;;; Undo-in-region functions
1782 (defun undo-tree-pull-undo-in-region-branch (start end)
1783 ;; Pull out entries from undo changesets to create a new undo-in-region
1784 ;; branch, which undoes changeset entries lying between START and END first,
1785 ;; followed by remaining entries from the changesets, before rejoining the
1786 ;; existing undo tree history. Repeated calls will, if appropriate, extend
1787 ;; the current undo-in-region branch rather than creating a new one.
1789 ;; if we're just reverting the last redo-in-region, we don't need to
1790 ;; manipulate the undo tree at all
1791 (if (undo-tree-reverting-redo-in-region-p start end)
1792 t ; return t to indicate success
1794 ;; We build the `region-changeset' and `delta-list' lists forwards, using
1795 ;; pointers `r' and `d' to the penultimate element of the list. So that we
1796 ;; don't have to treat the first element differently, we prepend a dummy
1797 ;; leading nil to the lists, and have the pointers point to that
1799 ;; Note: using '(nil) instead of (list nil) in the `let*' results in
1800 ;; bizarre errors when the code is byte-compiled, where parts of the
1801 ;; lists appear to survive across different calls to this function.
1802 ;; An obscure byte-compiler bug, perhaps?
1803 (let* ((region-changeset (list nil))
1804 (r region-changeset)
1805 (delta-list (list nil))
1807 (node (undo-tree-current buffer-undo-tree))
1808 (repeated-undo-in-region
1809 (undo-tree-repeated-undo-in-region-p start end))
1810 undo-adjusted-markers ; `undo-elt-in-region' expects this
1811 fragment splice original-fragment original-splice original-current
1812 got-visible-elt undo-list elt)
1814 ;; --- initialisation ---
1816 ;; if this is a repeated undo in the same region, start pulling changes
1817 ;; from NODE at which undo-in-region branch iss attached, and detatch
1818 ;; the branch, using it as initial FRAGMENT of branch being constructed
1819 (repeated-undo-in-region
1820 (setq original-current node
1821 fragment (car (undo-tree-node-next node))
1823 ;; undo up to node at which undo-in-region branch is attached
1824 ;; (recognizable as first node with more than one branch)
1825 (let ((mark-active nil))
1826 (while (= (length (undo-tree-node-next node)) 1)
1829 node (undo-tree-current buffer-undo-tree))))
1830 (when (eq splice node) (setq splice nil))
1831 ;; detatch undo-in-region branch
1832 (setf (undo-tree-node-next node)
1833 (delq fragment (undo-tree-node-next node))
1834 (undo-tree-node-previous fragment) nil
1835 original-fragment fragment
1836 original-splice node))
1838 ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all
1839 ;; nodes below the current one in the active branch
1840 ((undo-tree-node-next node)
1841 (setq fragment (make-undo-tree-node nil nil)
1843 (while (setq node (nth (undo-tree-node-branch node)
1844 (undo-tree-node-next node)))
1845 (push (make-undo-tree-node
1847 (undo-copy-list (undo-tree-node-undo node))
1848 (undo-copy-list (undo-tree-node-redo node)))
1849 (undo-tree-node-next splice))
1850 (setq splice (car (undo-tree-node-next splice))))
1851 (setq fragment (car (undo-tree-node-next fragment))
1853 node (undo-tree-current buffer-undo-tree))))
1856 ;; --- pull undo-in-region elements into branch ---
1857 ;; work backwards up tree, pulling out undo elements within region until
1858 ;; we've got one that undoes a visible change (insertion or deletion)
1860 (while (and (not got-visible-elt) node (undo-tree-node-undo node))
1861 ;; we cons a dummy nil element on the front of the changeset so that
1862 ;; we can conveniently remove the first (real) element from the
1863 ;; changeset if we need to; the leading nil is removed once we're
1864 ;; done with this changeset
1865 (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node)))
1866 elt (cadr undo-list))
1869 (setq fragment (undo-tree-grow-backwards fragment undo-list))
1870 (unless splice (setq splice fragment)))
1871 (setq fragment (make-undo-tree-node nil undo-list))
1872 (setq splice fragment))
1876 ;; keep elements within region
1877 ((undo-elt-in-region elt start end)
1878 ;; set flag if kept element is visible (insertion or deletion)
1879 (when (and (consp elt)
1880 (or (stringp (car elt)) (integerp (car elt))))
1881 (setq got-visible-elt t))
1882 ;; adjust buffer positions in elements previously undone before
1883 ;; kept element, as kept element will now be undone first
1884 (undo-tree-adjust-elements-to-elt splice elt)
1885 ;; move kept element to undo-in-region changeset, adjusting its
1886 ;; buffer position as it will now be undone first
1887 (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list))))
1889 (setcdr undo-list (cddr undo-list)))
1891 ;; discard "was unmodified" elements
1892 ;; FIXME: deal properly with these
1893 ((and (consp elt) (eq (car elt) t))
1894 (setcdr undo-list (cddr undo-list)))
1896 ;; if element crosses region, we can't pull any more elements
1897 ((undo-elt-crosses-region elt start end)
1898 ;; if we've found a visible element, it must be earlier in
1899 ;; current node's changeset; stop pulling elements (null
1900 ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit)
1902 (setq undo-list nil)
1903 ;; if we haven't found a visible element yet, pulling
1904 ;; undo-in-region branch has failed
1905 (setq region-changeset nil)
1908 ;; if rejecting element, add its delta (if any) to the list
1910 (let ((delta (undo-delta elt)))
1911 (when (/= 0 (cdr delta))
1912 (setcdr d (list delta))
1914 (setq undo-list (cdr undo-list))))
1916 ;; process next element of current changeset
1917 (setq elt (cadr undo-list)))
1919 ;; if there are remaining elements in changeset, remove dummy nil
1921 (if (cadr (undo-tree-node-undo fragment))
1922 (pop (undo-tree-node-undo fragment))
1923 ;; otherwise, if we've kept all elements in changeset, discard
1925 (when (eq splice fragment) (setq splice nil))
1926 (setq fragment (car (undo-tree-node-next fragment))))
1927 ;; process changeset from next node up the tree
1928 (setq node (undo-tree-node-previous node))))
1930 ;; pop dummy nil from front of `region-changeset'
1931 (pop region-changeset)
1934 ;; --- integrate branch into tree ---
1935 ;; if no undo-in-region elements were found, restore undo tree
1936 (if (null region-changeset)
1937 (when original-current
1938 (push original-fragment (undo-tree-node-next original-splice))
1939 (setf (undo-tree-node-branch original-splice) 0
1940 (undo-tree-node-previous original-fragment) original-splice)
1941 (let ((mark-active nil))
1942 (while (not (eq (undo-tree-current buffer-undo-tree)
1945 nil) ; return nil to indicate failure
1948 ;; need to undo up to node where new branch will be attached, to
1949 ;; ensure redo entries are populated, and then redo back to where we
1951 (let ((mark-active nil)
1952 (current (undo-tree-current buffer-undo-tree)))
1953 (while (not (eq (undo-tree-current buffer-undo-tree) node))
1955 (while (not (eq (undo-tree-current buffer-undo-tree) current))
1959 ;; if there's no remaining fragment, just create undo-in-region node
1960 ;; and attach it to parent of last node from which elements were
1963 (setq fragment (make-undo-tree-node node region-changeset))
1964 (push fragment (undo-tree-node-next node))
1965 (setf (undo-tree-node-branch node) 0)
1966 ;; set current node to undo-in-region node
1967 (setf (undo-tree-current buffer-undo-tree) fragment))
1969 ;; if no splice point has been set, add undo-in-region node to top of
1970 ;; fragment and attach it to parent of last node from which elements
1973 (setq fragment (undo-tree-grow-backwards fragment region-changeset))
1974 (push fragment (undo-tree-node-next node))
1975 (setf (undo-tree-node-branch node) 0
1976 (undo-tree-node-previous fragment) node)
1977 ;; set current node to undo-in-region node
1978 (setf (undo-tree-current buffer-undo-tree) fragment))
1980 ;; if fragment contains nodes, attach fragment to parent of last node
1981 ;; from which elements were pulled, and splice in undo-in-region node
1983 (setf (undo-tree-node-previous fragment) node)
1984 (push fragment (undo-tree-node-next node))
1985 (setf (undo-tree-node-branch node) 0)
1986 ;; if this is a repeated undo-in-region, then we've left the current
1987 ;; node at the original splice-point; we need to set the current
1988 ;; node to the equivalent node on the undo-in-region branch and redo
1989 ;; back to where we started
1990 (when repeated-undo-in-region
1991 (setf (undo-tree-current buffer-undo-tree)
1992 (undo-tree-node-previous original-fragment))
1993 (let ((mark-active nil))
1994 (while (not (eq (undo-tree-current buffer-undo-tree) splice))
1995 (undo-tree-redo nil 'preserve-undo))))
1996 ;; splice new undo-in-region node into fragment
1997 (setq node (make-undo-tree-node nil region-changeset))
1998 (undo-tree-splice-node node splice)
1999 ;; set current node to undo-in-region node
2000 (setf (undo-tree-current buffer-undo-tree) node)))
2002 ;; update undo-tree size
2003 (setq node (undo-tree-node-previous fragment))
2005 (and (setq node (car (undo-tree-node-next node)))
2006 (not (eq node original-fragment))
2007 (incf (undo-tree-size buffer-undo-tree)
2008 (undo-list-byte-size (undo-tree-node-undo node)))
2009 (when (undo-tree-node-redo node)
2010 (incf (undo-tree-size buffer-undo-tree)
2011 (undo-list-byte-size (undo-tree-node-redo node))))
2013 t) ; indicate undo-in-region branch was successfully pulled
2018 (defun undo-tree-pull-redo-in-region-branch (start end)
2019 ;; Pull out entries from redo changesets to create a new redo-in-region
2020 ;; branch, which redoes changeset entries lying between START and END first,
2021 ;; followed by remaining entries from the changesets. Repeated calls will,
2022 ;; if appropriate, extend the current redo-in-region branch rather than
2023 ;; creating a new one.
2025 ;; if we're just reverting the last undo-in-region, we don't need to
2026 ;; manipulate the undo tree at all
2027 (if (undo-tree-reverting-undo-in-region-p start end)
2028 t ; return t to indicate success
2030 ;; We build the `region-changeset' and `delta-list' lists forwards, using
2031 ;; pointers `r' and `d' to the penultimate element of the list. So that we
2032 ;; don't have to treat the first element differently, we prepend a dummy
2033 ;; leading nil to the lists, and have the pointers point to that
2035 ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre
2036 ;; errors when the code is byte-compiled, where parts of the lists
2037 ;; appear to survive across different calls to this function. An
2038 ;; obscure byte-compiler bug, perhaps?
2039 (let* ((region-changeset (list nil))
2040 (r region-changeset)
2041 (delta-list (list nil))
2043 (node (undo-tree-current buffer-undo-tree))
2044 (repeated-redo-in-region
2045 (undo-tree-repeated-redo-in-region-p start end))
2046 undo-adjusted-markers ; `undo-elt-in-region' expects this
2047 fragment splice got-visible-elt redo-list elt)
2049 ;; --- inisitalisation ---
2051 ;; if this is a repeated redo-in-region, detach fragment below current
2053 (repeated-redo-in-region
2054 (when (setq fragment (car (undo-tree-node-next node)))
2055 (setf (undo-tree-node-previous fragment) nil
2056 (undo-tree-node-next node)
2057 (delq fragment (undo-tree-node-next node)))))
2058 ;; if this is a new redo-in-region, initial fragment is a copy of all
2059 ;; nodes below the current one in the active branch
2060 ((undo-tree-node-next node)
2061 (setq fragment (make-undo-tree-node nil nil)
2063 (while (setq node (nth (undo-tree-node-branch node)
2064 (undo-tree-node-next node)))
2065 (push (make-undo-tree-node
2067 (undo-copy-list (undo-tree-node-redo node)))
2068 (undo-tree-node-next splice))
2069 (setq splice (car (undo-tree-node-next splice))))
2070 (setq fragment (car (undo-tree-node-next fragment)))))
2073 ;; --- pull redo-in-region elements into branch ---
2074 ;; work down fragment, pulling out redo elements within region until
2075 ;; we've got one that redoes a visible change (insertion or deletion)
2076 (setq node fragment)
2078 (while (and (not got-visible-elt) node (undo-tree-node-redo node))
2079 ;; we cons a dummy nil element on the front of the changeset so that
2080 ;; we can conveniently remove the first (real) element from the
2081 ;; changeset if we need to; the leading nil is removed once we're
2082 ;; done with this changeset
2083 (setq redo-list (push nil (undo-tree-node-redo node))
2084 elt (cadr redo-list))
2087 ;; keep elements within region
2088 ((undo-elt-in-region elt start end)
2089 ;; set flag if kept element is visible (insertion or deletion)
2090 (when (and (consp elt)
2091 (or (stringp (car elt)) (integerp (car elt))))
2092 (setq got-visible-elt t))
2093 ;; adjust buffer positions in elements previously redone before
2094 ;; kept element, as kept element will now be redone first
2095 (undo-tree-adjust-elements-to-elt fragment elt t)
2096 ;; move kept element to redo-in-region changeset, adjusting its
2097 ;; buffer position as it will now be redone first
2098 (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1)))
2100 (setcdr redo-list (cddr redo-list)))
2102 ;; discard "was unmodified" elements
2103 ;; FIXME: deal properly with these
2104 ((and (consp elt) (eq (car elt) t))
2105 (setcdr redo-list (cddr redo-list)))
2107 ;; if element crosses region, we can't pull any more elements
2108 ((undo-elt-crosses-region elt start end)
2109 ;; if we've found a visible element, it must be earlier in
2110 ;; current node's changeset; stop pulling elements (null
2111 ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit)
2113 (setq redo-list nil)
2114 ;; if we haven't found a visible element yet, pulling
2115 ;; redo-in-region branch has failed
2116 (setq region-changeset nil)
2119 ;; if rejecting element, add its delta (if any) to the list
2121 (let ((delta (undo-delta elt)))
2122 (when (/= 0 (cdr delta))
2123 (setcdr d (list delta))
2125 (setq redo-list (cdr redo-list))))
2127 ;; process next element of current changeset
2128 (setq elt (cadr redo-list)))
2130 ;; if there are remaining elements in changeset, remove dummy nil
2132 (if (cadr (undo-tree-node-redo node))
2133 (pop (undo-tree-node-undo node))
2134 ;; otherwise, if we've kept all elements in changeset, discard
2136 (if (eq fragment node)
2137 (setq fragment (car (undo-tree-node-next fragment)))
2138 (undo-tree-snip-node node)))
2139 ;; process changeset from next node in fragment
2140 (setq node (car (undo-tree-node-next node)))))
2142 ;; pop dummy nil from front of `region-changeset'
2143 (pop region-changeset)
2146 ;; --- integrate branch into tree ---
2147 (setq node (undo-tree-current buffer-undo-tree))
2148 ;; if no redo-in-region elements were found, restore undo tree
2149 (if (null (car region-changeset))
2150 (when (and repeated-redo-in-region fragment)
2151 (push fragment (undo-tree-node-next node))
2152 (setf (undo-tree-node-branch node) 0
2153 (undo-tree-node-previous fragment) node)
2154 nil) ; return nil to indicate failure
2156 ;; otherwise, add redo-in-region node to top of fragment, and attach
2157 ;; it below current node
2160 (undo-tree-grow-backwards fragment nil region-changeset)
2161 (make-undo-tree-node nil nil region-changeset)))
2162 (push fragment (undo-tree-node-next node))
2163 (setf (undo-tree-node-branch node) 0
2164 (undo-tree-node-previous fragment) node)
2165 ;; update undo-tree size
2166 (unless repeated-redo-in-region
2167 (setq node fragment)
2169 (and (setq node (car (undo-tree-node-next node)))
2170 (incf (undo-tree-size buffer-undo-tree)
2171 (undo-list-byte-size
2172 (undo-tree-node-redo node)))))))
2173 (incf (undo-tree-size buffer-undo-tree)
2174 (undo-list-byte-size (undo-tree-node-redo fragment)))
2175 t) ; indicate undo-in-region branch was successfully pulled
2180 (defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below)
2181 "Adjust buffer positions of undo elements, starting at NODE's
2182 and going up the tree (or down the active branch if BELOW is
2183 non-nil) and through the nodes' undo elements until we reach
2184 UNDO-ELT. UNDO-ELT must appear somewhere in the undo changeset
2185 of either NODE itself or some node above it in the tree."
2186 (let ((delta (list (undo-delta undo-elt)))
2187 (undo-list (undo-tree-node-undo node)))
2188 ;; adjust elements until we reach UNDO-ELT
2189 (while (and (car undo-list)
2190 (not (eq (car undo-list) undo-elt)))
2192 (undo-tree-apply-deltas (car undo-list) delta -1))
2193 ;; move to next undo element in list, or to next node if we've run out
2195 (unless (car (setq undo-list (cdr undo-list)))
2197 (setq node (nth (undo-tree-node-branch node)
2198 (undo-tree-node-next node)))
2199 (setq node (undo-tree-node-previous node)))
2200 (setq undo-list (undo-tree-node-undo node))))))
2204 (defun undo-tree-apply-deltas (undo-elt deltas &optional sgn)
2205 ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN
2206 ;; (only useful value for SGN is -1).
2207 (let (position offset)
2208 (dolist (delta deltas)
2209 (setq position (car delta)
2210 offset (* (cdr delta) (or sgn 1)))
2213 ((integerp undo-elt)
2214 (when (>= undo-elt position)
2215 (setq undo-elt (- undo-elt offset))))
2216 ;; nil (or any other atom)
2218 ;; (TEXT . POSITION)
2219 ((stringp (car undo-elt))
2220 (let ((text-pos (abs (cdr undo-elt)))
2221 (point-at-end (< (cdr undo-elt) 0)))
2222 (if (>= text-pos position)
2223 (setcdr undo-elt (* (if point-at-end -1 1)
2224 (- text-pos offset))))))
2226 ((integerp (car undo-elt))
2227 (when (>= (car undo-elt) position)
2228 (setcar undo-elt (- (car undo-elt) offset))
2229 (setcdr undo-elt (- (cdr undo-elt) offset))))
2230 ;; (nil PROPERTY VALUE BEG . END)
2231 ((null (car undo-elt))
2232 (let ((tail (nthcdr 3 undo-elt)))
2233 (when (>= (car tail) position)
2234 (setcar tail (- (car tail) offset))
2235 (setcdr tail (- (cdr tail) offset)))))
2241 (defun undo-tree-repeated-undo-in-region-p (start end)
2242 ;; Return non-nil if undo-in-region between START and END is a repeated
2244 (let ((node (undo-tree-current buffer-undo-tree)))
2246 (nth (undo-tree-node-branch node) (undo-tree-node-next node)))
2247 (eq (undo-tree-node-undo-beginning node) start)
2248 (eq (undo-tree-node-undo-end node) end))))
2251 (defun undo-tree-repeated-redo-in-region-p (start end)
2252 ;; Return non-nil if undo-in-region between START and END is a repeated
2254 (let ((node (undo-tree-current buffer-undo-tree)))
2255 (and (eq (undo-tree-node-redo-beginning node) start)
2256 (eq (undo-tree-node-redo-end node) end))))
2259 ;; Return non-nil if undo-in-region between START and END is simply
2260 ;; reverting the last redo-in-region
2261 (defalias 'undo-tree-reverting-undo-in-region-p
2262 'undo-tree-repeated-undo-in-region-p)
2265 ;; Return non-nil if redo-in-region between START and END is simply
2266 ;; reverting the last undo-in-region
2267 (defalias 'undo-tree-reverting-redo-in-region-p
2268 'undo-tree-repeated-redo-in-region-p)
2273 ;;; =====================================================================
2274 ;;; Undo-tree commands
2277 (define-minor-mode undo-tree-mode
2278 "Toggle undo-tree mode.
2279 With no argument, this command toggles the mode.
2280 A positive prefix argument turns the mode on.
2281 A negative prefix argument turns it off.
2283 Undo-tree-mode replaces Emacs' standard undo feature with a more
2284 powerful yet easier to use version, that treats the undo history
2285 as what it is: a tree.
2287 The following keys are available in `undo-tree-mode':
2291 Within the undo-tree visualizer, the following keys are available:
2293 \\{undo-tree-visualizer-map}"
2296 undo-tree-mode-lighter ; lighter
2297 undo-tree-map ; keymap
2298 ;; if disabling `undo-tree-mode', rebuild `buffer-undo-list' from tree so
2299 ;; Emacs undo can work
2300 (unless undo-tree-mode
2301 (undo-list-rebuild-from-tree)
2302 (setq buffer-undo-tree nil)))
2305 (defun turn-on-undo-tree-mode (&optional print-message)
2306 "Enable `undo-tree-mode' in the current buffer, when appropriate.
2307 Some major modes implement their own undo system, which should
2308 not normally be overridden by `undo-tree-mode'. This command does
2309 not enable `undo-tree-mode' in such buffers. If you want to force
2310 `undo-tree-mode' to be enabled regardless, use (undo-tree-mode 1)
2313 The heuristic used to detect major modes in which
2314 `undo-tree-mode' should not be used is to check whether either
2315 the `undo' command has been remapped, or the default undo
2316 keybindings (C-/ and C-_) have been overridden somewhere other
2317 than in the global map. In addition, `undo-tree-mode' will not be
2318 enabled if the buffer's `major-mode' appears in
2319 `undo-tree-incompatible-major-modes'."
2321 (if (or (key-binding [remap undo])
2322 (undo-tree-overridden-undo-bindings-p)
2323 (memq major-mode undo-tree-incompatible-major-modes))
2325 (message "Buffer does not support undo-tree-mode;\
2326 undo-tree-mode NOT enabled"))
2327 (undo-tree-mode 1)))
2330 (defun undo-tree-overridden-undo-bindings-p ()
2331 "Returns t if default undo bindings are overridden, nil otherwise.
2332 Checks if either of the default undo key bindings (\"C-/\" or
2333 \"C-_\") are overridden in the current buffer by any keymap other
2334 than the global one. (So global redefinitions of the default undo
2335 key bindings do not count.)"
2336 (let ((binding1 (lookup-key (current-global-map) [?\C-/]))
2337 (binding2 (lookup-key (current-global-map) [?\C-_])))
2338 (global-set-key [?\C-/] 'undo)
2339 (global-set-key [?\C-_] 'undo)
2341 (or (and (key-binding [?\C-/])
2342 (not (eq (key-binding [?\C-/]) 'undo)))
2343 (and (key-binding [?\C-_])
2344 (not (eq (key-binding [?\C-_]) 'undo))))
2345 (global-set-key [?\C-/] binding1)
2346 (global-set-key [?\C-_] binding2))))
2350 (define-globalized-minor-mode global-undo-tree-mode
2351 undo-tree-mode turn-on-undo-tree-mode)
2355 (defun undo-tree-undo (&optional arg preserve-redo)
2357 Repeat this command to undo more changes.
2358 A numeric ARG serves as a repeat count.
2360 In Transient Mark mode when the mark is active, only undo changes
2361 within the current region. Similarly, when not in Transient Mark
2362 mode, just \\[universal-argument] as an argument limits undo to
2363 changes within the current region.
2365 A non-nil PRESERVE-REDO causes the existing redo record to be
2366 preserved, rather than replacing it with the new one generated by
2369 ;; throw error if undo is disabled in buffer
2370 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2372 (let ((undo-in-progress t)
2373 (undo-in-region (and undo-tree-enable-undo-in-region
2374 (or (region-active-p)
2375 (and arg (not (numberp arg))))))
2377 ;; transfer entries accumulated in `buffer-undo-list' to
2378 ;; `buffer-undo-tree'
2379 (undo-list-transfer-to-tree)
2381 (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
2382 ;; check if at top of undo tree
2383 (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
2384 (error "No further undo information"))
2386 ;; if region is active, or a non-numeric prefix argument was supplied,
2387 ;; try to pull out a new branch of changes affecting the region
2388 (when (and undo-in-region
2389 (not (undo-tree-pull-undo-in-region-branch
2390 (region-beginning) (region-end))))
2391 (error "No further undo information for region"))
2393 ;; remove any GC'd elements from node's undo list
2394 (setq current (undo-tree-current buffer-undo-tree))
2395 (decf (undo-tree-size buffer-undo-tree)
2396 (undo-list-byte-size (undo-tree-node-undo current)))
2397 (setf (undo-tree-node-undo current)
2398 (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
2399 (incf (undo-tree-size buffer-undo-tree)
2400 (undo-list-byte-size (undo-tree-node-undo current)))
2401 ;; undo one record from undo tree
2402 (when undo-in-region
2403 (setq pos (set-marker (make-marker) (point)))
2404 (set-marker-insertion-type pos t))
2405 (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current)))
2408 ;; if preserving old redo record, discard new redo entries that
2409 ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
2410 ;; elements from node's redo list
2413 (undo-list-pop-changeset)
2414 (decf (undo-tree-size buffer-undo-tree)
2415 (undo-list-byte-size (undo-tree-node-redo current)))
2416 (setf (undo-tree-node-redo current)
2417 (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
2418 (incf (undo-tree-size buffer-undo-tree)
2419 (undo-list-byte-size (undo-tree-node-redo current))))
2420 ;; otherwise, record redo entries that `primitive-undo' has added to
2421 ;; `buffer-undo-list' in current node's redo record, replacing
2422 ;; existing entry if one already exists
2423 (when (undo-tree-node-redo current)
2424 (decf (undo-tree-size buffer-undo-tree)
2425 (undo-list-byte-size (undo-tree-node-redo current))))
2426 (setf (undo-tree-node-redo current)
2427 (undo-list-pop-changeset 'discard-pos))
2428 (incf (undo-tree-size buffer-undo-tree)
2429 (undo-list-byte-size (undo-tree-node-redo current))))
2431 ;; rewind current node and update timestamp
2432 (setf (undo-tree-current buffer-undo-tree)
2433 (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
2434 (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree))
2437 ;; if undoing-in-region, record current node, region and direction so we
2438 ;; can tell if undo-in-region is repeated, and re-activate mark if in
2439 ;; `transient-mark-mode'; if not, erase any leftover data
2440 (if (not undo-in-region)
2441 (undo-tree-node-clear-region-data current)
2443 ;; note: we deliberately want to store the region information in the
2444 ;; node *below* the now current one
2445 (setf (undo-tree-node-undo-beginning current) (region-beginning)
2446 (undo-tree-node-undo-end current) (region-end))
2447 (set-marker pos nil)))
2449 ;; undo deactivates mark unless undoing-in-region
2450 (setq deactivate-mark (not undo-in-region))
2451 ;; inform user if at branch point
2452 (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))))
2456 (defun undo-tree-redo (&optional arg preserve-undo)
2457 "Redo changes. A numeric ARG serves as a repeat count.
2459 In Transient Mark mode when the mark is active, only redo changes
2460 within the current region. Similarly, when not in Transient Mark
2461 mode, just \\[universal-argument] as an argument limits redo to
2462 changes within the current region.
2464 A non-nil PRESERVE-UNDO causes the existing undo record to be
2465 preserved, rather than replacing it with the new one generated by
2468 ;; throw error if undo is disabled in buffer
2469 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2471 (let ((undo-in-progress t)
2472 (redo-in-region (and undo-tree-enable-undo-in-region
2473 (or (region-active-p)
2474 (and arg (not (numberp arg))))))
2476 ;; transfer entries accumulated in `buffer-undo-list' to
2477 ;; `buffer-undo-tree'
2478 (undo-list-transfer-to-tree)
2480 (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
2481 ;; check if at bottom of undo tree
2482 (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree)))
2483 (error "No further redo information"))
2485 ;; if region is active, or a non-numeric prefix argument was supplied,
2486 ;; try to pull out a new branch of changes affecting the region
2487 (when (and redo-in-region
2488 (not (undo-tree-pull-redo-in-region-branch
2489 (region-beginning) (region-end))))
2490 (error "No further redo information for region"))
2492 ;; advance current node
2493 (setq current (undo-tree-current buffer-undo-tree)
2494 current (setf (undo-tree-current buffer-undo-tree)
2495 (nth (undo-tree-node-branch current)
2496 (undo-tree-node-next current))))
2497 ;; remove any GC'd elements from node's redo list
2498 (decf (undo-tree-size buffer-undo-tree)
2499 (undo-list-byte-size (undo-tree-node-redo current)))
2500 (setf (undo-tree-node-redo current)
2501 (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
2502 (incf (undo-tree-size buffer-undo-tree)
2503 (undo-list-byte-size (undo-tree-node-redo current)))
2504 ;; redo one record from undo tree
2505 (when redo-in-region
2506 (setq pos (set-marker (make-marker) (point)))
2507 (set-marker-insertion-type pos t))
2508 (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current)))
2511 ;; if preserving old undo record, discard new undo entries that
2512 ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
2513 ;; elements from node's redo list
2516 (undo-list-pop-changeset)
2517 (decf (undo-tree-size buffer-undo-tree)
2518 (undo-list-byte-size (undo-tree-node-undo current)))
2519 (setf (undo-tree-node-undo current)
2520 (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
2521 (incf (undo-tree-size buffer-undo-tree)
2522 (undo-list-byte-size (undo-tree-node-undo current))))
2523 ;; otherwise, record undo entries that `primitive-undo' has added to
2524 ;; `buffer-undo-list' in current node's undo record, replacing
2525 ;; existing entry if one already exists
2526 (when (undo-tree-node-undo current)
2527 (decf (undo-tree-size buffer-undo-tree)
2528 (undo-list-byte-size (undo-tree-node-undo current))))
2529 (setf (undo-tree-node-undo current)
2530 (undo-list-pop-changeset 'discard-pos))
2531 (incf (undo-tree-size buffer-undo-tree)
2532 (undo-list-byte-size (undo-tree-node-undo current))))
2535 (setf (undo-tree-node-timestamp current) (current-time))
2537 ;; if redoing-in-region, record current node, region and direction so we
2538 ;; can tell if redo-in-region is repeated, and re-activate mark if in
2539 ;; `transient-mark-mode'
2540 (if (not redo-in-region)
2541 (undo-tree-node-clear-region-data current)
2543 (setf (undo-tree-node-redo-beginning current) (region-beginning)
2544 (undo-tree-node-redo-end current) (region-end))
2545 (set-marker pos nil)))
2547 ;; redo deactivates the mark unless redoing-in-region
2548 (setq deactivate-mark (not redo-in-region))
2549 ;; inform user if at branch point
2550 (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))))
2554 (defun undo-tree-switch-branch (branch)
2555 "Switch to a different BRANCH of the undo tree.
2556 This will affect which branch to descend when *redoing* changes
2557 using `undo-tree-redo'."
2558 (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg))
2559 (and (not (eq buffer-undo-list t))
2560 (or (undo-list-transfer-to-tree) t)
2561 (> (undo-tree-num-branches) 1)
2563 (format "Branch (0-%d): "
2564 (1- (undo-tree-num-branches))))))))
2565 ;; throw error if undo is disabled in buffer
2566 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2567 ;; sanity check branch number
2568 (when (<= (undo-tree-num-branches) 1) (error "Not at undo branch point"))
2569 (when (or (< branch 0) (> branch (1- (undo-tree-num-branches))))
2570 (error "Invalid branch number"))
2571 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2572 (undo-list-transfer-to-tree)
2574 (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
2578 (defun undo-tree-set (node)
2579 ;; Set buffer to state corresponding to NODE. Returns intersection point
2580 ;; between path back from current node and path back from selected NODE.
2581 (let ((path (make-hash-table :test 'eq))
2583 (puthash (undo-tree-root buffer-undo-tree) t path)
2584 ;; build list of nodes leading back from selected node to root, updating
2585 ;; branches as we go to point down to selected node
2588 (when (undo-tree-node-previous n)
2589 (setf (undo-tree-node-branch (undo-tree-node-previous n))
2591 n (undo-tree-node-next (undo-tree-node-previous n))))
2592 (setq n (undo-tree-node-previous n)))))
2593 ;; work backwards from current node until we intersect path back from
2595 (setq n (undo-tree-current buffer-undo-tree))
2596 (while (not (gethash n path))
2597 (setq n (undo-tree-node-previous n)))
2598 ;; ascend tree until intersection node
2599 (while (not (eq (undo-tree-current buffer-undo-tree) n))
2601 ;; descend tree until selected node
2602 (while (not (eq (undo-tree-current buffer-undo-tree) node))
2604 n)) ; return intersection node
2608 (defun undo-tree-save-state-to-register (register)
2609 "Store current undo-tree state to REGISTER.
2610 The saved state can be restored using
2611 `undo-tree-restore-state-from-register'.
2612 Argument is a character, naming the register."
2613 (interactive "cUndo-tree state to register: ")
2614 ;; throw error if undo is disabled in buffer
2615 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2616 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2617 (undo-list-transfer-to-tree)
2618 ;; save current node to REGISTER
2619 (set-register register (undo-tree-current buffer-undo-tree))
2620 ;; record REGISTER in current node, for visualizer
2621 (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree))
2626 (defun undo-tree-restore-state-from-register (register)
2627 "Restore undo-tree state from REGISTER.
2628 The state must be saved using `undo-tree-save-state-to-register'.
2629 Argument is a character, naming the register."
2630 (interactive "cRestore undo-tree state from register: ")
2631 ;; throw error if undo is disabled in buffer, or if register doesn't contain
2632 ;; an undo-tree node
2633 (let ((node (get-register register)))
2635 ((eq buffer-undo-list t)
2636 (error "No undo information in this buffer"))
2637 ((not (undo-tree-node-p node))
2638 (error "Register doesn't contain undo-tree state")))
2639 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2640 (undo-list-transfer-to-tree)
2641 ;; restore buffer state corresponding to saved node
2642 (undo-tree-set node)))
2647 ;;; =====================================================================
2648 ;;; Undo-tree visualizer
2650 (defun undo-tree-visualize ()
2651 "Visualize the current buffer's undo tree."
2654 ;; throw error if undo is disabled in buffer
2655 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2656 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2657 (undo-list-transfer-to-tree)
2658 ;; add hook to kill visualizer buffer if original buffer is changed
2659 (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t)
2660 ;; prepare *undo-tree* buffer, then draw tree in it
2661 (let ((undo-tree buffer-undo-tree)
2662 (buff (current-buffer))
2663 (display-buffer-mark-dedicated 'soft))
2664 (switch-to-buffer-other-window
2665 (get-buffer-create undo-tree-visualizer-buffer-name))
2666 (undo-tree-visualizer-mode)
2667 (setq undo-tree-visualizer-parent-buffer buff)
2668 (setq buffer-undo-tree undo-tree)
2669 (setq buffer-read-only nil)
2670 (undo-tree-draw-tree undo-tree)
2671 (setq buffer-read-only t)))
2674 (defun undo-tree-kill-visualizer (&rest dummy)
2675 ;; Kill visualizer. Added to `before-change-functions' hook of original
2676 ;; buffer when visualizer is invoked.
2677 (unless undo-in-progress
2679 (with-current-buffer undo-tree-visualizer-buffer-name
2680 (undo-tree-visualizer-quit)))))
2684 (defun undo-tree-draw-tree (undo-tree)
2685 ;; Draw UNDO-TREE in current buffer.
2687 (undo-tree-move-down 1) ; top margin
2688 (undo-tree-clear-visualizer-data undo-tree)
2689 (undo-tree-compute-widths undo-tree)
2690 (undo-tree-move-forward
2691 (max (/ (window-width) 2)
2692 (+ (undo-tree-node-char-lwidth (undo-tree-root undo-tree))
2693 ;; add space for left part of left-most time-stamp
2694 (if undo-tree-visualizer-timestamps 4 0)
2697 (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)
2698 (stack (list (undo-tree-root undo-tree)))
2699 (n (undo-tree-root undo-tree)))
2700 ;; link root node to its representation in visualizer
2701 (unless (markerp (undo-tree-node-marker n))
2702 (setf (undo-tree-node-marker n) (make-marker))
2703 (set-marker-insertion-type (undo-tree-node-marker n) nil))
2704 (move-marker (undo-tree-node-marker n) (point))
2705 ;; draw nodes from stack until stack is empty
2707 (setq n (pop stack))
2708 (goto-char (undo-tree-node-marker n))
2709 (setq n (undo-tree-draw-subtree n nil))
2710 (setq stack (append stack n))))
2711 ;; highlight active branch
2712 (goto-char (undo-tree-node-marker (undo-tree-root undo-tree)))
2713 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
2714 (undo-tree-highlight-active-branch (undo-tree-root undo-tree)))
2715 ;; highlight current node
2716 (undo-tree-draw-node (undo-tree-current undo-tree) 'current))
2719 (defun undo-tree-highlight-active-branch (node)
2720 ;; Draw highlighted active branch below NODE in current buffer.
2721 (let ((stack (list node)))
2722 ;; link node to its representation in visualizer
2723 (unless (markerp (undo-tree-node-marker node))
2724 (setf (undo-tree-node-marker node) (make-marker))
2725 (set-marker-insertion-type (undo-tree-node-marker node) nil))
2726 (move-marker (undo-tree-node-marker node) (point))
2727 ;; draw active branch
2729 (setq node (pop stack))
2730 (goto-char (undo-tree-node-marker node))
2731 (setq node (undo-tree-draw-subtree node 'active))
2732 (setq stack (append stack node)))))
2735 (defun undo-tree-draw-node (node &optional current)
2736 ;; Draw symbol representing NODE in visualizer.
2737 (goto-char (undo-tree-node-marker node))
2738 (when undo-tree-visualizer-timestamps (backward-char 5))
2740 (let ((register (undo-tree-node-register node))
2742 (unless (and register (eq node (get-register register)))
2743 (setq register nil))
2744 ;; represent node by differentl symbols, depending on whether it's the
2745 ;; current node or is saved in a register
2748 (undo-tree-visualizer-timestamps
2749 (undo-tree-timestamp-to-string (undo-tree-node-timestamp node)))
2751 (register (char-to-string register))
2753 (when undo-tree-visualizer-timestamps
2755 (concat (if current "*" " ") node-string
2756 (if register (concat "(" (char-to-string register) ")")
2761 (let ((undo-tree-insert-face
2762 (cons 'undo-tree-visualizer-current-face
2763 (and (boundp 'undo-tree-insert-face)
2764 (or (and (consp undo-tree-insert-face)
2765 undo-tree-insert-face)
2766 (list undo-tree-insert-face))))))
2767 (undo-tree-insert node-string)))
2769 (let ((undo-tree-insert-face
2770 (cons 'undo-tree-visualizer-register-face
2771 (and (boundp 'undo-tree-insert-face)
2772 (or (and (consp undo-tree-insert-face)
2773 undo-tree-insert-face)
2774 (list undo-tree-insert-face))))))
2775 (undo-tree-insert node-string)))
2776 (t (undo-tree-insert node-string)))
2778 (backward-char (if undo-tree-visualizer-timestamps 7 1))
2779 (move-marker (undo-tree-node-marker node) (point))
2780 (put-text-property (- (point) (if undo-tree-visualizer-timestamps 3 0))
2781 (+ (point) (if undo-tree-visualizer-timestamps 5 1))
2782 'undo-tree-node node)))
2785 (defun undo-tree-draw-subtree (node &optional active-branch)
2786 ;; Draw subtree rooted at NODE. The subtree will start from point.
2787 ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE.
2788 ;; If TIMESTAP is non-nil, draw time-stamps instead of "o" at nodes.
2789 (let ((num-children (length (undo-tree-node-next node)))
2790 node-list pos trunk-pos n)
2792 (undo-tree-draw-node node)
2795 ;; if we're at a leaf node, we're done
2796 ((= num-children 0))
2798 ;; if node has only one child, draw it (not strictly necessary to deal
2799 ;; with this case separately, but as it's by far the most common case
2800 ;; this makes the code clearer and more efficient)
2802 (undo-tree-move-down 1)
2803 (undo-tree-insert ?|)
2805 (undo-tree-move-down 1)
2806 (undo-tree-insert ?|)
2808 (undo-tree-move-down 1)
2809 (setq n (car (undo-tree-node-next node)))
2810 ;; link next node to its representation in visualizer
2811 (unless (markerp (undo-tree-node-marker n))
2812 (setf (undo-tree-node-marker n) (make-marker))
2813 (set-marker-insertion-type (undo-tree-node-marker n) nil))
2814 (move-marker (undo-tree-node-marker n) (point))
2815 ;; add next node to list of nodes to draw next
2818 ;; if node had multiple children, draw branches
2820 (undo-tree-move-down 1)
2821 (undo-tree-insert ?|)
2823 (setq trunk-pos (point))
2826 (- (undo-tree-node-char-lwidth node)
2827 (undo-tree-node-char-lwidth
2828 (car (undo-tree-node-next node)))))
2830 (setq n (cons nil (undo-tree-node-next node)))
2831 (dotimes (i (/ num-children 2))
2833 (when (or (null active-branch)
2835 (nth (undo-tree-node-branch node)
2836 (undo-tree-node-next node))))
2837 (undo-tree-move-forward 2)
2838 (undo-tree-insert ?_ (- trunk-pos pos 2))
2840 (undo-tree-move-forward 1)
2841 (undo-tree-move-down 1)
2842 (undo-tree-insert ?/)
2844 (undo-tree-move-down 1)
2845 ;; link node to its representation in visualizer
2846 (unless (markerp (undo-tree-node-marker (car n)))
2847 (setf (undo-tree-node-marker (car n)) (make-marker))
2848 (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
2849 (move-marker (undo-tree-node-marker (car n)) (point))
2850 ;; add node to list of nodes to draw next
2851 (push (car n) node-list))
2853 (undo-tree-move-forward
2854 (+ (undo-tree-node-char-rwidth (car n))
2855 (undo-tree-node-char-lwidth (cadr n))
2856 undo-tree-visualizer-spacing 1))
2858 ;; middle subtree (only when number of children is odd)
2859 (when (= (mod num-children 2) 1)
2861 (when (or (null active-branch)
2863 (nth (undo-tree-node-branch node)
2864 (undo-tree-node-next node))))
2865 (undo-tree-move-down 1)
2866 (undo-tree-insert ?|)
2868 (undo-tree-move-down 1)
2869 ;; link node to its representation in visualizer
2870 (unless (markerp (undo-tree-node-marker (car n)))
2871 (setf (undo-tree-node-marker (car n)) (make-marker))
2872 (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
2873 (move-marker (undo-tree-node-marker (car n)) (point))
2874 ;; add node to list of nodes to draw next
2875 (push (car n) node-list))
2877 (undo-tree-move-forward
2878 (+ (undo-tree-node-char-rwidth (car n))
2879 (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
2880 undo-tree-visualizer-spacing 1))
2884 (dotimes (i (/ num-children 2))
2886 (when (or (null active-branch)
2888 (nth (undo-tree-node-branch node)
2889 (undo-tree-node-next node))))
2890 (goto-char trunk-pos)
2891 (undo-tree-insert ?_ (- pos trunk-pos 1))
2894 (undo-tree-move-down 1)
2895 (undo-tree-insert ?\\)
2896 (undo-tree-move-down 1)
2897 ;; link node to its representation in visualizer
2898 (unless (markerp (undo-tree-node-marker (car n)))
2899 (setf (undo-tree-node-marker (car n)) (make-marker))
2900 (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
2901 (move-marker (undo-tree-node-marker (car n)) (point))
2902 ;; add node to list of nodes to draw next
2903 (push (car n) node-list))
2906 (undo-tree-move-forward
2907 (+ (undo-tree-node-char-rwidth (car n))
2908 (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
2909 undo-tree-visualizer-spacing 1))
2910 (setq pos (point))))
2912 ;; return list of nodes to draw next
2913 (nreverse node-list)))
2917 (defun undo-tree-node-char-lwidth (node)
2918 ;; Return left-width of NODE measured in characters.
2919 (if (= (length (undo-tree-node-next node)) 0) 0
2920 (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node))
2921 (if (= (undo-tree-node-cwidth node) 0)
2922 (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
2925 (defun undo-tree-node-char-rwidth (node)
2926 ;; Return right-width of NODE measured in characters.
2927 (if (= (length (undo-tree-node-next node)) 0) 0
2928 (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node))
2929 (if (= (undo-tree-node-cwidth node) 0)
2930 (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
2933 (defun undo-tree-insert (str &optional arg)
2934 ;; Insert character or string STR ARG times, overwriting, and using
2935 ;; `undo-tree-insert-face'.
2936 (unless arg (setq arg 1))
2937 (when (characterp str)
2938 (setq str (make-string arg str))
2940 (dotimes (i arg) (insert str))
2941 (setq arg (* arg (length str)))
2942 (undo-tree-move-forward arg)
2943 ;; make sure mark isn't active, otherwise `backward-delete-char' might
2944 ;; delete region instead of single char if transient-mark-mode is enabled
2945 (setq mark-active nil)
2946 (backward-delete-char arg)
2947 (when (boundp 'undo-tree-insert-face)
2948 (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face)))
2951 (defun undo-tree-move-down (&optional arg)
2952 ;; Move down, extending buffer if necessary.
2953 (let ((row (line-number-at-pos))
2954 (col (current-column))
2956 (unless arg (setq arg 1))
2958 (setq line (line-number-at-pos))
2959 ;; if buffer doesn't have enough lines, add some
2960 (when (/= line (+ row arg))
2961 (insert (make-string (- arg (- line row)) ?\n)))
2962 (undo-tree-move-forward col)))
2965 (defun undo-tree-move-forward (&optional arg)
2966 ;; Move forward, extending buffer if necessary.
2967 (unless arg (setq arg 1))
2968 (let ((n (- (line-end-position) (point))))
2972 (insert (make-string (- arg n) ? )))))
2975 (defun undo-tree-timestamp-to-string (timestamp)
2976 ;; Convert TIMESTAMP to hh:mm:ss string.
2977 (let ((time (decode-time timestamp)))
2978 (format "%02d:%02d:%02d" (nth 2 time) (nth 1 time) (nth 0 time))))
2983 ;;; =====================================================================
2984 ;;; Visualizer mode commands
2986 (defun undo-tree-visualizer-mode ()
2987 "Major mode used in undo-tree visualizer.
2989 The undo-tree visualizer can only be invoked from a buffer in
2990 which `undo-tree-mode' is enabled. The visualizer displays the
2991 undo history tree graphically, and allows you to browse around
2992 the undo history, undoing or redoing the corresponding changes in
2995 Within the undo-tree visualizer, the following keys are available:
2997 \\{undo-tree-visualizer-map}"
2999 (setq major-mode 'undo-tree-visualizer-mode)
3000 (setq mode-name "undo-tree-visualizer-mode")
3001 (use-local-map undo-tree-visualizer-map)
3002 (setq truncate-lines t)
3003 (setq cursor-type nil)
3004 (setq buffer-read-only t))
3008 (defun undo-tree-visualize-undo (&optional arg)
3009 "Undo changes. A numeric ARG serves as a repeat count."
3011 (setq buffer-read-only nil)
3012 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
3013 (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
3014 (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
3017 (undo-tree-undo arg)
3018 (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
3019 (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
3020 (setq buffer-read-only t)))
3023 (defun undo-tree-visualize-redo (&optional arg)
3024 "Redo changes. A numeric ARG serves as a repeat count."
3026 (setq buffer-read-only nil)
3027 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
3028 (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
3029 (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
3032 (undo-tree-redo arg)
3033 (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
3034 (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3035 (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
3036 (setq buffer-read-only t)))
3039 (defun undo-tree-visualize-switch-branch-right (arg)
3040 "Switch to next branch of the undo tree.
3041 This will affect which branch to descend when *redoing* changes
3042 using `undo-tree-redo' or `undo-tree-visualizer-redo'."
3044 ;; un-highlight old active branch below current node
3045 (setq buffer-read-only nil)
3046 (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3047 (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face))
3048 (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
3050 (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree))))
3051 (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
3053 ((>= (+ branch arg) (undo-tree-num-branches))
3054 (1- (undo-tree-num-branches)))
3055 ((<= (+ branch arg) 0) 0)
3056 (t (+ branch arg))))
3057 ;; highlight new active branch below current node
3058 (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3059 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
3060 (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
3061 ;; re-highlight current node
3062 (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
3063 (setq buffer-read-only t)))
3066 (defun undo-tree-visualize-switch-branch-left (arg)
3067 "Switch to previous branch of the undo tree.
3068 This will affect which branch to descend when *redoing* changes
3069 using `undo-tree-redo' or `undo-tree-visualizer-redo'."
3071 (undo-tree-visualize-switch-branch-right (- arg)))
3074 (defun undo-tree-visualizer-quit ()
3075 "Quit the undo-tree visualizer."
3077 (undo-tree-clear-visualizer-data buffer-undo-tree)
3078 ;; remove kill visualizer hook from parent buffer
3080 (with-current-buffer undo-tree-visualizer-parent-buffer
3081 (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t))
3082 (let ((parent undo-tree-visualizer-parent-buffer)
3085 (if (setq window (get-buffer-window parent))
3086 (select-window window)
3087 (switch-to-buffer parent)))))
3090 (defun undo-tree-visualizer-set (&optional pos)
3091 "Set buffer to state corresponding to undo tree node
3092 at POS, or point if POS is nil."
3094 (unless pos (setq pos (point)))
3095 (let ((node (get-text-property pos 'undo-tree-node)))
3097 ;; set parent buffer to state corresponding to node at POS
3098 (set-buffer undo-tree-visualizer-parent-buffer)
3099 (undo-tree-set node)
3100 (set-buffer undo-tree-visualizer-buffer-name)
3101 (setq buffer-read-only nil)
3102 ;; re-draw undo tree
3103 (undo-tree-draw-tree buffer-undo-tree)
3104 (setq buffer-read-only t))))
3107 (defun undo-tree-visualizer-mouse-set (pos)
3108 "Set buffer to state corresponding to undo tree node
3109 at mouse event POS."
3111 (undo-tree-visualizer-set (event-start (nth 1 pos))))
3114 (defun undo-tree-visualizer-toggle-timestamps ()
3115 "Toggle display of time-stamps."
3117 (setq undo-tree-visualizer-spacing
3118 (if (setq undo-tree-visualizer-timestamps
3119 (not undo-tree-visualizer-timestamps))
3120 ;; need sufficient space if displaying timestamps
3121 (max 13 (default-value 'undo-tree-visualizer-spacing))
3122 (default-value 'undo-tree-visualizer-spacing)))
3124 (setq buffer-read-only nil)
3125 (undo-tree-draw-tree buffer-undo-tree)
3126 (setq buffer-read-only t))
3129 (defun undo-tree-visualizer-scroll-left (&optional arg)
3131 (scroll-right (or arg 1) t))
3134 (defun undo-tree-visualizer-scroll-right (&optional arg)
3136 (scroll-left (or arg 1) t))
3141 ;;; =====================================================================
3142 ;;; Visualizer selection mode
3144 (defun undo-tree-visualizer-selection-mode ()
3145 "Major mode used to select nodes in undo-tree visualizer."
3147 (setq major-mode 'undo-tree-visualizer-selection-mode)
3148 (setq mode-name "undo-tree-visualizer-selection-mode")
3149 (use-local-map undo-tree-visualizer-selection-map)
3150 (setq cursor-type 'box))
3153 (defun undo-tree-visualizer-select-previous (&optional arg)
3154 "Move to previous node."
3156 (let ((node (get-text-property (point) 'undo-tree-node)))
3159 (unless (undo-tree-node-previous node) (throw 'top t))
3160 (setq node (undo-tree-node-previous node))))
3161 (goto-char (undo-tree-node-marker node))))
3164 (defun undo-tree-visualizer-select-next (&optional arg)
3165 "Move to next node."
3167 (let ((node (get-text-property (point) 'undo-tree-node)))
3170 (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node))
3173 (nth (undo-tree-node-branch node) (undo-tree-node-next node)))))
3174 (goto-char (undo-tree-node-marker node))))
3177 (defun undo-tree-visualizer-select-right (&optional arg)
3178 "Move right to a sibling node."
3181 (end (line-end-position))
3187 (setq node (get-text-property (point) 'undo-tree-node))
3188 (when (= (point) end) (throw 'end t)))))
3189 (goto-char (if node (undo-tree-node-marker node) pos))))
3192 (defun undo-tree-visualizer-select-left (&optional arg)
3193 "Move left to a sibling node."
3196 (beg (line-beginning-position))
3202 (setq node (get-text-property (point) 'undo-tree-node))
3203 (when (= (point) beg) (throw 'beg t)))))
3204 (goto-char (if node (undo-tree-node-marker node) pos))))
3208 (provide 'undo-tree)
3210 ;;; undo-tree.el ends here