mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-17 c4001ccd1864293b64aa37d83a9d9457eb875e70
commit | author | age
5cb5f7 1 ;;; undo-tree.el --- Treat undo history as a tree  -*- lexical-binding: t; -*-
C 2
3 ;; Copyright (C) 2009-2013  Free Software Foundation, Inc
4
5 ;; Author: Toby Cubitt <toby-undo-tree@dr-qubit.org>
6 ;; Version: 0.6.5
7 ;; Keywords: convenience, files, undo, redo, history, tree
8 ;; URL: http://www.dr-qubit.org/emacs.php
9 ;; Repository: http://www.dr-qubit.org/git/undo-tree.git
10
11 ;; This file is part of Emacs.
12 ;;
13 ;; This file is free software: you can redistribute it and/or modify it under
14 ;; the terms of the GNU General Public License as published by the Free
15 ;; Software Foundation, either version 3 of the License, or (at your option)
16 ;; any later version.
17 ;;
18 ;; This program is distributed in the hope that it will be useful, but WITHOUT
19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
20 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
21 ;; more details.
22 ;;
23 ;; You should have received a copy of the GNU General Public License along
24 ;; with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
25
26
27 ;;; Commentary:
28 ;;
29 ;; Emacs has a powerful undo system. Unlike the standard undo/redo system in
30 ;; most software, it allows you to recover *any* past state of a buffer
31 ;; (whereas the standard undo/redo system can lose past states as soon as you
32 ;; redo). However, this power comes at a price: many people find Emacs' undo
33 ;; system confusing and difficult to use, spawning a number of packages that
34 ;; replace it with the less powerful but more intuitive undo/redo system.
35 ;;
36 ;; Both the loss of data with standard undo/redo, and the confusion of Emacs'
37 ;; undo, stem from trying to treat undo history as a linear sequence of
38 ;; changes. It's not. The `undo-tree-mode' provided by this package replaces
39 ;; Emacs' undo system with a system that treats undo history as what it is: a
40 ;; branching tree of changes. This simple idea allows the more intuitive
41 ;; behaviour of the standard undo/redo system to be combined with the power of
42 ;; never losing any history. An added side bonus is that undo history can in
43 ;; some cases be stored more efficiently, allowing more changes to accumulate
44 ;; before Emacs starts discarding history.
45 ;;
46 ;; The only downside to this more advanced yet simpler undo system is that it
47 ;; was inspired by Vim. But, after all, most successful religions steal the
48 ;; best ideas from their competitors!
49 ;;
50 ;;
51 ;; Installation
52 ;; ============
53 ;;
54 ;; This package has only been tested with Emacs versions 24 and CVS. It should
55 ;; work in Emacs versions 22 and 23 too, but will not work without
56 ;; modifications in earlier versions of Emacs.
57 ;;
58 ;; To install `undo-tree-mode', make sure this file is saved in a directory in
59 ;; your `load-path', and add the line:
60 ;;
61 ;;   (require 'undo-tree)
62 ;;
63 ;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using
64 ;; "M-x byte-compile-file" from within emacs).
65 ;;
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
68 ;; adding:
69 ;;
70 ;;   (global-undo-tree-mode)
71 ;;
72 ;; to your .emacs file.
73 ;;
74 ;;
75 ;; Quick-Start
76 ;; ===========
77 ;;
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:
82 ;;
83 ;; `undo-tree-mode' and `global-undo-tree-mode'
84 ;;   Enable undo-tree mode (either in the current buffer or globally).
85 ;;
86 ;; C-_  C-/  (`undo-tree-undo')
87 ;;   Undo changes.
88 ;;
89 ;; M-_  C-?  (`undo-tree-redo')
90 ;;   Redo changes.
91 ;;
92 ;; `undo-tree-switch-branch'
93 ;;   Switch undo-tree branch.
94 ;;   (What does this mean? Better press the button and see!)
95 ;;
96 ;; C-x u  (`undo-tree-visualize')
97 ;;   Visualize the undo tree.
98 ;;   (Better try pressing this button too!)
99 ;;
100 ;; C-x r u  (`undo-tree-save-state-to-register')
101 ;;   Save current buffer state to register.
102 ;;
103 ;; C-x r U  (`undo-tree-restore-state-from-register')
104 ;;   Restore buffer state from register.
105 ;;
106 ;;
107 ;;
108 ;; In the undo-tree visualizer:
109 ;;
110 ;; <up>  p  C-p  (`undo-tree-visualize-undo')
111 ;;   Undo changes.
112 ;;
113 ;; <down>  n  C-n  (`undo-tree-visualize-redo')
114 ;;   Redo changes.
115 ;;
116 ;; <left>  b  C-b  (`undo-tree-visualize-switch-branch-left')
117 ;;   Switch to previous undo-tree branch.
118 ;;
119 ;; <right>  f  C-f  (`undo-tree-visualize-switch-branch-right')
120 ;;   Switch to next undo-tree branch.
121 ;;
122 ;; C-<up>  M-{  (`undo-tree-visualize-undo-to-x')
123 ;;   Undo changes up to last branch point.
124 ;;
125 ;; C-<down>  M-}  (`undo-tree-visualize-redo-to-x')
126 ;;   Redo changes down to next branch point.
127 ;;
128 ;; <down>  n  C-n  (`undo-tree-visualize-redo')
129 ;;   Redo changes.
130 ;;
131 ;; <mouse-1>  (`undo-tree-visualizer-mouse-set')
132 ;;   Set state to node at mouse click.
133 ;;
134 ;; t  (`undo-tree-visualizer-toggle-timestamps')
135 ;;   Toggle display of time-stamps.
136 ;;
137 ;; d  (`undo-tree-visualizer-toggle-diff')
138 ;;   Toggle diff display.
139 ;;
140 ;; s  (`undo-tree-visualizer-selection-mode')
141 ;;   Toggle keyboard selection mode.
142 ;;
143 ;; q  (`undo-tree-visualizer-quit')
144 ;;   Quit undo-tree-visualizer.
145 ;;
146 ;; C-q  (`undo-tree-visualizer-abort')
147 ;;   Abort undo-tree-visualizer.
148 ;;
149 ;; ,  <
150 ;;   Scroll left.
151 ;;
152 ;; .  >
153 ;;   Scroll right.
154 ;;
155 ;; <pgup>  M-v
156 ;;   Scroll up.
157 ;;
158 ;; <pgdown>  C-v
159 ;;   Scroll down.
160 ;;
161 ;;
162 ;;
163 ;; In visualizer selection mode:
164 ;;
165 ;; <up>  p  C-p  (`undo-tree-visualizer-select-previous')
166 ;;   Select previous node.
167 ;;
168 ;; <down>  n  C-n  (`undo-tree-visualizer-select-next')
169 ;;   Select next node.
170 ;;
171 ;; <left>  b  C-b  (`undo-tree-visualizer-select-left')
172 ;;   Select left sibling node.
173 ;;
174 ;; <right>  f  C-f  (`undo-tree-visualizer-select-right')
175 ;;   Select right sibling node.
176 ;;
177 ;; <pgup>  M-v
178 ;;   Select node 10 above.
179 ;;
180 ;; <pgdown>  C-v
181 ;;   Select node 10 below.
182 ;;
183 ;; <enter>  (`undo-tree-visualizer-set')
184 ;;   Set state to selected node and exit selection mode.
185 ;;
186 ;; s  (`undo-tree-visualizer-mode')
187 ;;   Exit selection mode.
188 ;;
189 ;; t  (`undo-tree-visualizer-toggle-timestamps')
190 ;;   Toggle display of time-stamps.
191 ;;
192 ;; d  (`undo-tree-visualizer-toggle-diff')
193 ;;   Toggle diff display.
194 ;;
195 ;; q  (`undo-tree-visualizer-quit')
196 ;;   Quit undo-tree-visualizer.
197 ;;
198 ;; C-q  (`undo-tree-visualizer-abort')
199 ;;   Abort undo-tree-visualizer.
200 ;;
201 ;; ,  <
202 ;;   Scroll left.
203 ;;
204 ;; .  >
205 ;;   Scroll right.
206 ;;
207 ;;
208 ;;
209 ;; Persistent undo history:
210 ;;
211 ;; Note: Requires Emacs version 24.3 or higher.
212 ;;
213 ;; `undo-tree-auto-save-history' (variable)
214 ;;    automatically save and restore undo-tree history along with buffer
215 ;;    (disabled by default)
216 ;;
217 ;; `undo-tree-save-history' (command)
218 ;;    manually save undo history to file
219 ;;
220 ;; `undo-tree-load-history' (command)
221 ;;    manually load undo history from file
222 ;;
223 ;;
224 ;;
225 ;; Compressing undo history:
226 ;;
227 ;;   Undo history files cannot grow beyond the maximum undo tree size, which
228 ;;   is limited by `undo-limit', `undo-strong-limit' and
229 ;;   `undo-outer-limit'. Nevertheless, undo history files can grow quite
230 ;;   large. If you want to automatically compress undo history, add the
231 ;;   following advice to your .emacs file (replacing ".gz" with the filename
232 ;;   extension of your favourite compression algorithm):
233 ;;
234 ;;   (defadvice undo-tree-make-history-save-file-name
235 ;;     (after undo-tree activate)
236 ;;     (setq ad-return-value (concat ad-return-value ".gz")))
237 ;;
238 ;;
239 ;;
240 ;;
241 ;; Undo Systems
242 ;; ============
243 ;;
244 ;; To understand the different undo systems, it's easiest to consider an
245 ;; example. Imagine you make a few edits in a buffer. As you edit, you
246 ;; accumulate a history of changes, which we might visualize as a string of
247 ;; past buffer states, growing downwards:
248 ;;
249 ;;                                o  (initial buffer state)
250 ;;                                |
251 ;;                                |
252 ;;                                o  (first edit)
253 ;;                                |
254 ;;                                |
255 ;;                                o  (second edit)
256 ;;                                |
257 ;;                                |
258 ;;                                x  (current buffer state)
259 ;;
260 ;;
261 ;; Now imagine that you undo the last two changes. We can visualize this as
262 ;; rewinding the current state back two steps:
263 ;;
264 ;;                                o  (initial buffer state)
265 ;;                                |
266 ;;                                |
267 ;;                                x  (current buffer state)
268 ;;                                |
269 ;;                                |
270 ;;                                o
271 ;;                                |
272 ;;                                |
273 ;;                                o
274 ;;
275 ;;
276 ;; However, this isn't a good representation of what Emacs' undo system
277 ;; does. Instead, it treats the undos as *new* changes to the buffer, and adds
278 ;; them to the history:
279 ;;
280 ;;                                o  (initial buffer state)
281 ;;                                |
282 ;;                                |
283 ;;                                o  (first edit)
284 ;;                                |
285 ;;                                |
286 ;;                                o  (second edit)
287 ;;                                |
288 ;;                                |
289 ;;                                x  (buffer state before undo)
290 ;;                                |
291 ;;                                |
292 ;;                                o  (first undo)
293 ;;                                |
294 ;;                                |
295 ;;                                x  (second undo)
296 ;;
297 ;;
298 ;; Actually, since the buffer returns to a previous state after an undo,
299 ;; perhaps a better way to visualize it is to imagine the string of changes
300 ;; turning back on itself:
301 ;;
302 ;;        (initial buffer state)  o
303 ;;                                |
304 ;;                                |
305 ;;                  (first edit)  o  x  (second undo)
306 ;;                                |  |
307 ;;                                |  |
308 ;;                 (second edit)  o  o  (first undo)
309 ;;                                | /
310 ;;                                |/
311 ;;                                o  (buffer state before undo)
312 ;;
313 ;; Treating undos as new changes might seem a strange thing to do. But the
314 ;; advantage becomes clear as soon as we imagine what happens when you edit
315 ;; the buffer again. Since you've undone a couple of changes, new edits will
316 ;; branch off from the buffer state that you've rewound to. Conceptually, it
317 ;; looks like this:
318 ;;
319 ;;                                o  (initial buffer state)
320 ;;                                |
321 ;;                                |
322 ;;                                o
323 ;;                                |\
324 ;;                                | \
325 ;;                                o  x  (new edit)
326 ;;                                |
327 ;;                                |
328 ;;                                o
329 ;;
330 ;; The standard undo/redo system only lets you go backwards and forwards
331 ;; linearly. So as soon as you make that new edit, it discards the old
332 ;; branch. Emacs' undo just keeps adding changes to the end of the string. So
333 ;; the undo history in the two systems now looks like this:
334 ;;
335 ;;            Undo/Redo:                      Emacs' undo
336 ;;
337 ;;               o                                o
338 ;;               |                                |
339 ;;               |                                |
340 ;;               o                                o  o
341 ;;               .\                               |  |\
342 ;;               . \                              |  | \
343 ;;               .  x  (new edit)                 o  o  |
344 ;;   (discarded  .                                | /   |
345 ;;     branch)   .                                |/    |
346 ;;               .                                o     |
347 ;;                                                      |
348 ;;                                                      |
349 ;;                                                      x  (new edit)
350 ;;
351 ;; Now, what if you change your mind about those undos, and decide you did
352 ;; like those other changes you'd made after all? With the standard undo/redo
353 ;; system, you're lost. There's no way to recover them, because that branch
354 ;; was discarded when you made the new edit.
355 ;;
356 ;; However, in Emacs' undo system, those old buffer states are still there in
357 ;; the undo history. You just have to rewind back through the new edit, and
358 ;; back through the changes made by the undos, until you reach them. Of
359 ;; course, since Emacs treats undos (even undos of undos!) as new changes,
360 ;; you're really weaving backwards and forwards through the history, all the
361 ;; time adding new changes to the end of the string as you go:
362 ;;
363 ;;                       o
364 ;;                       |
365 ;;                       |
366 ;;                       o  o     o  (undo new edit)
367 ;;                       |  |\    |\
368 ;;                       |  | \   | \
369 ;;                       o  o  |  |  o  (undo the undo)
370 ;;                       | /   |  |  |
371 ;;                       |/    |  |  |
372 ;;      (trying to get   o     |  |  x  (undo the undo)
373 ;;       to this state)        | /
374 ;;                             |/
375 ;;                             o
376 ;;
377 ;; So far, this is still reasonably intuitive to use. It doesn't behave so
378 ;; differently to standard undo/redo, except that by going back far enough you
379 ;; can access changes that would be lost in standard undo/redo.
380 ;;
381 ;; However, imagine that after undoing as just described, you decide you
382 ;; actually want to rewind right back to the initial state. If you're lucky,
383 ;; and haven't invoked any command since the last undo, you can just keep on
384 ;; undoing until you get back to the start:
385 ;;
386 ;;      (trying to get   o              x  (got there!)
387 ;;       to this state)  |              |
388 ;;                       |              |
389 ;;                       o  o     o     o  (keep undoing)
390 ;;                       |  |\    |\    |
391 ;;                       |  | \   | \   |
392 ;;                       o  o  |  |  o  o  (keep undoing)
393 ;;                       | /   |  |  | /
394 ;;                       |/    |  |  |/
395 ;;      (already undid   o     |  |  o  (got this far)
396 ;;       to this state)        | /
397 ;;                             |/
398 ;;                             o
399 ;;
400 ;; But if you're unlucky, and you happen to have moved the point (say) after
401 ;; getting to the state labelled "got this far", then you've "broken the undo
402 ;; chain". Hold on to something solid, because things are about to get
403 ;; hairy. If you try to undo now, Emacs thinks you're trying to undo the
404 ;; undos! So to get back to the initial state you now have to rewind through
405 ;; *all* the changes, including the undos you just did:
406 ;;
407 ;;      (trying to get   o                          x  (finally got there!)
408 ;;       to this state)  |                          |
409 ;;                       |                          |
410 ;;                       o  o     o     o     o     o
411 ;;                       |  |\    |\    |\    |\    |
412 ;;                       |  | \   | \   | \   | \   |
413 ;;                       o  o  |  |  o  o  o  |  o  o
414 ;;                       | /   |  |  | /   |  |  | /
415 ;;                       |/    |  |  |/    |  |  |/
416 ;;      (already undid   o     |  |  o<.   |  |  o
417 ;;       to this state)        | /     :   | /
418 ;;                             |/      :   |/
419 ;;                             o       :   o
420 ;;                                     :
421 ;;                             (got this far, but
422 ;;                              broke the undo chain)
423 ;;
424 ;; Confused?
425 ;;
426 ;; In practice you can just hold down the undo key until you reach the buffer
427 ;; state that you want. But whatever you do, don't move around in the buffer
428 ;; to *check* that you've got back to where you want! Because you'll break the
429 ;; undo chain, and then you'll have to traverse the entire string of undos
430 ;; again, just to get back to the point at which you broke the
431 ;; chain. Undo-in-region and commands such as `undo-only' help to make using
432 ;; Emacs' undo a little easier, but nonetheless it remains confusing for many
433 ;; people.
434 ;;
435 ;;
436 ;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent
437 ;; the history we've been discussing (make a few edits, undo a couple of them,
438 ;; and edit again)? The diagram that conceptually represented our undo
439 ;; history, before we started discussing specific undo systems? It looked like
440 ;; this:
441 ;;
442 ;;                                o  (initial buffer state)
443 ;;                                |
444 ;;                                |
445 ;;                                o
446 ;;                                |\
447 ;;                                | \
448 ;;                                o  x  (current state)
449 ;;                                |
450 ;;                                |
451 ;;                                o
452 ;;
453 ;; Well, that's *exactly* what the undo history looks like to
454 ;; `undo-tree-mode'.  It doesn't discard the old branch (as standard undo/redo
455 ;; does), nor does it treat undos as new changes to be added to the end of a
456 ;; linear string of buffer states (as Emacs' undo does). It just keeps track
457 ;; of the tree of branching changes that make up the entire undo history.
458 ;;
459 ;; If you undo from this point, you'll rewind back up the tree to the previous
460 ;; state:
461 ;;
462 ;;                                o
463 ;;                                |
464 ;;                                |
465 ;;                                x  (undo)
466 ;;                                |\
467 ;;                                | \
468 ;;                                o  o
469 ;;                                |
470 ;;                                |
471 ;;                                o
472 ;;
473 ;; If you were to undo again, you'd rewind back to the initial state. If on
474 ;; the other hand you redo the change, you'll end up back at the bottom of the
475 ;; most recent branch:
476 ;;
477 ;;                                o  (undo takes you here)
478 ;;                                |
479 ;;                                |
480 ;;                                o  (start here)
481 ;;                                |\
482 ;;                                | \
483 ;;                                o  x  (redo takes you here)
484 ;;                                |
485 ;;                                |
486 ;;                                o
487 ;;
488 ;; So far, this is just like the standard undo/redo system. But what if you
489 ;; want to return to a buffer state located on a previous branch of the
490 ;; history? Since `undo-tree-mode' keeps the entire history, you simply need
491 ;; to tell it to switch to a different branch, and then redo the changes you
492 ;; want:
493 ;;
494 ;;                                o
495 ;;                                |
496 ;;                                |
497 ;;                                o  (start here, but switch
498 ;;                                |\  to the other branch)
499 ;;                                | \
500 ;;                        (redo)  o  o
501 ;;                                |
502 ;;                                |
503 ;;                        (redo)  x
504 ;;
505 ;; Now you're on the other branch, if you undo and redo changes you'll stay on
506 ;; that branch, moving up and down through the buffer states located on that
507 ;; branch. Until you decide to switch branches again, of course.
508 ;;
509 ;; Real undo trees might have multiple branches and sub-branches:
510 ;;
511 ;;                                o
512 ;;                            ____|______
513 ;;                           /           \
514 ;;                          o             o
515 ;;                      ____|__         __|
516 ;;                     /    |  \       /   \
517 ;;                    o     o   o     o     x
518 ;;                    |               |
519 ;;                   / \             / \
520 ;;                  o   o           o   o
521 ;;
522 ;; Trying to imagine what Emacs' undo would do as you move about such a tree
523 ;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're
524 ;; just moving around this undo history tree. Most of the time, you'll
525 ;; probably only need to stay on the most recent branch, in which case it
526 ;; behaves like standard undo/redo, and is just as simple to understand. But
527 ;; if you ever need to recover a buffer state on a different branch, the
528 ;; possibility of switching between branches and accessing the full undo
529 ;; history is still there.
530 ;;
531 ;;
532 ;;
533 ;; The Undo-Tree Visualizer
534 ;; ========================
535 ;;
536 ;; Actually, it gets better. You don't have to imagine all these tree
537 ;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which
538 ;; draws them for you! In fact, it draws even better diagrams: it highlights
539 ;; the node representing the current buffer state, it highlights the current
540 ;; branch, and you can toggle the display of time-stamps (by hitting "t") and
541 ;; a diff of the undo changes (by hitting "d"). (There's one other tiny
542 ;; difference: the visualizer puts the most recent branch on the left rather
543 ;; than the right.)
544 ;;
545 ;; Bring up the undo tree visualizer whenever you want by hitting "C-x u".
546 ;;
547 ;; In the visualizer, the usual keys for moving up and down a buffer instead
548 ;; move up and down the undo history tree (e.g. the up and down arrow keys, or
549 ;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo
550 ;; history you are visualizing) is updated as you move around the undo tree in
551 ;; the visualizer. If you reach a branch point in the visualizer, the usual
552 ;; keys for moving forward and backward in a buffer instead switch branch
553 ;; (e.g. the left and right arrow keys, or "C-f" and "C-b").
554 ;;
555 ;; Clicking with the mouse on any node in the visualizer will take you
556 ;; directly to that node, resetting the state of the parent buffer to the
557 ;; state represented by that node.
558 ;;
559 ;; You can also select nodes directly using the keyboard, by hitting "s" to
560 ;; toggle selection mode. The usual motion keys now allow you to move around
561 ;; the tree without changing the parent buffer. Hitting <enter> will reset the
562 ;; state of the parent buffer to the state represented by the currently
563 ;; selected node.
564 ;;
565 ;; It can be useful to see how long ago the parent buffer was in the state
566 ;; represented by a particular node in the visualizer. Hitting "t" in the
567 ;; visualizer toggles the display of time-stamps for all the nodes. (Note
568 ;; that, because of the way `undo-tree-mode' works, these time-stamps may be
569 ;; somewhat later than the true times, especially if it's been a long time
570 ;; since you last undid any changes.)
571 ;;
572 ;; To get some idea of what changes are represented by a given node in the
573 ;; tree, it can be useful to see a diff of the changes. Hit "d" in the
574 ;; visualizer to toggle a diff display. This normally displays a diff between
575 ;; the current state and the previous one, i.e. it shows you the changes that
576 ;; will be applied if you undo (move up the tree). However, the diff display
577 ;; really comes into its own in the visualizer's selection mode (see above),
578 ;; where it instead shows a diff between the current state and the currently
579 ;; selected state, i.e. it shows you the changes that will be applied if you
580 ;; reset to the selected state.
581 ;;
582 ;; (Note that the diff is generated by the Emacs `diff' command, and is
583 ;; displayed using `diff-mode'. See the corresponding customization groups if
584 ;; you want to customize the diff display.)
585 ;;
586 ;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in
587 ;; whatever state you ended at. Hitting "C-q" will abort the visualizer,
588 ;; returning the parent buffer to whatever state it was originally in when the
589 ;; visualizer was .
590 ;;
591 ;;
592 ;;
593 ;; Undo-in-Region
594 ;; ==============
595 ;;
596 ;; Emacs allows a very useful and powerful method of undoing only selected
597 ;; changes: when a region is active, only changes that affect the text within
598 ;; that region will be undone. With the standard Emacs undo system, changes
599 ;; produced by undoing-in-region naturally get added onto the end of the
600 ;; linear undo history:
601 ;;
602 ;;                       o
603 ;;                       |
604 ;;                       |  x  (second undo-in-region)
605 ;;                       o  |
606 ;;                       |  |
607 ;;                       |  o  (first undo-in-region)
608 ;;                       o  |
609 ;;                       | /
610 ;;                       |/
611 ;;                       o
612 ;;
613 ;; You can of course redo these undos-in-region as usual, by undoing the
614 ;; undos:
615 ;;
616 ;;                       o
617 ;;                       |
618 ;;                       |  o_
619 ;;                       o  | \
620 ;;                       |  |  |
621 ;;                       |  o  o  (undo the undo-in-region)
622 ;;                       o  |  |
623 ;;                       | /   |
624 ;;                       |/    |
625 ;;                       o     x  (undo the undo-in-region)
626 ;;
627 ;;
628 ;; In `undo-tree-mode', undo-in-region works similarly: when there's an active
629 ;; region, undoing only undoes changes that affect that region. However, the
630 ;; way these undos-in-region are recorded in the undo history is quite
631 ;; different. In `undo-tree-mode', undo-in-region creates a new branch in the
632 ;; undo history. The new branch consists of an undo step that undoes some of
633 ;; the changes that affect the current region, and another step that undoes
634 ;; the remaining changes needed to rejoin the previous undo history.
635 ;;
636 ;;      Previous undo history                Undo-in-region
637 ;;
638 ;;               o                                o
639 ;;               |                                |
640 ;;               |                                |
641 ;;               o                                o
642 ;;               |                                |\
643 ;;               |                                | \
644 ;;               o                                o  x  (undo-in-region)
645 ;;               |                                |  |
646 ;;               |                                |  |
647 ;;               x                                o  o
648 ;;
649 ;; As long as you don't change the active region after undoing-in-region,
650 ;; continuing to undo-in-region extends the new branch, pulling more changes
651 ;; that affect the current region into an undo step immediately above your
652 ;; current location in the undo tree, and pushing the point at which the new
653 ;; branch is attached further up the tree:
654 ;;
655 ;;      First undo-in-region                 Second undo-in-region
656 ;;
657 ;;               o                                o
658 ;;               |                                |\
659 ;;               |                                | \
660 ;;               o                                o  x  (undo-in-region)
661 ;;               |\                               |  |
662 ;;               | \                              |  |
663 ;;               o  x                             o  o
664 ;;               |  |                             |  |
665 ;;               |  |                             |  |
666 ;;               o  o                             o  o
667 ;;
668 ;; Redoing takes you back down the undo tree, as usual (as long as you haven't
669 ;; changed the active region after undoing-in-region, it doesn't matter if it
670 ;; is still active):
671 ;;
672 ;;                       o
673 ;;             |\
674 ;;             | \
675 ;;             o  o
676 ;;             |  |
677 ;;             |  |
678 ;;             o  o  (redo)
679 ;;             |  |
680 ;;             |  |
681 ;;             o  x  (redo)
682 ;;
683 ;;
684 ;; What about redo-in-region? Obviously, this only makes sense if you have
685 ;; already undone some changes, so that there are some changes to redo!
686 ;; Redoing-in-region splits off a new branch of the undo history below your
687 ;; current location in the undo tree. This time, the new branch consists of a
688 ;; redo step that redoes some of the redo changes that affect the current
689 ;; region, followed by all the remaining redo changes.
690 ;;
691 ;;      Previous undo history                Redo-in-region
692 ;;
693 ;;               o                                o
694 ;;               |                                |
695 ;;               |                                |
696 ;;               x                                o
697 ;;               |                                |\
698 ;;               |                                | \
699 ;;               o                                o  x  (redo-in-region)
700 ;;               |                                |  |
701 ;;               |                                |  |
702 ;;               o                                o  o
703 ;;
704 ;; As long as you don't change the active region after redoing-in-region,
705 ;; continuing to redo-in-region extends the new branch, pulling more redo
706 ;; changes into a redo step immediately below your current location in the
707 ;; undo tree.
708 ;;
709 ;;      First redo-in-region                 Second redo-in-region
710 ;;
711 ;;          o                                     o
712 ;;          |                                     |
713 ;;          |                                     |
714 ;;          o                                     o
715 ;;          |\                                    |\
716 ;;          | \                                   | \
717 ;;          o  x  (redo-in-region)                o  o
718 ;;          |  |                                  |  |
719 ;;          |  |                                  |  |
720 ;;          o  o                                  o  x  (redo-in-region)
721 ;;                                                   |
722 ;;                                                   |
723 ;;                                                   o
724 ;;
725 ;; Note that undo-in-region and redo-in-region only ever add new changes to
726 ;; the undo tree, they *never* modify existing undo history. So you can always
727 ;; return to previous buffer states by switching to a previous branch of the
728 ;; tree.
729
730
731
732 ;;; Code:
733
734 (eval-when-compile (require 'cl))
735 (require 'diff)
736
737
738
739 ;;; =====================================================================
740 ;;;              Compatibility hacks for older Emacsen
741
742 ;; `characterp' isn't defined in Emacs versions < 23
743 (unless (fboundp 'characterp)
744   (defalias 'characterp 'char-valid-p))
745
746 ;; `region-active-p' isn't defined in Emacs versions < 23
747 (unless (fboundp 'region-active-p)
748   (defun region-active-p () (and transient-mark-mode mark-active)))
749
750
751 ;; `registerv' defstruct isn't defined in Emacs versions < 24
752 (unless (fboundp 'registerv-make)
753   (defmacro registerv-make (data &rest _dummy) data))
754
755 (unless (fboundp 'registerv-data)
756   (defmacro registerv-data (data) data))
757
758
759 ;; `diff-no-select' and `diff-file-local-copy' aren't defined in Emacs
760 ;; versions < 24 (copied and adapted from Emacs 24)
761 (unless (fboundp 'diff-no-select)
762   (defun diff-no-select (old new &optional switches no-async buf)
763     ;; Noninteractive helper for creating and reverting diff buffers
764     (unless (bufferp new) (setq new (expand-file-name new)))
765     (unless (bufferp old) (setq old (expand-file-name old)))
766     (or switches (setq switches diff-switches)) ; If not specified, use default.
767     (unless (listp switches) (setq switches (list switches)))
768     (or buf (setq buf (get-buffer-create "*Diff*")))
769     (let* ((old-alt (diff-file-local-copy old))
770        (new-alt (diff-file-local-copy new))
771        (command
772         (mapconcat 'identity
773                `(,diff-command
774              ;; Use explicitly specified switches
775              ,@switches
776              ,@(mapcar #'shell-quote-argument
777                    (nconc
778                     (when (or old-alt new-alt)
779                       (list "-L" (if (stringp old)
780                              old (prin1-to-string old))
781                         "-L" (if (stringp new)
782                              new (prin1-to-string new))))
783                     (list (or old-alt old)
784                       (or new-alt new)))))
785                " "))
786        (thisdir default-directory))
787       (with-current-buffer buf
788     (setq buffer-read-only t)
789     (buffer-disable-undo (current-buffer))
790     (let ((inhibit-read-only t))
791       (erase-buffer))
792     (buffer-enable-undo (current-buffer))
793     (diff-mode)
794     (set (make-local-variable 'revert-buffer-function)
795          (lambda (_ignore-auto _noconfirm)
796            (diff-no-select old new switches no-async (current-buffer))))
797     (setq default-directory thisdir)
798     (let ((inhibit-read-only t))
799       (insert command "\n"))
800     (if (and (not no-async) (fboundp 'start-process))
801         (let ((proc (start-process "Diff" buf shell-file-name
802                        shell-command-switch command)))
803           (set-process-filter proc 'diff-process-filter)
804           (set-process-sentinel
805            proc (lambda (proc _msg)
806               (with-current-buffer (process-buffer proc)
807             (diff-sentinel (process-exit-status proc))
808             (if old-alt (delete-file old-alt))
809             (if new-alt (delete-file new-alt))))))
810       ;; Async processes aren't available.
811       (let ((inhibit-read-only t))
812         (diff-sentinel
813          (call-process shell-file-name nil buf nil
814                shell-command-switch command))
815         (if old-alt (delete-file old-alt))
816         (if new-alt (delete-file new-alt)))))
817       buf)))
818
819 (unless (fboundp 'diff-file-local-copy)
820   (defun diff-file-local-copy (file-or-buf)
821     (if (bufferp file-or-buf)
822     (with-current-buffer file-or-buf
823       (let ((tempfile (make-temp-file "buffer-content-")))
824         (write-region nil nil tempfile nil 'nomessage)
825         tempfile))
826       (file-local-copy file-or-buf))))
827
828
829 ;; `user-error' isn't defined in Emacs < 24.3
830 (unless (fboundp 'user-error)
831   (defalias 'user-error 'error)
832   ;; prevent debugger being called on user errors
833   (add-to-list 'debug-ignored-errors "^No further undo information")
834   (add-to-list 'debug-ignored-errors "^No further redo information")
835   (add-to-list 'debug-ignored-errors "^No further redo information for region"))
836
837
838
839
840
841 ;;; =====================================================================
842 ;;;              Global variables and customization options
843
844 (defvar buffer-undo-tree nil
845   "Tree of undo entries in current buffer.")
846 (put 'buffer-undo-tree 'permanent-local t)
847 (make-variable-buffer-local 'buffer-undo-tree)
848
849
850 (defgroup undo-tree nil
851   "Tree undo/redo."
852   :group 'undo)
853
854 (defcustom undo-tree-mode-lighter " Undo-Tree"
855   "Lighter displayed in mode line
856 when `undo-tree-mode' is enabled."
857   :group 'undo-tree
858   :type 'string)
859
860
861 (defcustom undo-tree-incompatible-major-modes '(term-mode)
862   "List of major-modes in which `undo-tree-mode' should not be enabled.
863 \(See `turn-on-undo-tree-mode'.\)"
864   :group 'undo-tree
865   :type '(repeat symbol))
866
867
868 (defcustom undo-tree-enable-undo-in-region t
869   "When non-nil, enable undo-in-region.
870
871 When undo-in-region is enabled, undoing or redoing when the
872 region is active (in `transient-mark-mode') or with a prefix
873 argument (not in `transient-mark-mode') only undoes changes
874 within the current region."
875   :group 'undo-tree
876   :type 'boolean)
877
878
879 (defcustom undo-tree-auto-save-history nil
880   "When non-nil, `undo-tree-mode' will save undo history to file
881 when a buffer is saved to file.
882
883 It will automatically load undo history when a buffer is loaded
884 from file, if an undo save file exists.
885
886 By default, undo-tree history is saved to a file called
887 \".<buffer-file-name>.~undo-tree~\" in the same directory as the
888 file itself. To save under a different directory, customize
889 `undo-tree-history-directory-alist' (see the documentation for
890 that variable for details).
891
892 WARNING! `undo-tree-auto-save-history' will not work properly in
893 Emacs versions prior to 24.3, so it cannot be enabled via
894 the customization interface in versions earlier than that one. To
895 ignore this warning and enable it regardless, set
896 `undo-tree-auto-save-history' to a non-nil value outside of
897 customize."
898   :group 'undo-tree
899   :type (if (version-list-< (version-to-list emacs-version) '(24 3))
900         '(choice (const :tag "<disabled>" nil))
901       'boolean))
902
903
904 (defcustom undo-tree-history-directory-alist nil
905   "Alist of filename patterns and undo history directory names.
906 Each element looks like (REGEXP . DIRECTORY).  Undo history for
907 files with names matching REGEXP will be saved in DIRECTORY.
908 DIRECTORY may be relative or absolute.  If it is absolute, so
909 that all matching files are backed up into the same directory,
910 the file names in this directory will be the full name of the
911 file backed up with all directory separators changed to `!' to
912 prevent clashes.  This will not work correctly if your filesystem
913 truncates the resulting name.
914
915 For the common case of all backups going into one directory, the
916 alist should contain a single element pairing \".\" with the
917 appropriate directory name.
918
919 If this variable is nil, or it fails to match a filename, the
920 backup is made in the original file's directory.
921
922 On MS-DOS filesystems without long names this variable is always
923 ignored."
924   :group 'undo-tree
925   :type '(repeat (cons (regexp :tag "Regexp matching filename")
926                (directory :tag "Undo history directory name"))))
927
928
929
930 (defcustom undo-tree-visualizer-relative-timestamps t
931   "When non-nil, display times relative to current time
932 when displaying time stamps in visualizer.
933
934 Otherwise, display absolute times."
935   :group 'undo-tree
936   :type 'boolean)
937
938
939 (defcustom undo-tree-visualizer-timestamps nil
940   "When non-nil, display time-stamps by default
941 in undo-tree visualizer.
942
943 \\<undo-tree-visualizer-mode-map>You can always toggle time-stamps on and off \
944 using \\[undo-tree-visualizer-toggle-timestamps], regardless of the
945 setting of this variable."
946   :group 'undo-tree
947   :type 'boolean)
948
949
950 (defcustom undo-tree-visualizer-diff nil
951   "When non-nil, display diff by default in undo-tree visualizer.
952
953 \\<undo-tree-visualizer-mode-map>You can always toggle the diff display \
954 using \\[undo-tree-visualizer-toggle-diff], regardless of the
955 setting of this variable."
956   :group 'undo-tree
957   :type 'boolean)
958
959
960 (defcustom undo-tree-visualizer-lazy-drawing 100
961   "When non-nil, use lazy undo-tree drawing in visualizer.
962
963 Setting this to a number causes the visualizer to switch to lazy
964 drawing when the number of nodes in the tree is larger than this
965 value.
966
967 Lazy drawing means that only the visible portion of the tree will
968 be drawn initially, and the tree will be extended later as
969 needed. For the most part, the only visible effect of this is to
970 significantly speed up displaying the visualizer for very large
971 trees.
972
973 There is one potential negative effect of lazy drawing. Other
974 branches of the tree will only be drawn once the node from which
975 they branch off becomes visible. So it can happen that certain
976 portions of the tree that would be shown with lazy drawing
977 disabled, will not be drawn immediately when it is
978 enabled. However, this effect is quite rare in practice."
979   :group 'undo-tree
980   :type '(choice (const :tag "never" nil)
981          (const :tag "always" t)
982          (integer :tag "> size")))
983
984
985 (defface undo-tree-visualizer-default-face
986   '((((class color)) :foreground "gray"))
987   "Face used to draw undo-tree in visualizer."
988   :group 'undo-tree)
989
990 (defface undo-tree-visualizer-current-face
991   '((((class color)) :foreground "red"))
992   "Face used to highlight current undo-tree node in visualizer."
993   :group 'undo-tree)
994
995 (defface undo-tree-visualizer-active-branch-face
996   '((((class color) (background dark))
997      (:foreground "white" :weight bold))
998     (((class color) (background light))
999      (:foreground "black" :weight bold)))
1000   "Face used to highlight active undo-tree branch in visualizer."
1001   :group 'undo-tree)
1002
1003 (defface undo-tree-visualizer-register-face
1004   '((((class color)) :foreground "yellow"))
1005   "Face used to highlight undo-tree nodes saved to a register
1006 in visualizer."
1007   :group 'undo-tree)
1008
1009 (defface undo-tree-visualizer-unmodified-face
1010   '((((class color)) :foreground "cyan"))
1011   "Face used to highlight nodes corresponding to unmodified buffers
1012 in visualizer."
1013   :group 'undo-tree)
1014
1015
1016 (defvar undo-tree-visualizer-parent-buffer nil
1017   "Parent buffer in visualizer.")
1018 (put 'undo-tree-visualizer-parent-buffer 'permanent-local t)
1019 (make-variable-buffer-local 'undo-tree-visualizer-parent-buffer)
1020
1021 ;; stores modification time of parent buffer's file, if any
1022 (defvar undo-tree-visualizer-parent-mtime nil)
1023 (put 'undo-tree-visualizer-parent-mtime 'permanent-local t)
1024 (make-variable-buffer-local 'undo-tree-visualizer-parent-mtime)
1025
1026 ;; stores current horizontal spacing needed for drawing undo-tree
1027 (defvar undo-tree-visualizer-spacing nil)
1028 (put 'undo-tree-visualizer-spacing 'permanent-local t)
1029 (make-variable-buffer-local 'undo-tree-visualizer-spacing)
1030
1031 ;; calculate horizontal spacing required for drawing tree with current
1032 ;; settings
1033 (defsubst undo-tree-visualizer-calculate-spacing ()
1034   (if undo-tree-visualizer-timestamps
1035       (if undo-tree-visualizer-relative-timestamps 9 13)
1036     3))
1037
1038 ;; holds node that was current when visualizer was invoked
1039 (defvar undo-tree-visualizer-initial-node nil)
1040 (put 'undo-tree-visualizer-initial-node 'permanent-local t)
1041 (make-variable-buffer-local 'undo-tree-visualizer-initial-node)
1042
1043 ;; holds currently selected node in visualizer selection mode
1044 (defvar undo-tree-visualizer-selected-node nil)
1045 (put 'undo-tree-visualizer-selected-node 'permanent-local t)
1046 (make-variable-buffer-local 'undo-tree-visualizer-selected)
1047
1048 ;; used to store nodes at edge of currently drawn portion of tree
1049 (defvar undo-tree-visualizer-needs-extending-down nil)
1050 (put 'undo-tree-visualizer-needs-extending-down 'permanent-local t)
1051 (make-variable-buffer-local 'undo-tree-visualizer-needs-extending-down)
1052 (defvar undo-tree-visualizer-needs-extending-up nil)
1053 (put 'undo-tree-visualizer-needs-extending-up 'permanent-local t)
1054 (make-variable-buffer-local 'undo-tree-visualizer-needs-extending-up)
1055
1056 ;; dynamically bound to t when undoing from visualizer, to inhibit
1057 ;; `undo-tree-kill-visualizer' hook function in parent buffer
1058 (defvar undo-tree-inhibit-kill-visualizer nil)
1059
1060 ;; can be let-bound to a face name, used in drawing functions
1061 (defvar undo-tree-insert-face nil)
1062
1063 ;; visualizer buffer names
1064 (defconst undo-tree-visualizer-buffer-name " *undo-tree*")
1065 (defconst undo-tree-diff-buffer-name "*undo-tree Diff*")
1066
1067 ;; install history-auto-save hooks
1068 (add-hook 'write-file-functions 'undo-tree-save-history-hook)
1069 (add-hook 'find-file-hook 'undo-tree-load-history-hook)
1070
1071
1072
1073
1074 ;;; =================================================================
1075 ;;;                          Default keymaps
1076
1077 (defvar undo-tree-map nil
1078   "Keymap used in undo-tree-mode.")
1079
1080 (unless undo-tree-map
1081   (let ((map (make-sparse-keymap)))
1082     ;; remap `undo' and `undo-only' to `undo-tree-undo'
1083     (define-key map [remap undo] 'undo-tree-undo)
1084     (define-key map [remap undo-only] 'undo-tree-undo)
1085     ;; bind standard undo bindings (since these match redo counterparts)
1086     (define-key map (kbd "C-/") 'undo-tree-undo)
1087     (define-key map "\C-_" 'undo-tree-undo)
1088     ;; redo doesn't exist normally, so define our own keybindings
1089     (define-key map (kbd "C-?") 'undo-tree-redo)
1090     (define-key map (kbd "M-_") 'undo-tree-redo)
1091     ;; just in case something has defined `redo'...
1092     (define-key map [remap redo] 'undo-tree-redo)
1093     ;; we use "C-x u" for the undo-tree visualizer
1094     (define-key map (kbd "\C-x u") 'undo-tree-visualize)
1095     ;; bind register commands
1096     (define-key map (kbd "C-x r u") 'undo-tree-save-state-to-register)
1097     (define-key map (kbd "C-x r U") 'undo-tree-restore-state-from-register)
1098     ;; set keymap
1099     (setq undo-tree-map map)))
1100
1101
1102 (defvar undo-tree-visualizer-mode-map nil
1103   "Keymap used in undo-tree visualizer.")
1104
1105 (unless undo-tree-visualizer-mode-map
1106   (let ((map (make-sparse-keymap)))
1107     ;; vertical motion keys undo/redo
1108     (define-key map [remap previous-line] 'undo-tree-visualize-undo)
1109     (define-key map [remap next-line] 'undo-tree-visualize-redo)
1110     (define-key map [up] 'undo-tree-visualize-undo)
1111     (define-key map "p" 'undo-tree-visualize-undo)
1112     (define-key map "\C-p" 'undo-tree-visualize-undo)
1113     (define-key map [down] 'undo-tree-visualize-redo)
1114     (define-key map "n" 'undo-tree-visualize-redo)
1115     (define-key map "\C-n" 'undo-tree-visualize-redo)
1116     ;; horizontal motion keys switch branch
1117     (define-key map [remap forward-char]
1118       'undo-tree-visualize-switch-branch-right)
1119     (define-key map [remap backward-char]
1120       'undo-tree-visualize-switch-branch-left)
1121     (define-key map [right] 'undo-tree-visualize-switch-branch-right)
1122     (define-key map "f" 'undo-tree-visualize-switch-branch-right)
1123     (define-key map "\C-f" 'undo-tree-visualize-switch-branch-right)
1124     (define-key map [left] 'undo-tree-visualize-switch-branch-left)
1125     (define-key map "b" 'undo-tree-visualize-switch-branch-left)
1126     (define-key map "\C-b" 'undo-tree-visualize-switch-branch-left)
1127     ;; paragraph motion keys undo/redo to significant points in tree
1128     (define-key map [remap backward-paragraph] 'undo-tree-visualize-undo-to-x)
1129     (define-key map [remap forward-paragraph] 'undo-tree-visualize-redo-to-x)
1130     (define-key map "\M-{" 'undo-tree-visualize-undo-to-x)
1131     (define-key map "\M-}" 'undo-tree-visualize-redo-to-x)
1132     (define-key map [C-up] 'undo-tree-visualize-undo-to-x)
1133     (define-key map [C-down] 'undo-tree-visualize-redo-to-x)
1134     ;; mouse sets buffer state to node at click
1135     (define-key map [mouse-1] 'undo-tree-visualizer-mouse-set)
1136     ;; toggle timestamps
1137     (define-key map "t" 'undo-tree-visualizer-toggle-timestamps)
1138     ;; toggle diff
1139     (define-key map "d" 'undo-tree-visualizer-toggle-diff)
1140     ;; toggle selection mode
1141     (define-key map "s" 'undo-tree-visualizer-selection-mode)
1142     ;; horizontal scrolling may be needed if the tree is very wide
1143     (define-key map "," 'undo-tree-visualizer-scroll-left)
1144     (define-key map "." 'undo-tree-visualizer-scroll-right)
1145     (define-key map "<" 'undo-tree-visualizer-scroll-left)
1146     (define-key map ">" 'undo-tree-visualizer-scroll-right)
1147     ;; vertical scrolling may be needed if the tree is very tall
1148     (define-key map [next] 'undo-tree-visualizer-scroll-up)
1149     (define-key map [prior] 'undo-tree-visualizer-scroll-down)
1150     ;; quit/abort visualizer
1151     (define-key map "q" 'undo-tree-visualizer-quit)
1152     (define-key map "\C-q" 'undo-tree-visualizer-abort)
1153     ;; set keymap
1154     (setq undo-tree-visualizer-mode-map map)))
1155
1156
1157 (defvar undo-tree-visualizer-selection-mode-map nil
1158   "Keymap used in undo-tree visualizer selection mode.")
1159
1160 (unless undo-tree-visualizer-selection-mode-map
1161   (let ((map (make-sparse-keymap)))
1162     ;; vertical motion keys move up and down tree
1163     (define-key map [remap previous-line]
1164       'undo-tree-visualizer-select-previous)
1165     (define-key map [remap next-line]
1166       'undo-tree-visualizer-select-next)
1167     (define-key map [up] 'undo-tree-visualizer-select-previous)
1168     (define-key map "p" 'undo-tree-visualizer-select-previous)
1169     (define-key map "\C-p" 'undo-tree-visualizer-select-previous)
1170     (define-key map [down] 'undo-tree-visualizer-select-next)
1171     (define-key map "n" 'undo-tree-visualizer-select-next)
1172     (define-key map "\C-n" 'undo-tree-visualizer-select-next)
1173     ;; vertical scroll keys move up and down quickly
1174     (define-key map [next]
1175       (lambda () (interactive) (undo-tree-visualizer-select-next 10)))
1176     (define-key map [prior]
1177       (lambda () (interactive) (undo-tree-visualizer-select-previous 10)))
1178     ;; horizontal motion keys move to left and right siblings
1179     (define-key map [remap forward-char] 'undo-tree-visualizer-select-right)
1180     (define-key map [remap backward-char] 'undo-tree-visualizer-select-left)
1181     (define-key map [right] 'undo-tree-visualizer-select-right)
1182     (define-key map "f" 'undo-tree-visualizer-select-right)
1183     (define-key map "\C-f" 'undo-tree-visualizer-select-right)
1184     (define-key map [left] 'undo-tree-visualizer-select-left)
1185     (define-key map "b" 'undo-tree-visualizer-select-left)
1186     (define-key map "\C-b" 'undo-tree-visualizer-select-left)
1187     ;; horizontal scroll keys move left or right quickly
1188     (define-key map ","
1189       (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
1190     (define-key map "."
1191       (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
1192     (define-key map "<"
1193       (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
1194     (define-key map ">"
1195       (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
1196     ;; <enter> sets buffer state to node at point
1197     (define-key map "\r" 'undo-tree-visualizer-set)
1198     ;; mouse selects node at click
1199     (define-key map [mouse-1] 'undo-tree-visualizer-mouse-select)
1200     ;; toggle diff
1201     (define-key map "d" 'undo-tree-visualizer-selection-toggle-diff)
1202     ;; set keymap
1203     (setq undo-tree-visualizer-selection-mode-map map)))
1204
1205
1206 (defvar undo-tree-old-undo-menu-item nil)
1207
1208 (defun undo-tree-update-menu-bar ()
1209   "Update `undo-tree-mode' Edit menu items."
1210   (if undo-tree-mode
1211       (progn
1212     ;; save old undo menu item, and install undo/redo menu items
1213     (setq undo-tree-old-undo-menu-item
1214           (cdr (assq 'undo (lookup-key global-map [menu-bar edit]))))
1215     (define-key (lookup-key global-map [menu-bar edit])
1216       [undo] '(menu-item "Undo" undo-tree-undo
1217                  :enable (and undo-tree-mode
1218                       (not buffer-read-only)
1219                       (not (eq t buffer-undo-list))
1220                       (undo-tree-node-previous
1221                        (undo-tree-current buffer-undo-tree)))
1222                  :help "Undo last operation"))
1223     (define-key-after (lookup-key global-map [menu-bar edit])
1224       [redo] '(menu-item "Redo" undo-tree-redo
1225                  :enable (and undo-tree-mode
1226                       (not buffer-read-only)
1227                       (not (eq t buffer-undo-list))
1228                       (undo-tree-node-next
1229                        (undo-tree-current buffer-undo-tree)))
1230                  :help "Redo last operation")
1231       'undo))
1232     ;; uninstall undo/redo menu items
1233     (define-key (lookup-key global-map [menu-bar edit])
1234       [undo] undo-tree-old-undo-menu-item)
1235     (define-key (lookup-key global-map [menu-bar edit])
1236       [redo] nil)))
1237
1238 (add-hook 'menu-bar-update-hook 'undo-tree-update-menu-bar)
1239
1240
1241
1242
1243
1244 ;;; =====================================================================
1245 ;;;                     Undo-tree data structure
1246
1247 (defstruct
1248   (undo-tree
1249    :named
1250    (:constructor nil)
1251    (:constructor make-undo-tree
1252                  (&aux
1253                   (root (undo-tree-make-node nil nil))
1254                   (current root)
1255                   (size 0)
1256           (count 0)
1257           (object-pool (make-hash-table :test 'eq :weakness 'value))))
1258    ;;(:copier nil)
1259    )
1260   root current size count object-pool)
1261
1262
1263
1264 (defstruct
1265   (undo-tree-node
1266    (:type vector)   ; create unnamed struct
1267    (:constructor nil)
1268    (:constructor undo-tree-make-node
1269                  (previous undo
1270           &optional redo
1271                   &aux
1272                   (timestamp (current-time))
1273                   (branch 0)))
1274    (:constructor undo-tree-make-node-backwards
1275                  (next-node undo
1276           &optional redo
1277                   &aux
1278                   (next (list next-node))
1279                   (timestamp (current-time))
1280                   (branch 0)))
1281    (:copier nil))
1282   previous next undo redo timestamp branch meta-data)
1283
1284
1285 (defmacro undo-tree-node-p (n)
1286   (let ((len (length (undo-tree-make-node nil nil))))
1287     `(and (vectorp ,n) (= (length ,n) ,len))))
1288
1289
1290
1291 (defstruct
1292   (undo-tree-region-data
1293    (:type vector)   ; create unnamed struct
1294    (:constructor nil)
1295    (:constructor undo-tree-make-region-data
1296          (&optional undo-beginning undo-end
1297                  redo-beginning redo-end))
1298    (:constructor undo-tree-make-undo-region-data
1299          (undo-beginning undo-end))
1300    (:constructor undo-tree-make-redo-region-data
1301          (redo-beginning redo-end))
1302    (:copier nil))
1303   undo-beginning undo-end redo-beginning redo-end)
1304
1305
1306 (defmacro undo-tree-region-data-p (r)
1307   (let ((len (length (undo-tree-make-region-data))))
1308     `(and (vectorp ,r) (= (length ,r) ,len))))
1309
1310 (defmacro undo-tree-node-clear-region-data (node)
1311   `(setf (undo-tree-node-meta-data ,node)
1312      (delq nil
1313            (delq :region
1314              (plist-put (undo-tree-node-meta-data ,node)
1315                 :region nil)))))
1316
1317
1318 (defmacro undo-tree-node-undo-beginning (node)
1319   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1320      (when (undo-tree-region-data-p r)
1321        (undo-tree-region-data-undo-beginning r))))
1322
1323 (defmacro undo-tree-node-undo-end (node)
1324   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1325      (when (undo-tree-region-data-p r)
1326        (undo-tree-region-data-undo-end r))))
1327
1328 (defmacro undo-tree-node-redo-beginning (node)
1329   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1330      (when (undo-tree-region-data-p r)
1331        (undo-tree-region-data-redo-beginning r))))
1332
1333 (defmacro undo-tree-node-redo-end (node)
1334   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1335      (when (undo-tree-region-data-p r)
1336        (undo-tree-region-data-redo-end r))))
1337
1338
1339 (defsetf undo-tree-node-undo-beginning (node) (val)
1340   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1341      (unless (undo-tree-region-data-p r)
1342        (setf (undo-tree-node-meta-data ,node)
1343          (plist-put (undo-tree-node-meta-data ,node) :region
1344             (setq r (undo-tree-make-region-data)))))
1345      (setf (undo-tree-region-data-undo-beginning r) ,val)))
1346
1347 (defsetf undo-tree-node-undo-end (node) (val)
1348   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1349      (unless (undo-tree-region-data-p r)
1350        (setf (undo-tree-node-meta-data ,node)
1351          (plist-put (undo-tree-node-meta-data ,node) :region
1352             (setq r (undo-tree-make-region-data)))))
1353      (setf (undo-tree-region-data-undo-end r) ,val)))
1354
1355 (defsetf undo-tree-node-redo-beginning (node) (val)
1356   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1357      (unless (undo-tree-region-data-p r)
1358        (setf (undo-tree-node-meta-data ,node)
1359          (plist-put (undo-tree-node-meta-data ,node) :region
1360             (setq r (undo-tree-make-region-data)))))
1361      (setf (undo-tree-region-data-redo-beginning r) ,val)))
1362
1363 (defsetf undo-tree-node-redo-end (node) (val)
1364   `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1365      (unless (undo-tree-region-data-p r)
1366        (setf (undo-tree-node-meta-data ,node)
1367          (plist-put (undo-tree-node-meta-data ,node) :region
1368             (setq r (undo-tree-make-region-data)))))
1369      (setf (undo-tree-region-data-redo-end r) ,val)))
1370
1371
1372
1373 (defstruct
1374   (undo-tree-visualizer-data
1375    (:type vector)   ; create unnamed struct
1376    (:constructor nil)
1377    (:constructor undo-tree-make-visualizer-data
1378          (&optional lwidth cwidth rwidth marker))
1379    (:copier nil))
1380   lwidth cwidth rwidth marker)
1381
1382
1383 (defmacro undo-tree-visualizer-data-p (v)
1384   (let ((len (length (undo-tree-make-visualizer-data))))
1385     `(and (vectorp ,v) (= (length ,v) ,len))))
1386
1387 (defun undo-tree-node-clear-visualizer-data (node)
1388   (let ((plist (undo-tree-node-meta-data node)))
1389     (if (eq (car plist) :visualizer)
1390     (setf (undo-tree-node-meta-data node) (nthcdr 2 plist))
1391       (while (and plist (not (eq (cadr plist) :visualizer)))
1392     (setq plist (cdr plist)))
1393       (if plist (setcdr plist (nthcdr 3 plist))))))
1394
1395 (defmacro undo-tree-node-lwidth (node)
1396   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1397      (when (undo-tree-visualizer-data-p v)
1398        (undo-tree-visualizer-data-lwidth v))))
1399
1400 (defmacro undo-tree-node-cwidth (node)
1401   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1402      (when (undo-tree-visualizer-data-p v)
1403        (undo-tree-visualizer-data-cwidth v))))
1404
1405 (defmacro undo-tree-node-rwidth (node)
1406   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1407      (when (undo-tree-visualizer-data-p v)
1408        (undo-tree-visualizer-data-rwidth v))))
1409
1410 (defmacro undo-tree-node-marker (node)
1411   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1412      (when (undo-tree-visualizer-data-p v)
1413        (undo-tree-visualizer-data-marker v))))
1414
1415
1416 (defsetf undo-tree-node-lwidth (node) (val)
1417   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1418      (unless (undo-tree-visualizer-data-p v)
1419        (setf (undo-tree-node-meta-data ,node)
1420          (plist-put (undo-tree-node-meta-data ,node) :visualizer
1421             (setq v (undo-tree-make-visualizer-data)))))
1422      (setf (undo-tree-visualizer-data-lwidth v) ,val)))
1423
1424 (defsetf undo-tree-node-cwidth (node) (val)
1425   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1426      (unless (undo-tree-visualizer-data-p v)
1427        (setf (undo-tree-node-meta-data ,node)
1428          (plist-put (undo-tree-node-meta-data ,node) :visualizer
1429             (setq v (undo-tree-make-visualizer-data)))))
1430      (setf (undo-tree-visualizer-data-cwidth v) ,val)))
1431
1432 (defsetf undo-tree-node-rwidth (node) (val)
1433   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1434      (unless (undo-tree-visualizer-data-p v)
1435        (setf (undo-tree-node-meta-data ,node)
1436          (plist-put (undo-tree-node-meta-data ,node) :visualizer
1437             (setq v (undo-tree-make-visualizer-data)))))
1438      (setf (undo-tree-visualizer-data-rwidth v) ,val)))
1439
1440 (defsetf undo-tree-node-marker (node) (val)
1441   `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1442      (unless (undo-tree-visualizer-data-p v)
1443        (setf (undo-tree-node-meta-data ,node)
1444          (plist-put (undo-tree-node-meta-data ,node) :visualizer
1445             (setq v (undo-tree-make-visualizer-data)))))
1446      (setf (undo-tree-visualizer-data-marker v) ,val)))
1447
1448
1449
1450 (defstruct
1451   (undo-tree-register-data
1452    (:type vector)
1453    (:constructor nil)
1454    (:constructor undo-tree-make-register-data (buffer node)))
1455   buffer node)
1456
1457 (defun undo-tree-register-data-p (data)
1458   (and (vectorp data)
1459        (= (length data) 2)
1460        (undo-tree-node-p (undo-tree-register-data-node data))))
1461
1462 (defun undo-tree-register-data-print-func (data)
1463   (princ (format "an undo-tree state for buffer %s"
1464          (undo-tree-register-data-buffer data))))
1465
1466 (defmacro undo-tree-node-register (node)
1467   `(plist-get (undo-tree-node-meta-data ,node) :register))
1468
1469 (defsetf undo-tree-node-register (node) (val)
1470   `(setf (undo-tree-node-meta-data ,node)
1471      (plist-put (undo-tree-node-meta-data ,node) :register ,val)))
1472
1473
1474
1475
1476 ;;; =====================================================================
1477 ;;;              Basic undo-tree data structure functions
1478
1479 (defun undo-tree-grow (undo)
1480   "Add an UNDO node to current branch of `buffer-undo-tree'."
1481   (let* ((current (undo-tree-current buffer-undo-tree))
1482          (new (undo-tree-make-node current undo)))
1483     (push new (undo-tree-node-next current))
1484     (setf (undo-tree-current buffer-undo-tree) new)))
1485
1486
1487 (defun undo-tree-grow-backwards (node undo &optional redo)
1488   "Add new node *above* undo-tree NODE, and return new node.
1489 Note that this will overwrite NODE's \"previous\" link, so should
1490 only be used on a detached NODE, never on nodes that are already
1491 part of `buffer-undo-tree'."
1492   (let ((new (undo-tree-make-node-backwards node undo redo)))
1493     (setf (undo-tree-node-previous node) new)
1494     new))
1495
1496
1497 (defun undo-tree-splice-node (node splice)
1498   "Splice NODE into undo tree, below node SPLICE.
1499 Note that this will overwrite NODE's \"next\" and \"previous\"
1500 links, so should only be used on a detached NODE, never on nodes
1501 that are already part of `buffer-undo-tree'."
1502   (setf (undo-tree-node-next node) (undo-tree-node-next splice)
1503     (undo-tree-node-branch node) (undo-tree-node-branch splice)
1504     (undo-tree-node-previous node) splice
1505     (undo-tree-node-next splice) (list node)
1506     (undo-tree-node-branch splice) 0)
1507   (dolist (n (undo-tree-node-next node))
1508     (setf (undo-tree-node-previous n) node)))
1509
1510
1511 (defun undo-tree-snip-node (node)
1512   "Snip NODE out of undo tree."
1513   (let* ((parent (undo-tree-node-previous node))
1514      position p)
1515     ;; if NODE is only child, replace parent's next links with NODE's
1516     (if (= (length (undo-tree-node-next parent)) 0)
1517     (setf (undo-tree-node-next parent) (undo-tree-node-next node)
1518           (undo-tree-node-branch parent) (undo-tree-node-branch node))
1519       ;; otherwise...
1520       (setq position (undo-tree-position node (undo-tree-node-next parent)))
1521       (cond
1522        ;; if active branch used do go via NODE, set parent's branch to active
1523        ;; branch of NODE
1524        ((= (undo-tree-node-branch parent) position)
1525     (setf (undo-tree-node-branch parent)
1526           (+ position (undo-tree-node-branch node))))
1527        ;; if active branch didn't go via NODE, update parent's branch to point
1528        ;; to same node as before
1529        ((> (undo-tree-node-branch parent) position)
1530     (incf (undo-tree-node-branch parent)
1531           (1- (length (undo-tree-node-next node))))))
1532       ;; replace NODE in parent's next list with NODE's entire next list
1533       (if (= position 0)
1534       (setf (undo-tree-node-next parent)
1535         (nconc (undo-tree-node-next node)
1536                (cdr (undo-tree-node-next parent))))
1537     (setq p (nthcdr (1- position) (undo-tree-node-next parent)))
1538     (setcdr p (nconc (undo-tree-node-next node) (cddr p)))))
1539     ;; update previous links of NODE's children
1540     (dolist (n (undo-tree-node-next node))
1541       (setf (undo-tree-node-previous n) parent))))
1542
1543
1544 (defun undo-tree-mapc (--undo-tree-mapc-function-- node)
1545   ;; Apply FUNCTION to NODE and to each node below it.
1546   (let ((stack (list node))
1547     n)
1548     (while stack
1549       (setq n (pop stack))
1550       (funcall --undo-tree-mapc-function-- n)
1551       (setq stack (append (undo-tree-node-next n) stack)))))
1552
1553
1554 (defmacro undo-tree-num-branches ()
1555   "Return number of branches at current undo tree node."
1556   '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree))))
1557
1558
1559 (defun undo-tree-position (node list)
1560   "Find the first occurrence of NODE in LIST.
1561 Return the index of the matching item, or nil of not found.
1562 Comparison is done with `eq'."
1563   (let ((i 0))
1564     (catch 'found
1565       (while (progn
1566                (when (eq node (car list)) (throw 'found i))
1567                (incf i)
1568                (setq list (cdr list))))
1569       nil)))
1570
1571
1572 (defvar *undo-tree-id-counter* 0)
1573 (make-variable-buffer-local '*undo-tree-id-counter*)
1574
1575 (defmacro undo-tree-generate-id ()
1576   ;; Generate a new, unique id (uninterned symbol).
1577   ;; The name is made by appending a number to "undo-tree-id".
1578   ;; (Copied from CL package `gensym'.)
1579   `(let ((num (prog1 *undo-tree-id-counter* (incf *undo-tree-id-counter*))))
1580      (make-symbol (format "undo-tree-id%d" num))))
1581
1582
1583 (defun undo-tree-decircle (undo-tree)
1584   ;; Nullify PREVIOUS links of UNDO-TREE nodes, to make UNDO-TREE data
1585   ;; structure non-circular.
1586   (undo-tree-mapc
1587    (lambda (node)
1588      (dolist (n (undo-tree-node-next node))
1589        (setf (undo-tree-node-previous n) nil)))
1590    (undo-tree-root undo-tree)))
1591
1592
1593 (defun undo-tree-recircle (undo-tree)
1594   ;; Recreate PREVIOUS links of UNDO-TREE nodes, to restore circular UNDO-TREE
1595   ;; data structure.
1596   (undo-tree-mapc
1597    (lambda (node)
1598      (dolist (n (undo-tree-node-next node))
1599        (setf (undo-tree-node-previous n) node)))
1600    (undo-tree-root undo-tree)))
1601
1602
1603
1604
1605 ;;; =====================================================================
1606 ;;;             Undo list and undo changeset utility functions
1607
1608 (defmacro undo-list-marker-elt-p (elt)
1609   `(markerp (car-safe ,elt)))
1610
1611 (defmacro undo-list-GCd-marker-elt-p (elt)
1612   ;; Return t if ELT is a marker element whose marker has been moved to the
1613   ;; object-pool, so may potentially have been garbage-collected.
1614   ;; Note: Valid marker undo elements should be uniquely identified as cons
1615   ;; cells with a symbol in the car (replacing the marker), and a number in
1616   ;; the cdr. However, to guard against future changes to undo element
1617   ;; formats, we perform an additional redundant check on the symbol name.
1618   `(and (car-safe ,elt)
1619     (symbolp (car ,elt))
1620     (let ((str (symbol-name (car ,elt))))
1621       (and (> (length str) 12)
1622            (string= (substring str 0 12) "undo-tree-id")))
1623     (numberp (cdr-safe ,elt))))
1624
1625
1626 (defun undo-tree-move-GC-elts-to-pool (elt)
1627   ;; Move elements that can be garbage-collected into `buffer-undo-tree'
1628   ;; object pool, substituting a unique id that can be used to retrieve them
1629   ;; later. (Only markers require this treatment currently.)
1630   (when (undo-list-marker-elt-p elt)
1631     (let ((id (undo-tree-generate-id)))
1632       (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree))
1633       (setcar elt id))))
1634
1635
1636 (defun undo-tree-restore-GC-elts-from-pool (elt)
1637   ;; Replace object id's in ELT with corresponding objects from
1638   ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if
1639   ;; any object in ELT has been garbage-collected.
1640   (if (undo-list-GCd-marker-elt-p elt)
1641       (when (setcar elt (gethash (car elt)
1642                  (undo-tree-object-pool buffer-undo-tree)))
1643     elt)
1644     elt))
1645
1646
1647 (defun undo-list-clean-GCd-elts (undo-list)
1648   ;; Remove object id's from UNDO-LIST that refer to elements that have been
1649   ;; garbage-collected. UNDO-LIST is modified by side-effect.
1650   (while (undo-list-GCd-marker-elt-p (car undo-list))
1651     (unless (gethash (caar undo-list)
1652              (undo-tree-object-pool buffer-undo-tree))
1653       (setq undo-list (cdr undo-list))))
1654   (let ((p undo-list))
1655     (while (cdr p)
1656       (when (and (undo-list-GCd-marker-elt-p (cadr p))
1657          (null (gethash (car (cadr p))
1658                 (undo-tree-object-pool buffer-undo-tree))))
1659     (setcdr p (cddr p)))
1660       (setq p (cdr p))))
1661   undo-list)
1662
1663
1664 (defun undo-list-pop-changeset (&optional discard-pos)
1665   ;; Pop changeset from `buffer-undo-list'. If DISCARD-POS is non-nil, discard
1666   ;; any position entries from changeset.
1667
1668   ;; discard undo boundaries and (if DISCARD-POS is non-nil) position entries
1669   ;; at head of undo list
1670   (while (or (null (car buffer-undo-list))
1671          (and discard-pos (integerp (car buffer-undo-list))))
1672     (setq buffer-undo-list (cdr buffer-undo-list)))
1673   ;; pop elements up to next undo boundary, discarding position entries if
1674   ;; DISCARD-POS is non-nil
1675   (if (eq (car buffer-undo-list) 'undo-tree-canary)
1676       (push nil buffer-undo-list)
1677     (let* ((changeset (list (pop buffer-undo-list)))
1678            (p changeset))
1679       (while (progn
1680            (undo-tree-move-GC-elts-to-pool (car p))
1681            (while (and discard-pos (integerp (car buffer-undo-list)))
1682          (setq buffer-undo-list (cdr buffer-undo-list)))
1683            (and (car buffer-undo-list)
1684             (not (eq (car buffer-undo-list) 'undo-tree-canary))))
1685         (setcdr p (list (pop buffer-undo-list)))
1686     (setq p (cdr p)))
1687       changeset)))
1688
1689
1690 (defun undo-tree-copy-list (undo-list)
1691   ;; Return a deep copy of first changeset in `undo-list'. Object id's are
1692   ;; replaced by corresponding objects from `buffer-undo-tree' object-pool.
1693   (when undo-list
1694     (let (copy p)
1695       ;; if first element contains an object id, replace it with object from
1696       ;; pool, discarding element entirely if it's been GC'd
1697       (while (null copy)
1698     (setq copy
1699           (undo-tree-restore-GC-elts-from-pool (pop undo-list))))
1700       (setq copy (list copy)
1701         p copy)
1702       ;; copy remaining elements, replacing object id's with objects from
1703       ;; pool, or discarding them entirely if they've been GC'd
1704       (while undo-list
1705     (when (setcdr p (undo-tree-restore-GC-elts-from-pool
1706              (undo-copy-list-1 (pop undo-list))))
1707       (setcdr p (list (cdr p)))
1708       (setq p (cdr p))))
1709       copy)))
1710
1711
1712
1713 (defun undo-list-transfer-to-tree ()
1714   ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'.
1715
1716   ;; `undo-list-transfer-to-tree' should never be called when undo is disabled
1717   ;; (i.e. `buffer-undo-tree' is t)
1718   (assert (not (eq buffer-undo-tree t)))
1719
1720   ;; if `buffer-undo-tree' is empty, create initial undo-tree
1721   (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree)))
1722   ;; make sure there's a canary at end of `buffer-undo-list'
1723   (when (null buffer-undo-list)
1724     (setq buffer-undo-list '(nil undo-tree-canary)))
1725
1726   (unless (or (eq (cadr buffer-undo-list) 'undo-tree-canary)
1727           (eq (car buffer-undo-list) 'undo-tree-canary))
1728     ;; create new node from first changeset in `buffer-undo-list', save old
1729     ;; `buffer-undo-tree' current node, and make new node the current node
1730     (let* ((node (undo-tree-make-node nil (undo-list-pop-changeset)))
1731        (splice (undo-tree-current buffer-undo-tree))
1732        (size (undo-list-byte-size (undo-tree-node-undo node)))
1733        (count 1))
1734       (setf (undo-tree-current buffer-undo-tree) node)
1735       ;; grow tree fragment backwards using `buffer-undo-list' changesets
1736       (while (and buffer-undo-list
1737           (not (eq (cadr buffer-undo-list) 'undo-tree-canary)))
1738     (setq node
1739           (undo-tree-grow-backwards node (undo-list-pop-changeset)))
1740     (incf size (undo-list-byte-size (undo-tree-node-undo node)))
1741     (incf count))
1742       ;; if no undo history has been discarded from `buffer-undo-list' since
1743       ;; last transfer, splice new tree fragment onto end of old
1744       ;; `buffer-undo-tree' current node
1745       (if (or (eq (cadr buffer-undo-list) 'undo-tree-canary)
1746           (eq (car buffer-undo-list) 'undo-tree-canary))
1747       (progn
1748         (setf (undo-tree-node-previous node) splice)
1749         (push node (undo-tree-node-next splice))
1750         (setf (undo-tree-node-branch splice) 0)
1751         (incf (undo-tree-size buffer-undo-tree) size)
1752         (incf (undo-tree-count buffer-undo-tree) count))
1753     ;; if undo history has been discarded, replace entire
1754     ;; `buffer-undo-tree' with new tree fragment
1755     (setq node (undo-tree-grow-backwards node nil))
1756     (setf (undo-tree-root buffer-undo-tree) node)
1757     (setq buffer-undo-list '(nil undo-tree-canary))
1758     (setf (undo-tree-size buffer-undo-tree) size)
1759     (setf (undo-tree-count buffer-undo-tree) count)
1760     (setq buffer-undo-list '(nil undo-tree-canary))))
1761     ;; discard undo history if necessary
1762     (undo-tree-discard-history)))
1763
1764
1765 (defun undo-list-byte-size (undo-list)
1766   ;; Return size (in bytes) of UNDO-LIST
1767   (let ((size 0) (p undo-list))
1768     (while p
1769       (incf size 8)  ; cons cells use up 8 bytes
1770       (when (and (consp (car p)) (stringp (caar p)))
1771         (incf size (string-bytes (caar p))))
1772       (setq p (cdr p)))
1773     size))
1774
1775
1776
1777 (defun undo-list-rebuild-from-tree ()
1778   "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'."
1779   (unless (eq buffer-undo-list t)
1780     (undo-list-transfer-to-tree)
1781     (setq buffer-undo-list nil)
1782     (when buffer-undo-tree
1783       (let ((stack (list (list (undo-tree-root buffer-undo-tree)))))
1784     (push (sort (mapcar 'identity (undo-tree-node-next (caar stack)))
1785             (lambda (a b)
1786               (time-less-p (undo-tree-node-timestamp a)
1787                    (undo-tree-node-timestamp b))))
1788           stack)
1789     ;; Traverse tree in depth-and-oldest-first order, but add undo records
1790     ;; on the way down, and redo records on the way up.
1791     (while (or (car stack)
1792            (not (eq (car (nth 1 stack))
1793                 (undo-tree-current buffer-undo-tree))))
1794       (if (car stack)
1795           (progn
1796         (setq buffer-undo-list
1797               (append (undo-tree-node-undo (caar stack))
1798                   buffer-undo-list))
1799         (undo-boundary)
1800         (push (sort (mapcar 'identity
1801                     (undo-tree-node-next (caar stack)))
1802                 (lambda (a b)
1803                   (time-less-p (undo-tree-node-timestamp a)
1804                        (undo-tree-node-timestamp b))))
1805               stack))
1806         (pop stack)
1807         (setq buffer-undo-list
1808           (append (undo-tree-node-redo (caar stack))
1809               buffer-undo-list))
1810         (undo-boundary)
1811         (pop (car stack))))))))
1812
1813
1814
1815
1816 ;;; =====================================================================
1817 ;;;                History discarding utility functions
1818
1819 (defun undo-tree-oldest-leaf (node)
1820   ;; Return oldest leaf node below NODE.
1821   (while (undo-tree-node-next node)
1822     (setq node
1823           (car (sort (mapcar 'identity (undo-tree-node-next node))
1824                      (lambda (a b)
1825                        (time-less-p (undo-tree-node-timestamp a)
1826                                     (undo-tree-node-timestamp b)))))))
1827   node)
1828
1829
1830 (defun undo-tree-discard-node (node)
1831   ;; Discard NODE from `buffer-undo-tree', and return next in line for
1832   ;; discarding.
1833
1834   ;; don't discard current node
1835   (unless (eq node (undo-tree-current buffer-undo-tree))
1836
1837     ;; discarding root node...
1838     (if (eq node (undo-tree-root buffer-undo-tree))
1839         (cond
1840          ;; should always discard branches before root
1841          ((> (length (undo-tree-node-next node)) 1)
1842           (error "Trying to discard undo-tree root which still\
1843  has multiple branches"))
1844          ;; don't discard root if current node is only child
1845          ((eq (car (undo-tree-node-next node))
1846               (undo-tree-current buffer-undo-tree))
1847       nil)
1848      ;; discard root
1849          (t
1850       ;; clear any register referring to root
1851       (let ((r (undo-tree-node-register node)))
1852         (when (and r (eq (get-register r) node))
1853           (set-register r nil)))
1854           ;; make child of root into new root
1855           (setq node (setf (undo-tree-root buffer-undo-tree)
1856                            (car (undo-tree-node-next node))))
1857       ;; update undo-tree size
1858       (decf (undo-tree-size buffer-undo-tree)
1859         (+ (undo-list-byte-size (undo-tree-node-undo node))
1860            (undo-list-byte-size (undo-tree-node-redo node))))
1861       (decf (undo-tree-count buffer-undo-tree))
1862       ;; discard new root's undo data and PREVIOUS link
1863       (setf (undo-tree-node-undo node) nil
1864         (undo-tree-node-redo node) nil
1865         (undo-tree-node-previous node) nil)
1866           ;; if new root has branches, or new root is current node, next node
1867           ;; to discard is oldest leaf, otherwise it's new root
1868           (if (or (> (length (undo-tree-node-next node)) 1)
1869                   (eq (car (undo-tree-node-next node))
1870                       (undo-tree-current buffer-undo-tree)))
1871               (undo-tree-oldest-leaf node)
1872             node)))
1873
1874       ;; discarding leaf node...
1875       (let* ((parent (undo-tree-node-previous node))
1876              (current (nth (undo-tree-node-branch parent)
1877                            (undo-tree-node-next parent))))
1878     ;; clear any register referring to the discarded node
1879     (let ((r (undo-tree-node-register node)))
1880       (when (and r (eq (get-register r) node))
1881         (set-register r nil)))
1882     ;; update undo-tree size
1883     (decf (undo-tree-size buffer-undo-tree)
1884           (+ (undo-list-byte-size (undo-tree-node-undo node))
1885          (undo-list-byte-size (undo-tree-node-redo node))))
1886     (decf (undo-tree-count buffer-undo-tree))
1887     ;; discard leaf
1888         (setf (undo-tree-node-next parent)
1889                 (delq node (undo-tree-node-next parent))
1890               (undo-tree-node-branch parent)
1891                 (undo-tree-position current (undo-tree-node-next parent)))
1892         ;; if parent has branches, or parent is current node, next node to
1893         ;; discard is oldest leaf, otherwise it's the parent itself
1894         (if (or (eq parent (undo-tree-current buffer-undo-tree))
1895                 (and (undo-tree-node-next parent)
1896                      (or (not (eq parent (undo-tree-root buffer-undo-tree)))
1897                          (> (length (undo-tree-node-next parent)) 1))))
1898             (undo-tree-oldest-leaf parent)
1899           parent)))))
1900
1901
1902
1903 (defun undo-tree-discard-history ()
1904   "Discard undo history until we're within memory usage limits
1905 set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'."
1906
1907   (when (> (undo-tree-size buffer-undo-tree) undo-limit)
1908     ;; if there are no branches off root, first node to discard is root;
1909     ;; otherwise it's leaf node at botom of oldest branch
1910     (let ((node (if (> (length (undo-tree-node-next
1911                                 (undo-tree-root buffer-undo-tree))) 1)
1912                     (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree))
1913                   (undo-tree-root buffer-undo-tree))))
1914
1915       ;; discard nodes until memory use is within `undo-strong-limit'
1916       (while (and node
1917                   (> (undo-tree-size buffer-undo-tree) undo-strong-limit))
1918         (setq node (undo-tree-discard-node node)))
1919
1920       ;; discard nodes until next node to discard would bring memory use
1921       ;; within `undo-limit'
1922       (while (and node
1923           ;; check first if last discard has brought us within
1924           ;; `undo-limit', in case we can avoid more expensive
1925           ;; `undo-strong-limit' calculation
1926           ;; Note: this assumes undo-strong-limit > undo-limit;
1927           ;;       if not, effectively undo-strong-limit = undo-limit
1928           (> (undo-tree-size buffer-undo-tree) undo-limit)
1929                   (> (- (undo-tree-size buffer-undo-tree)
1930             ;; if next node to discard is root, the memory we
1931             ;; free-up comes from discarding changesets from its
1932             ;; only child...
1933             (if (eq node (undo-tree-root buffer-undo-tree))
1934                 (+ (undo-list-byte-size
1935                 (undo-tree-node-undo
1936                  (car (undo-tree-node-next node))))
1937                    (undo-list-byte-size
1938                 (undo-tree-node-redo
1939                  (car (undo-tree-node-next node)))))
1940               ;; ...otherwise, it comes from discarding changesets
1941               ;; from along with the node itself
1942               (+ (undo-list-byte-size (undo-tree-node-undo node))
1943                  (undo-list-byte-size (undo-tree-node-redo node)))
1944               ))
1945                      undo-limit))
1946         (setq node (undo-tree-discard-node node)))
1947
1948       ;; if we're still over the `undo-outer-limit', discard entire history
1949       (when (> (undo-tree-size buffer-undo-tree) undo-outer-limit)
1950         ;; query first if `undo-ask-before-discard' is set
1951         (if undo-ask-before-discard
1952             (when (yes-or-no-p
1953                    (format
1954                     "Buffer `%s' undo info is %d bytes long;  discard it? "
1955                     (buffer-name) (undo-tree-size buffer-undo-tree)))
1956               (setq buffer-undo-tree nil))
1957           ;; otherwise, discard and display warning
1958           (display-warning
1959            '(undo discard-info)
1960            (concat
1961             (format "Buffer `%s' undo info was %d bytes long.\n"
1962                     (buffer-name) (undo-tree-size buffer-undo-tree))
1963             "The undo info was discarded because it exceeded\
1964  `undo-outer-limit'.
1965
1966 This is normal if you executed a command that made a huge change
1967 to the buffer. In that case, to prevent similar problems in the
1968 future, set `undo-outer-limit' to a value that is large enough to
1969 cover the maximum size of normal changes you expect a single
1970 command to make, but not so large that it might exceed the
1971 maximum memory allotted to Emacs.
1972
1973 If you did not execute any such command, the situation is
1974 probably due to a bug and you should report it.
1975
1976 You can disable the popping up of this buffer by adding the entry
1977 \(undo discard-info) to the user option `warning-suppress-types',
1978 which is defined in the `warnings' library.\n")
1979            :warning)
1980           (setq buffer-undo-tree nil)))
1981       )))
1982
1983
1984
1985
1986 ;;; =====================================================================
1987 ;;;                   Visualizer utility functions
1988
1989 (defun undo-tree-compute-widths (node)
1990   "Recursively compute widths for nodes below NODE."
1991   (let ((stack (list node))
1992         res)
1993     (while stack
1994       ;; try to compute widths for node at top of stack
1995       (if (undo-tree-node-p
1996            (setq res (undo-tree-node-compute-widths (car stack))))
1997           ;; if computation fails, it returns a node whose widths still need
1998           ;; computing, which we push onto the stack
1999           (push res stack)
2000         ;; otherwise, store widths and remove it from stack
2001         (setf (undo-tree-node-lwidth (car stack)) (aref res 0)
2002               (undo-tree-node-cwidth (car stack)) (aref res 1)
2003               (undo-tree-node-rwidth (car stack)) (aref res 2))
2004         (pop stack)))))
2005
2006
2007 (defun undo-tree-node-compute-widths (node)
2008   ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths
2009   ;; (in a vector) if successful. Otherwise, returns a node whose widths need
2010   ;; calculating before NODE's can be calculated.
2011   (let ((num-children (length (undo-tree-node-next node)))
2012         (lwidth 0) (cwidth 0) (rwidth 0) p)
2013     (catch 'need-widths
2014       (cond
2015        ;; leaf nodes have 0 width
2016        ((= 0 num-children)
2017         (setf cwidth 1
2018               (undo-tree-node-lwidth node) 0
2019               (undo-tree-node-cwidth node) 1
2020               (undo-tree-node-rwidth node) 0))
2021
2022        ;; odd number of children
2023        ((= (mod num-children 2) 1)
2024         (setq p (undo-tree-node-next node))
2025         ;; compute left-width
2026         (dotimes (i (/ num-children 2))
2027           (if (undo-tree-node-lwidth (car p))
2028               (incf lwidth (+ (undo-tree-node-lwidth (car p))
2029                               (undo-tree-node-cwidth (car p))
2030                               (undo-tree-node-rwidth (car p))))
2031             ;; if child's widths haven't been computed, return that child
2032             (throw 'need-widths (car p)))
2033           (setq p (cdr p)))
2034         (if (undo-tree-node-lwidth (car p))
2035             (incf lwidth (undo-tree-node-lwidth (car p)))
2036           (throw 'need-widths (car p)))
2037         ;; centre-width is inherited from middle child
2038         (setf cwidth (undo-tree-node-cwidth (car p)))
2039         ;; compute right-width
2040         (incf rwidth (undo-tree-node-rwidth (car p)))
2041         (setq p (cdr p))
2042         (dotimes (i (/ num-children 2))
2043           (if (undo-tree-node-lwidth (car p))
2044               (incf rwidth (+ (undo-tree-node-lwidth (car p))
2045                               (undo-tree-node-cwidth (car p))
2046                               (undo-tree-node-rwidth (car p))))
2047             (throw 'need-widths (car p)))
2048           (setq p (cdr p))))
2049
2050        ;; even number of children
2051        (t
2052         (setq p (undo-tree-node-next node))
2053         ;; compute left-width
2054         (dotimes (i (/ num-children 2))
2055           (if (undo-tree-node-lwidth (car p))
2056               (incf lwidth (+ (undo-tree-node-lwidth (car p))
2057                               (undo-tree-node-cwidth (car p))
2058                               (undo-tree-node-rwidth (car p))))
2059             (throw 'need-widths (car p)))
2060           (setq p (cdr p)))
2061         ;; centre-width is 0 when number of children is even
2062         (setq cwidth 0)
2063         ;; compute right-width
2064         (dotimes (i (/ num-children 2))
2065           (if (undo-tree-node-lwidth (car p))
2066               (incf rwidth (+ (undo-tree-node-lwidth (car p))
2067                               (undo-tree-node-cwidth (car p))
2068                               (undo-tree-node-rwidth (car p))))
2069             (throw 'need-widths (car p)))
2070           (setq p (cdr p)))))
2071
2072       ;; return left-, centre- and right-widths
2073       (vector lwidth cwidth rwidth))))
2074
2075
2076 (defun undo-tree-clear-visualizer-data (tree)
2077   ;; Clear visualizer data below NODE.
2078   (undo-tree-mapc
2079    (lambda (n) (undo-tree-node-clear-visualizer-data n))
2080    (undo-tree-root tree)))
2081
2082
2083 (defun undo-tree-node-unmodified-p (node &optional mtime)
2084   ;; Return non-nil if NODE corresponds to a buffer state that once upon a
2085   ;; time was unmodified. If a file modification time MTIME is specified,
2086   ;; return non-nil if the corresponding buffer state really is unmodified.
2087   (let (changeset ntime)
2088     (setq changeset
2089       (or (undo-tree-node-redo node)
2090           (and (setq changeset (car (undo-tree-node-next node)))
2091            (undo-tree-node-undo changeset)))
2092       ntime
2093       (catch 'found
2094         (dolist (elt changeset)
2095           (when (and (consp elt) (eq (car elt) t) (consp (cdr elt))
2096              (throw 'found (cdr elt)))))))
2097     (and ntime
2098      (or (null mtime)
2099          ;; high-precision timestamps
2100          (if (listp (cdr ntime))
2101          (equal ntime mtime)
2102            ;; old-style timestamps
2103            (and (= (car ntime) (car mtime))
2104             (= (cdr ntime) (cadr mtime))))))))
2105
2106
2107
2108
2109 ;;; =====================================================================
2110 ;;;                  Undo-in-region utility functions
2111
2112 ;; `undo-elt-in-region' uses this as a dynamically-scoped variable
2113 (defvar undo-adjusted-markers nil)
2114
2115
2116 (defun undo-tree-pull-undo-in-region-branch (start end)
2117   ;; Pull out entries from undo changesets to create a new undo-in-region
2118   ;; branch, which undoes changeset entries lying between START and END first,
2119   ;; followed by remaining entries from the changesets, before rejoining the
2120   ;; existing undo tree history. Repeated calls will, if appropriate, extend
2121   ;; the current undo-in-region branch rather than creating a new one.
2122
2123   ;; if we're just reverting the last redo-in-region, we don't need to
2124   ;; manipulate the undo tree at all
2125   (if (undo-tree-reverting-redo-in-region-p start end)
2126       t  ; return t to indicate success
2127
2128     ;; We build the `region-changeset' and `delta-list' lists forwards, using
2129     ;; pointers `r' and `d' to the penultimate element of the list. So that we
2130     ;; don't have to treat the first element differently, we prepend a dummy
2131     ;; leading nil to the lists, and have the pointers point to that
2132     ;; initially.
2133     ;; Note: using '(nil) instead of (list nil) in the `let*' results in
2134     ;;       bizarre errors when the code is byte-compiled, where parts of the
2135     ;;       lists appear to survive across different calls to this function.
2136     ;;       An obscure byte-compiler bug, perhaps?
2137     (let* ((region-changeset (list nil))
2138        (r region-changeset)
2139        (delta-list (list nil))
2140        (d delta-list)
2141        (node (undo-tree-current buffer-undo-tree))
2142        (repeated-undo-in-region
2143         (undo-tree-repeated-undo-in-region-p start end))
2144        undo-adjusted-markers  ; `undo-elt-in-region' expects this
2145        fragment splice original-fragment original-splice original-current
2146        got-visible-elt undo-list elt)
2147
2148       ;; --- initialisation ---
2149       (cond
2150        ;; if this is a repeated undo in the same region, start pulling changes
2151        ;; from NODE at which undo-in-region branch iss attached, and detatch
2152        ;; the branch, using it as initial FRAGMENT of branch being constructed
2153        (repeated-undo-in-region
2154     (setq original-current node
2155           fragment (car (undo-tree-node-next node))
2156           splice node)
2157     ;; undo up to node at which undo-in-region branch is attached
2158     ;; (recognizable as first node with more than one branch)
2159     (let ((mark-active nil))
2160       (while (= (length (undo-tree-node-next node)) 1)
2161         (undo-tree-undo-1)
2162         (setq fragment node
2163           node (undo-tree-current buffer-undo-tree))))
2164     (when (eq splice node) (setq splice nil))
2165     ;; detatch undo-in-region branch
2166     (setf (undo-tree-node-next node)
2167           (delq fragment (undo-tree-node-next node))
2168           (undo-tree-node-previous fragment) nil
2169           original-fragment fragment
2170           original-splice node))
2171
2172        ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all
2173        ;; nodes below the current one in the active branch
2174        ((undo-tree-node-next node)
2175     (setq fragment (undo-tree-make-node nil nil)
2176           splice fragment)
2177     (while (setq node (nth (undo-tree-node-branch node)
2178                    (undo-tree-node-next node)))
2179       (push (undo-tree-make-node
2180          splice
2181          (undo-copy-list (undo-tree-node-undo node))
2182          (undo-copy-list (undo-tree-node-redo node)))
2183         (undo-tree-node-next splice))
2184       (setq splice (car (undo-tree-node-next splice))))
2185     (setq fragment (car (undo-tree-node-next fragment))
2186           splice nil
2187           node (undo-tree-current buffer-undo-tree))))
2188
2189
2190       ;; --- pull undo-in-region elements into branch ---
2191       ;; work backwards up tree, pulling out undo elements within region until
2192       ;; we've got one that undoes a visible change (insertion or deletion)
2193       (catch 'abort
2194     (while (and (not got-visible-elt) node (undo-tree-node-undo node))
2195       ;; we cons a dummy nil element on the front of the changeset so that
2196       ;; we can conveniently remove the first (real) element from the
2197       ;; changeset if we need to; the leading nil is removed once we're
2198       ;; done with this changeset
2199       (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node)))
2200         elt (cadr undo-list))
2201       (if fragment
2202           (progn
2203         (setq fragment (undo-tree-grow-backwards fragment undo-list))
2204         (unless splice (setq splice fragment)))
2205         (setq fragment (undo-tree-make-node nil undo-list))
2206         (setq splice fragment))
2207
2208       (while elt
2209         (cond
2210          ;; keep elements within region
2211          ((undo-elt-in-region elt start end)
2212           ;; set flag if kept element is visible (insertion or deletion)
2213           (when (and (consp elt)
2214              (or (stringp (car elt)) (integerp (car elt))))
2215         (setq got-visible-elt t))
2216           ;; adjust buffer positions in elements previously undone before
2217           ;; kept element, as kept element will now be undone first
2218           (undo-tree-adjust-elements-to-elt splice elt)
2219           ;; move kept element to undo-in-region changeset, adjusting its
2220           ;; buffer position as it will now be undone first
2221           (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list))))
2222           (setq r (cdr r))
2223           (setcdr undo-list (cddr undo-list)))
2224
2225          ;; discard "was unmodified" elements
2226          ;; FIXME: deal properly with these
2227          ((and (consp elt) (eq (car elt) t))
2228           (setcdr undo-list (cddr undo-list)))
2229
2230          ;; if element crosses region, we can't pull any more elements
2231          ((undo-elt-crosses-region elt start end)
2232           ;; if we've found a visible element, it must be earlier in
2233           ;; current node's changeset; stop pulling elements (null
2234           ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit)
2235           (if got-visible-elt
2236           (setq undo-list nil)
2237         ;; if we haven't found a visible element yet, pulling
2238         ;; undo-in-region branch has failed
2239         (setq region-changeset nil)
2240         (throw 'abort t)))
2241
2242          ;; if rejecting element, add its delta (if any) to the list
2243          (t
2244           (let ((delta (undo-delta elt)))
2245         (when (/= 0 (cdr delta))
2246           (setcdr d (list delta))
2247           (setq d (cdr d))))
2248           (setq undo-list (cdr undo-list))))
2249
2250         ;; process next element of current changeset
2251         (setq elt (cadr undo-list)))
2252
2253       ;; if there are remaining elements in changeset, remove dummy nil
2254       ;; from front
2255       (if (cadr (undo-tree-node-undo fragment))
2256           (pop (undo-tree-node-undo fragment))
2257         ;; otherwise, if we've kept all elements in changeset, discard
2258         ;; empty changeset
2259         (when (eq splice fragment) (setq splice nil))
2260         (setq fragment (car (undo-tree-node-next fragment))))
2261       ;; process changeset from next node up the tree
2262       (setq node (undo-tree-node-previous node))))
2263
2264       ;; pop dummy nil from front of `region-changeset'
2265       (setq region-changeset (cdr region-changeset))
2266
2267
2268       ;; --- integrate branch into tree ---
2269       ;; if no undo-in-region elements were found, restore undo tree
2270       (if (null region-changeset)
2271       (when original-current
2272         (push original-fragment (undo-tree-node-next original-splice))
2273         (setf (undo-tree-node-branch original-splice) 0
2274           (undo-tree-node-previous original-fragment) original-splice)
2275         (let ((mark-active nil))
2276           (while (not (eq (undo-tree-current buffer-undo-tree)
2277                   original-current))
2278         (undo-tree-redo-1)))
2279         nil)  ; return nil to indicate failure
2280
2281     ;; otherwise...
2282     ;; need to undo up to node where new branch will be attached, to
2283     ;; ensure redo entries are populated, and then redo back to where we
2284     ;; started
2285     (let ((mark-active nil)
2286           (current (undo-tree-current buffer-undo-tree)))
2287       (while (not (eq (undo-tree-current buffer-undo-tree) node))
2288         (undo-tree-undo-1))
2289       (while (not (eq (undo-tree-current buffer-undo-tree) current))
2290         (undo-tree-redo-1)))
2291
2292     (cond
2293      ;; if there's no remaining fragment, just create undo-in-region node
2294      ;; and attach it to parent of last node from which elements were
2295      ;; pulled
2296      ((null fragment)
2297       (setq fragment (undo-tree-make-node node region-changeset))
2298       (push fragment (undo-tree-node-next node))
2299       (setf (undo-tree-node-branch node) 0)
2300       ;; set current node to undo-in-region node
2301       (setf (undo-tree-current buffer-undo-tree) fragment))
2302
2303      ;; if no splice point has been set, add undo-in-region node to top of
2304      ;; fragment and attach it to parent of last node from which elements
2305      ;; were pulled
2306      ((null splice)
2307       (setq fragment (undo-tree-grow-backwards fragment region-changeset))
2308       (push fragment (undo-tree-node-next node))
2309       (setf (undo-tree-node-branch node) 0
2310         (undo-tree-node-previous fragment) node)
2311       ;; set current node to undo-in-region node
2312       (setf (undo-tree-current buffer-undo-tree) fragment))
2313
2314      ;; if fragment contains nodes, attach fragment to parent of last node
2315      ;; from which elements were pulled, and splice in undo-in-region node
2316      (t
2317       (setf (undo-tree-node-previous fragment) node)
2318       (push fragment (undo-tree-node-next node))
2319       (setf (undo-tree-node-branch node) 0)
2320       ;; if this is a repeated undo-in-region, then we've left the current
2321       ;; node at the original splice-point; we need to set the current
2322       ;; node to the equivalent node on the undo-in-region branch and redo
2323       ;; back to where we started
2324       (when repeated-undo-in-region
2325         (setf (undo-tree-current buffer-undo-tree)
2326           (undo-tree-node-previous original-fragment))
2327         (let ((mark-active nil))
2328           (while (not (eq (undo-tree-current buffer-undo-tree) splice))
2329         (undo-tree-redo-1 nil 'preserve-undo))))
2330       ;; splice new undo-in-region node into fragment
2331       (setq node (undo-tree-make-node nil region-changeset))
2332       (undo-tree-splice-node node splice)
2333       ;; set current node to undo-in-region node
2334       (setf (undo-tree-current buffer-undo-tree) node)))
2335
2336     ;; update undo-tree size
2337     (setq node (undo-tree-node-previous fragment))
2338     (while (progn
2339          (and (setq node (car (undo-tree-node-next node)))
2340               (not (eq node original-fragment))
2341               (incf (undo-tree-count buffer-undo-tree))
2342               (incf (undo-tree-size buffer-undo-tree)
2343                 (+ (undo-list-byte-size (undo-tree-node-undo node))
2344                    (undo-list-byte-size (undo-tree-node-redo node)))))))
2345     t)  ; indicate undo-in-region branch was successfully pulled
2346       )))
2347
2348
2349
2350 (defun undo-tree-pull-redo-in-region-branch (start end)
2351   ;; Pull out entries from redo changesets to create a new redo-in-region
2352   ;; branch, which redoes changeset entries lying between START and END first,
2353   ;; followed by remaining entries from the changesets. Repeated calls will,
2354   ;; if appropriate, extend the current redo-in-region branch rather than
2355   ;; creating a new one.
2356
2357   ;; if we're just reverting the last undo-in-region, we don't need to
2358   ;; manipulate the undo tree at all
2359   (if (undo-tree-reverting-undo-in-region-p start end)
2360       t  ; return t to indicate success
2361
2362     ;; We build the `region-changeset' and `delta-list' lists forwards, using
2363     ;; pointers `r' and `d' to the penultimate element of the list. So that we
2364     ;; don't have to treat the first element differently, we prepend a dummy
2365     ;; leading nil to the lists, and have the pointers point to that
2366     ;; initially.
2367     ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre
2368     ;;       errors when the code is byte-compiled, where parts of the lists
2369     ;;       appear to survive across different calls to this function.  An
2370     ;;       obscure byte-compiler bug, perhaps?
2371     (let* ((region-changeset (list nil))
2372        (r region-changeset)
2373        (delta-list (list nil))
2374        (d delta-list)
2375        (node (undo-tree-current buffer-undo-tree))
2376        (repeated-redo-in-region
2377         (undo-tree-repeated-redo-in-region-p start end))
2378        undo-adjusted-markers  ; `undo-elt-in-region' expects this
2379        fragment splice got-visible-elt redo-list elt)
2380
2381       ;; --- inisitalisation ---
2382       (cond
2383        ;; if this is a repeated redo-in-region, detach fragment below current
2384        ;; node
2385        (repeated-redo-in-region
2386     (when (setq fragment (car (undo-tree-node-next node)))
2387       (setf (undo-tree-node-previous fragment) nil
2388         (undo-tree-node-next node)
2389         (delq fragment (undo-tree-node-next node)))))
2390        ;; if this is a new redo-in-region, initial fragment is a copy of all
2391        ;; nodes below the current one in the active branch
2392        ((undo-tree-node-next node)
2393     (setq fragment (undo-tree-make-node nil nil)
2394           splice fragment)
2395     (while (setq node (nth (undo-tree-node-branch node)
2396                    (undo-tree-node-next node)))
2397       (push (undo-tree-make-node
2398          splice nil
2399          (undo-copy-list (undo-tree-node-redo node)))
2400         (undo-tree-node-next splice))
2401       (setq splice (car (undo-tree-node-next splice))))
2402     (setq fragment (car (undo-tree-node-next fragment)))))
2403
2404
2405       ;; --- pull redo-in-region elements into branch ---
2406       ;; work down fragment, pulling out redo elements within region until
2407       ;; we've got one that redoes a visible change (insertion or deletion)
2408       (setq node fragment)
2409       (catch 'abort
2410     (while (and (not got-visible-elt) node (undo-tree-node-redo node))
2411       ;; we cons a dummy nil element on the front of the changeset so that
2412       ;; we can conveniently remove the first (real) element from the
2413       ;; changeset if we need to; the leading nil is removed once we're
2414       ;; done with this changeset
2415       (setq redo-list (push nil (undo-tree-node-redo node))
2416         elt (cadr redo-list))
2417       (while elt
2418         (cond
2419          ;; keep elements within region
2420          ((undo-elt-in-region elt start end)
2421           ;; set flag if kept element is visible (insertion or deletion)
2422           (when (and (consp elt)
2423              (or (stringp (car elt)) (integerp (car elt))))
2424         (setq got-visible-elt t))
2425           ;; adjust buffer positions in elements previously redone before
2426           ;; kept element, as kept element will now be redone first
2427           (undo-tree-adjust-elements-to-elt fragment elt t)
2428           ;; move kept element to redo-in-region changeset, adjusting its
2429           ;; buffer position as it will now be redone first
2430           (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1)))
2431           (setq r (cdr r))
2432           (setcdr redo-list (cddr redo-list)))
2433
2434          ;; discard "was unmodified" elements
2435          ;; FIXME: deal properly with these
2436          ((and (consp elt) (eq (car elt) t))
2437           (setcdr redo-list (cddr redo-list)))
2438
2439          ;; if element crosses region, we can't pull any more elements
2440          ((undo-elt-crosses-region elt start end)
2441           ;; if we've found a visible element, it must be earlier in
2442           ;; current node's changeset; stop pulling elements (null
2443           ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit)
2444           (if got-visible-elt
2445           (setq redo-list nil)
2446         ;; if we haven't found a visible element yet, pulling
2447         ;; redo-in-region branch has failed
2448         (setq region-changeset nil)
2449         (throw 'abort t)))
2450
2451          ;; if rejecting element, add its delta (if any) to the list
2452          (t
2453           (let ((delta (undo-delta elt)))
2454         (when (/= 0 (cdr delta))
2455           (setcdr d (list delta))
2456           (setq d (cdr d))))
2457           (setq redo-list (cdr redo-list))))
2458
2459         ;; process next element of current changeset
2460         (setq elt (cadr redo-list)))
2461
2462       ;; if there are remaining elements in changeset, remove dummy nil
2463       ;; from front
2464       (if (cadr (undo-tree-node-redo node))
2465           (pop (undo-tree-node-undo node))
2466         ;; otherwise, if we've kept all elements in changeset, discard
2467         ;; empty changeset
2468         (if (eq fragment node)
2469         (setq fragment (car (undo-tree-node-next fragment)))
2470           (undo-tree-snip-node node)))
2471       ;; process changeset from next node in fragment
2472       (setq node (car (undo-tree-node-next node)))))
2473
2474       ;; pop dummy nil from front of `region-changeset'
2475       (setq region-changeset (cdr region-changeset))
2476
2477
2478       ;; --- integrate branch into tree ---
2479       (setq node (undo-tree-current buffer-undo-tree))
2480       ;; if no redo-in-region elements were found, restore undo tree
2481       (if (null (car region-changeset))
2482       (when (and repeated-redo-in-region fragment)
2483         (push fragment (undo-tree-node-next node))
2484         (setf (undo-tree-node-branch node) 0
2485           (undo-tree-node-previous fragment) node)
2486         nil)  ; return nil to indicate failure
2487
2488     ;; otherwise, add redo-in-region node to top of fragment, and attach
2489     ;; it below current node
2490     (setq fragment
2491           (if fragment
2492           (undo-tree-grow-backwards fragment nil region-changeset)
2493         (undo-tree-make-node nil nil region-changeset)))
2494     (push fragment (undo-tree-node-next node))
2495     (setf (undo-tree-node-branch node) 0
2496           (undo-tree-node-previous fragment) node)
2497     ;; update undo-tree size
2498     (unless repeated-redo-in-region
2499       (setq node fragment)
2500       (while (and (setq node (car (undo-tree-node-next node)))
2501               (incf (undo-tree-count buffer-undo-tree))
2502               (incf (undo-tree-size buffer-undo-tree)
2503                 (undo-list-byte-size
2504                  (undo-tree-node-redo node))))))
2505     (incf (undo-tree-size buffer-undo-tree)
2506           (undo-list-byte-size (undo-tree-node-redo fragment)))
2507     t)  ; indicate redo-in-region branch was successfully pulled
2508       )))
2509
2510
2511
2512 (defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below)
2513   "Adjust buffer positions of undo elements, starting at NODE's
2514 and going up the tree (or down the active branch if BELOW is
2515 non-nil) and through the nodes' undo elements until we reach
2516 UNDO-ELT.  UNDO-ELT must appear somewhere in the undo changeset
2517 of either NODE itself or some node above it in the tree."
2518   (let ((delta (list (undo-delta undo-elt)))
2519     (undo-list (undo-tree-node-undo node)))
2520     ;; adjust elements until we reach UNDO-ELT
2521     (while (and (car undo-list)
2522         (not (eq (car undo-list) undo-elt)))
2523       (setcar undo-list
2524           (undo-tree-apply-deltas (car undo-list) delta -1))
2525       ;; move to next undo element in list, or to next node if we've run out
2526       ;; of elements
2527       (unless (car (setq undo-list (cdr undo-list)))
2528     (if below
2529         (setq node (nth (undo-tree-node-branch node)
2530                 (undo-tree-node-next node)))
2531       (setq node (undo-tree-node-previous node)))
2532     (setq undo-list (undo-tree-node-undo node))))))
2533
2534
2535
2536 (defun undo-tree-apply-deltas (undo-elt deltas &optional sgn)
2537   ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN
2538   ;; (only useful value for SGN is -1).
2539   (let (position offset)
2540     (dolist (delta deltas)
2541       (setq position (car delta)
2542         offset (* (cdr delta) (or sgn 1)))
2543       (cond
2544        ;; POSITION
2545        ((integerp undo-elt)
2546     (when (>= undo-elt position)
2547       (setq undo-elt (- undo-elt offset))))
2548        ;; nil (or any other atom)
2549        ((atom undo-elt))
2550        ;; (TEXT . POSITION)
2551        ((stringp (car undo-elt))
2552     (let ((text-pos (abs (cdr undo-elt)))
2553           (point-at-end (< (cdr undo-elt) 0)))
2554       (if (>= text-pos position)
2555           (setcdr undo-elt (* (if point-at-end -1 1)
2556                   (- text-pos offset))))))
2557        ;; (BEGIN . END)
2558        ((integerp (car undo-elt))
2559     (when (>= (car undo-elt) position)
2560       (setcar undo-elt (- (car undo-elt) offset))
2561       (setcdr undo-elt (- (cdr undo-elt) offset))))
2562        ;; (nil PROPERTY VALUE BEG . END)
2563        ((null (car undo-elt))
2564     (let ((tail (nthcdr 3 undo-elt)))
2565       (when (>= (car tail) position)
2566         (setcar tail (- (car tail) offset))
2567         (setcdr tail (- (cdr tail) offset)))))
2568        ))
2569     undo-elt))
2570
2571
2572
2573 (defun undo-tree-repeated-undo-in-region-p (start end)
2574   ;; Return non-nil if undo-in-region between START and END is a repeated
2575   ;; undo-in-region
2576   (let ((node (undo-tree-current buffer-undo-tree)))
2577     (and (setq node
2578            (nth (undo-tree-node-branch node) (undo-tree-node-next node)))
2579      (eq (undo-tree-node-undo-beginning node) start)
2580      (eq (undo-tree-node-undo-end node) end))))
2581
2582
2583 (defun undo-tree-repeated-redo-in-region-p (start end)
2584   ;; Return non-nil if undo-in-region between START and END is a repeated
2585   ;; undo-in-region
2586   (let ((node (undo-tree-current buffer-undo-tree)))
2587     (and (eq (undo-tree-node-redo-beginning node) start)
2588      (eq (undo-tree-node-redo-end node) end))))
2589
2590
2591 ;; Return non-nil if undo-in-region between START and END is simply
2592 ;; reverting the last redo-in-region
2593 (defalias 'undo-tree-reverting-undo-in-region-p
2594   'undo-tree-repeated-undo-in-region-p)
2595
2596
2597 ;; Return non-nil if redo-in-region between START and END is simply
2598 ;; reverting the last undo-in-region
2599 (defalias 'undo-tree-reverting-redo-in-region-p
2600   'undo-tree-repeated-redo-in-region-p)
2601
2602
2603
2604
2605 ;;; =====================================================================
2606 ;;;                        Undo-tree commands
2607
2608 ;;;###autoload
2609 (define-minor-mode undo-tree-mode
2610   "Toggle undo-tree mode.
2611 With no argument, this command toggles the mode.
2612 A positive prefix argument turns the mode on.
2613 A negative prefix argument turns it off.
2614
2615 Undo-tree-mode replaces Emacs' standard undo feature with a more
2616 powerful yet easier to use version, that treats the undo history
2617 as what it is: a tree.
2618
2619 The following keys are available in `undo-tree-mode':
2620
2621   \\{undo-tree-map}
2622
2623 Within the undo-tree visualizer, the following keys are available:
2624
2625   \\{undo-tree-visualizer-mode-map}"
2626
2627   nil                       ; init value
2628   undo-tree-mode-lighter    ; lighter
2629   undo-tree-map             ; keymap
2630
2631   ;; if disabling `undo-tree-mode', rebuild `buffer-undo-list' from tree so
2632   ;; Emacs undo can work
2633   (when (not undo-tree-mode)
2634     (undo-list-rebuild-from-tree)
2635     (setq buffer-undo-tree nil)))
2636
2637
2638 (defun turn-on-undo-tree-mode (&optional print-message)
2639   "Enable `undo-tree-mode' in the current buffer, when appropriate.
2640 Some major modes implement their own undo system, which should
2641 not normally be overridden by `undo-tree-mode'. This command does
2642 not enable `undo-tree-mode' in such buffers. If you want to force
2643 `undo-tree-mode' to be enabled regardless, use (undo-tree-mode 1)
2644 instead.
2645
2646 The heuristic used to detect major modes in which
2647 `undo-tree-mode' should not be used is to check whether either
2648 the `undo' command has been remapped, or the default undo
2649 keybindings (C-/ and C-_) have been overridden somewhere other
2650 than in the global map. In addition, `undo-tree-mode' will not be
2651 enabled if the buffer's `major-mode' appears in
2652 `undo-tree-incompatible-major-modes'."
2653   (interactive "p")
2654   (if (or (key-binding [remap undo])
2655       (undo-tree-overridden-undo-bindings-p)
2656       (memq major-mode undo-tree-incompatible-major-modes))
2657       (when print-message
2658     (message "Buffer does not support undo-tree-mode;\
2659  undo-tree-mode NOT enabled"))
2660     (undo-tree-mode 1)))
2661
2662
2663 (defun undo-tree-overridden-undo-bindings-p ()
2664   "Returns t if default undo bindings are overridden, nil otherwise.
2665 Checks if either of the default undo key bindings (\"C-/\" or
2666 \"C-_\") are overridden in the current buffer by any keymap other
2667 than the global one. (So global redefinitions of the default undo
2668 key bindings do not count.)"
2669   (let ((binding1 (lookup-key (current-global-map) [?\C-/]))
2670     (binding2 (lookup-key (current-global-map) [?\C-_])))
2671     (global-set-key [?\C-/] 'undo)
2672     (global-set-key [?\C-_] 'undo)
2673     (unwind-protect
2674     (or (and (key-binding [?\C-/])
2675          (not (eq (key-binding [?\C-/]) 'undo)))
2676         (and (key-binding [?\C-_])
2677          (not (eq (key-binding [?\C-_]) 'undo))))
2678       (global-set-key [?\C-/] binding1)
2679       (global-set-key [?\C-_] binding2))))
2680
2681
2682 ;;;###autoload
2683 (define-globalized-minor-mode global-undo-tree-mode
2684   undo-tree-mode turn-on-undo-tree-mode)
2685
2686
2687
2688 (defun undo-tree-undo (&optional arg)
2689   "Undo changes.
2690 Repeat this command to undo more changes.
2691 A numeric ARG serves as a repeat count.
2692
2693 In Transient Mark mode when the mark is active, only undo changes
2694 within the current region. Similarly, when not in Transient Mark
2695 mode, just \\[universal-argument] as an argument limits undo to
2696 changes within the current region."
2697   (interactive "*P")
2698   ;; throw error if undo is disabled in buffer
2699   (when (eq buffer-undo-list t)
2700     (user-error "No undo information in this buffer"))
2701   (undo-tree-undo-1 arg)
2702   ;; inform user if at branch point
2703   (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))
2704
2705
2706 (defun undo-tree-undo-1 (&optional arg preserve-redo preserve-timestamps)
2707   ;; Internal undo function. An active mark in `transient-mark-mode', or
2708   ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-REDO
2709   ;; causes the existing redo record to be preserved, rather than replacing it
2710   ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS
2711   ;; disables updating of timestamps in visited undo-tree nodes. (This latter
2712   ;; should *only* be used when temporarily visiting another undo state and
2713   ;; immediately returning to the original state afterwards. Otherwise, it
2714   ;; could cause history-discarding errors.)
2715   (let ((undo-in-progress t)
2716     (undo-in-region (and undo-tree-enable-undo-in-region
2717                  (or (region-active-p)
2718                  (and arg (not (numberp arg))))))
2719     pos current)
2720     ;; transfer entries accumulated in `buffer-undo-list' to
2721     ;; `buffer-undo-tree'
2722     (undo-list-transfer-to-tree)
2723
2724     (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
2725       ;; check if at top of undo tree
2726       (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
2727     (user-error "No further undo information"))
2728
2729       ;; if region is active, or a non-numeric prefix argument was supplied,
2730       ;; try to pull out a new branch of changes affecting the region
2731       (when (and undo-in-region
2732          (not (undo-tree-pull-undo-in-region-branch
2733                (region-beginning) (region-end))))
2734     (user-error "No further undo information for region"))
2735
2736       ;; remove any GC'd elements from node's undo list
2737       (setq current (undo-tree-current buffer-undo-tree))
2738       (decf (undo-tree-size buffer-undo-tree)
2739         (undo-list-byte-size (undo-tree-node-undo current)))
2740       (setf (undo-tree-node-undo current)
2741         (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
2742       (incf (undo-tree-size buffer-undo-tree)
2743         (undo-list-byte-size (undo-tree-node-undo current)))
2744       ;; undo one record from undo tree
2745       (when undo-in-region
2746     (setq pos (set-marker (make-marker) (point)))
2747     (set-marker-insertion-type pos t))
2748       (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current)))
2749       (undo-boundary)
2750
2751       ;; if preserving old redo record, discard new redo entries that
2752       ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
2753       ;; elements from node's redo list
2754       (if preserve-redo
2755       (progn
2756         (undo-list-pop-changeset)
2757         (decf (undo-tree-size buffer-undo-tree)
2758           (undo-list-byte-size (undo-tree-node-redo current)))
2759         (setf (undo-tree-node-redo current)
2760           (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
2761         (incf (undo-tree-size buffer-undo-tree)
2762           (undo-list-byte-size (undo-tree-node-redo current))))
2763     ;; otherwise, record redo entries that `primitive-undo' has added to
2764     ;; `buffer-undo-list' in current node's redo record, replacing
2765     ;; existing entry if one already exists
2766     (decf (undo-tree-size buffer-undo-tree)
2767           (undo-list-byte-size (undo-tree-node-redo current)))
2768     (setf (undo-tree-node-redo current)
2769           (undo-list-pop-changeset 'discard-pos))
2770     (incf (undo-tree-size buffer-undo-tree)
2771           (undo-list-byte-size (undo-tree-node-redo current))))
2772
2773       ;; rewind current node and update timestamp
2774       (setf (undo-tree-current buffer-undo-tree)
2775         (undo-tree-node-previous (undo-tree-current buffer-undo-tree)))
2776       (unless preserve-timestamps
2777     (setf (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree))
2778           (current-time)))
2779
2780       ;; if undoing-in-region, record current node, region and direction so we
2781       ;; can tell if undo-in-region is repeated, and re-activate mark if in
2782       ;; `transient-mark-mode'; if not, erase any leftover data
2783       (if (not undo-in-region)
2784       (undo-tree-node-clear-region-data current)
2785     (goto-char pos)
2786     ;; note: we deliberately want to store the region information in the
2787     ;; node *below* the now current one
2788     (setf (undo-tree-node-undo-beginning current) (region-beginning)
2789           (undo-tree-node-undo-end current) (region-end))
2790     (set-marker pos nil)))
2791
2792     ;; undo deactivates mark unless undoing-in-region
2793     (setq deactivate-mark (not undo-in-region))))
2794
2795
2796
2797 (defun undo-tree-redo (&optional arg)
2798   "Redo changes. A numeric ARG serves as a repeat count.
2799
2800 In Transient Mark mode when the mark is active, only redo changes
2801 within the current region. Similarly, when not in Transient Mark
2802 mode, just \\[universal-argument] as an argument limits redo to
2803 changes within the current region."
2804   (interactive "*P")
2805   ;; throw error if undo is disabled in buffer
2806   (when (eq buffer-undo-list t)
2807     (user-error "No undo information in this buffer"))
2808   (undo-tree-redo-1 arg)
2809   ;; inform user if at branch point
2810   (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))
2811
2812
2813 (defun undo-tree-redo-1 (&optional arg preserve-undo preserve-timestamps)
2814   ;; Internal redo function. An active mark in `transient-mark-mode', or
2815   ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-UNDO
2816   ;; causes the existing redo record to be preserved, rather than replacing it
2817   ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS
2818   ;; disables updating of timestamps in visited undo-tree nodes. (This latter
2819   ;; should *only* be used when temporarily visiting another undo state and
2820   ;; immediately returning to the original state afterwards. Otherwise, it
2821   ;; could cause history-discarding errors.)
2822   (let ((undo-in-progress t)
2823     (redo-in-region (and undo-tree-enable-undo-in-region
2824                  (or (region-active-p)
2825                  (and arg (not (numberp arg))))))
2826     pos current)
2827     ;; transfer entries accumulated in `buffer-undo-list' to
2828     ;; `buffer-undo-tree'
2829     (undo-list-transfer-to-tree)
2830
2831     (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
2832       ;; check if at bottom of undo tree
2833       (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree)))
2834     (user-error "No further redo information"))
2835
2836       ;; if region is active, or a non-numeric prefix argument was supplied,
2837       ;; try to pull out a new branch of changes affecting the region
2838       (when (and redo-in-region
2839          (not (undo-tree-pull-redo-in-region-branch
2840                (region-beginning) (region-end))))
2841     (user-error "No further redo information for region"))
2842
2843       ;; get next node (but DON'T advance current node in tree yet, in case
2844       ;; redoing fails)
2845       (setq current (undo-tree-current buffer-undo-tree)
2846         current (nth (undo-tree-node-branch current)
2847              (undo-tree-node-next current)))
2848       ;; remove any GC'd elements from node's redo list
2849       (decf (undo-tree-size buffer-undo-tree)
2850         (undo-list-byte-size (undo-tree-node-redo current)))
2851       (setf (undo-tree-node-redo current)
2852         (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
2853       (incf (undo-tree-size buffer-undo-tree)
2854         (undo-list-byte-size (undo-tree-node-redo current)))
2855       ;; redo one record from undo tree
2856       (when redo-in-region
2857     (setq pos (set-marker (make-marker) (point)))
2858     (set-marker-insertion-type pos t))
2859       (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current)))
2860       (undo-boundary)
2861       ;; advance current node in tree
2862       (setf (undo-tree-current buffer-undo-tree) current)
2863
2864       ;; if preserving old undo record, discard new undo entries that
2865       ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
2866       ;; elements from node's redo list
2867       (if preserve-undo
2868       (progn
2869         (undo-list-pop-changeset)
2870         (decf (undo-tree-size buffer-undo-tree)
2871           (undo-list-byte-size (undo-tree-node-undo current)))
2872         (setf (undo-tree-node-undo current)
2873           (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
2874         (incf (undo-tree-size buffer-undo-tree)
2875           (undo-list-byte-size (undo-tree-node-undo current))))
2876     ;; otherwise, record undo entries that `primitive-undo' has added to
2877     ;; `buffer-undo-list' in current node's undo record, replacing
2878     ;; existing entry if one already exists
2879     (decf (undo-tree-size buffer-undo-tree)
2880           (undo-list-byte-size (undo-tree-node-undo current)))
2881     (setf (undo-tree-node-undo current)
2882           (undo-list-pop-changeset 'discard-pos))
2883     (incf (undo-tree-size buffer-undo-tree)
2884           (undo-list-byte-size (undo-tree-node-undo current))))
2885
2886       ;; update timestamp
2887       (unless preserve-timestamps
2888     (setf (undo-tree-node-timestamp current) (current-time)))
2889
2890       ;; if redoing-in-region, record current node, region and direction so we
2891       ;; can tell if redo-in-region is repeated, and re-activate mark if in
2892       ;; `transient-mark-mode'
2893       (if (not redo-in-region)
2894       (undo-tree-node-clear-region-data current)
2895     (goto-char pos)
2896     (setf (undo-tree-node-redo-beginning current) (region-beginning)
2897           (undo-tree-node-redo-end current) (region-end))
2898     (set-marker pos nil)))
2899
2900     ;; redo deactivates the mark unless redoing-in-region
2901     (setq deactivate-mark (not redo-in-region))))
2902
2903
2904
2905 (defun undo-tree-switch-branch (branch)
2906   "Switch to a different BRANCH of the undo tree.
2907 This will affect which branch to descend when *redoing* changes
2908 using `undo-tree-redo'."
2909   (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg))
2910                          (and (not (eq buffer-undo-list t))
2911                   (or (undo-list-transfer-to-tree) t)
2912                   (let ((b (undo-tree-node-branch
2913                     (undo-tree-current
2914                      buffer-undo-tree))))
2915                 (cond
2916                  ;; switch to other branch if only 2
2917                  ((= (undo-tree-num-branches) 2) (- 1 b))
2918                  ;; prompt if more than 2
2919                  ((> (undo-tree-num-branches) 2)
2920                   (read-number
2921                    (format "Branch (0-%d, on %d): "
2922                        (1- (undo-tree-num-branches)) b)))
2923                  ))))))
2924   ;; throw error if undo is disabled in buffer
2925   (when (eq buffer-undo-list t)
2926     (user-error "No undo information in this buffer"))
2927   ;; sanity check branch number
2928   (when (<= (undo-tree-num-branches) 1)
2929     (user-error "Not at undo branch point"))
2930   (when (or (< branch 0) (> branch (1- (undo-tree-num-branches))))
2931     (user-error "Invalid branch number"))
2932   ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2933   (undo-list-transfer-to-tree)
2934   ;; switch branch
2935   (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
2936     branch)
2937   (message "Switched to branch %d" branch))
2938
2939
2940 (defun undo-tree-set (node &optional preserve-timestamps)
2941   ;; Set buffer to state corresponding to NODE. Returns intersection point
2942   ;; between path back from current node and path back from selected NODE.
2943   ;; Non-nil PRESERVE-TIMESTAMPS disables updating of timestamps in visited
2944   ;; undo-tree nodes. (This should *only* be used when temporarily visiting
2945   ;; another undo state and immediately returning to the original state
2946   ;; afterwards. Otherwise, it could cause history-discarding errors.)
2947   (let ((path (make-hash-table :test 'eq))
2948         (n node))
2949     (puthash (undo-tree-root buffer-undo-tree) t path)
2950     ;; build list of nodes leading back from selected node to root, updating
2951     ;; branches as we go to point down to selected node
2952     (while (progn
2953              (puthash n t path)
2954              (when (undo-tree-node-previous n)
2955                (setf (undo-tree-node-branch (undo-tree-node-previous n))
2956                      (undo-tree-position
2957                       n (undo-tree-node-next (undo-tree-node-previous n))))
2958                (setq n (undo-tree-node-previous n)))))
2959     ;; work backwards from current node until we intersect path back from
2960     ;; selected node
2961     (setq n (undo-tree-current buffer-undo-tree))
2962     (while (not (gethash n path))
2963       (setq n (undo-tree-node-previous n)))
2964     ;; ascend tree until intersection node
2965     (while (not (eq (undo-tree-current buffer-undo-tree) n))
2966       (undo-tree-undo-1 nil nil preserve-timestamps))
2967     ;; descend tree until selected node
2968     (while (not (eq (undo-tree-current buffer-undo-tree) node))
2969       (undo-tree-redo-1 nil nil preserve-timestamps))
2970     n))  ; return intersection node
2971
2972
2973
2974 (defun undo-tree-save-state-to-register (register)
2975   "Store current undo-tree state to REGISTER.
2976 The saved state can be restored using
2977 `undo-tree-restore-state-from-register'.
2978 Argument is a character, naming the register."
2979   (interactive "cUndo-tree state to register: ")
2980   ;; throw error if undo is disabled in buffer
2981   (when (eq buffer-undo-list t)
2982     (user-error "No undo information in this buffer"))
2983   ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2984   (undo-list-transfer-to-tree)
2985   ;; save current node to REGISTER
2986   (set-register
2987    register (registerv-make
2988          (undo-tree-make-register-data
2989           (current-buffer) (undo-tree-current buffer-undo-tree))
2990          :print-func 'undo-tree-register-data-print-func))
2991   ;; record REGISTER in current node, for visualizer
2992   (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree))
2993     register))
2994
2995
2996
2997 (defun undo-tree-restore-state-from-register (register)
2998   "Restore undo-tree state from REGISTER.
2999 The state must be saved using `undo-tree-save-state-to-register'.
3000 Argument is a character, naming the register."
3001   (interactive "*cRestore undo-tree state from register: ")
3002   ;; throw error if undo is disabled in buffer, or if register doesn't contain
3003   ;; an undo-tree node
3004   (let ((data (registerv-data (get-register register))))
3005     (cond
3006      ((eq buffer-undo-list t)
3007       (user-error "No undo information in this buffer"))
3008      ((not (undo-tree-register-data-p data))
3009       (user-error "Register doesn't contain undo-tree state"))
3010      ((not (eq (current-buffer) (undo-tree-register-data-buffer data)))
3011       (user-error "Register contains undo-tree state for a different buffer")))
3012     ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
3013     (undo-list-transfer-to-tree)
3014     ;; restore buffer state corresponding to saved node
3015     (undo-tree-set (undo-tree-register-data-node data))))
3016
3017
3018
3019
3020 ;;; =====================================================================
3021 ;;;                    Persistent storage commands
3022
3023 (defun undo-tree-make-history-save-file-name (file)
3024   "Create the undo history file name for FILE.
3025 Normally this is the file's name with \".\" prepended and
3026 \".~undo-tree~\" appended.
3027
3028 A match for FILE is sought in `undo-tree-history-directory-alist'
3029 \(see the documentation of that variable for details\). If the
3030 directory for the backup doesn't exist, it is created."
3031   (let* ((backup-directory-alist undo-tree-history-directory-alist)
3032      (name (make-backup-file-name-1 file)))
3033     (concat (file-name-directory name) "." (file-name-nondirectory name)
3034         ".~undo-tree~")))
3035
3036
3037 (defun undo-tree-save-history (&optional filename overwrite)
3038   "Store undo-tree history to file.
3039
3040 If optional argument FILENAME is omitted, default save file is
3041 \".<buffer-file-name>.~undo-tree\" if buffer is visiting a file.
3042 Otherwise, prompt for one.
3043
3044 If OVERWRITE is non-nil, any existing file will be overwritten
3045 without asking for confirmation."
3046   (interactive)
3047   (when (eq buffer-undo-list t)
3048     (user-error "No undo information in this buffer"))
3049   (undo-list-transfer-to-tree)
3050   (when (and buffer-undo-tree (not (eq buffer-undo-tree t)))
3051     (condition-case nil
3052     (undo-tree-kill-visualizer)
3053       (error (undo-tree-clear-visualizer-data buffer-undo-tree)))
3054     (let ((buff (current-buffer))
3055       tree)
3056       ;; get filename
3057       (unless filename
3058     (setq filename
3059           (if buffer-file-name
3060           (undo-tree-make-history-save-file-name buffer-file-name)
3061         (expand-file-name (read-file-name "File to save in: ") nil))))
3062       (when (or (not (file-exists-p filename))
3063         overwrite
3064         (yes-or-no-p (format "Overwrite \"%s\"? " filename)))
3065     (unwind-protect
3066         (progn
3067           ;; transform undo-tree into non-circular structure, and make
3068           ;; temporary copy
3069           (undo-tree-decircle buffer-undo-tree)
3070           (setq tree (copy-undo-tree buffer-undo-tree))
3071           ;; discard undo-tree object pool before saving
3072           (setf (undo-tree-object-pool tree) nil)
3073           ;; print undo-tree to file
3074           ;; NOTE: We use `with-temp-buffer' instead of `with-temp-file'
3075           ;;       to allow `auto-compression-mode' to take effect, in
3076           ;;       case user has overridden or advised the default
3077           ;;       `undo-tree-make-history-save-file-name' to add a
3078           ;;       compressed file extension.
3079           (with-auto-compression-mode
3080         (with-temp-buffer
3081           (prin1 (sha1 buff) (current-buffer))
3082           (terpri (current-buffer))
3083           (let ((print-circle t)) (prin1 tree (current-buffer)))
3084           (write-region nil nil filename))))
3085       ;; restore circular undo-tree data structure
3086       (undo-tree-recircle buffer-undo-tree))
3087     ))))
3088
3089
3090
3091 (defun undo-tree-load-history (&optional filename noerror)
3092   "Load undo-tree history from file.
3093
3094 If optional argument FILENAME is null, default load file is
3095 \".<buffer-file-name>.~undo-tree\" if buffer is visiting a file.
3096 Otherwise, prompt for one.
3097
3098 If optional argument NOERROR is non-nil, return nil instead of
3099 signaling an error if file is not found."
3100   (interactive)
3101   ;; get filename
3102   (unless filename
3103     (setq filename
3104       (if buffer-file-name
3105           (undo-tree-make-history-save-file-name buffer-file-name)
3106         (expand-file-name (read-file-name "File to load from: ") nil))))
3107
3108   ;; attempt to read undo-tree from FILENAME
3109   (catch 'load-error
3110     (unless (file-exists-p filename)
3111       (if noerror
3112       (throw 'load-error nil)
3113     (error "File \"%s\" does not exist; could not load undo-tree history"
3114            filename)))
3115     (let (buff hash tree)
3116       (setq buff (current-buffer))
3117       (with-auto-compression-mode
3118     (with-temp-buffer
3119       (insert-file-contents filename)
3120       (goto-char (point-min))
3121       (condition-case nil
3122           (setq hash (read (current-buffer)))
3123         (error
3124          (kill-buffer nil)
3125          (funcall (if noerror 'message 'user-error)
3126               "Error reading undo-tree history from \"%s\"" filename)
3127          (throw 'load-error nil)))
3128       (unless (string= (sha1 buff) hash)
3129         (kill-buffer nil)
3130         (funcall (if noerror 'message 'user-error)
3131              "Buffer has been modified; could not load undo-tree history")
3132         (throw 'load-error nil))
3133       (condition-case nil
3134           (setq tree (read (current-buffer)))
3135         (error
3136          (kill-buffer nil)
3137          (funcall (if noerror 'message 'error)
3138               "Error reading undo-tree history from \"%s\"" filename)
3139          (throw 'load-error nil)))
3140       (kill-buffer nil)))
3141       ;; initialise empty undo-tree object pool
3142       (setf (undo-tree-object-pool tree)
3143         (make-hash-table :test 'eq :weakness 'value))
3144       ;; restore circular undo-tree data structure
3145       (undo-tree-recircle tree)
3146       (setq buffer-undo-tree tree))))
3147
3148
3149
3150 ;; Versions of save/load functions for use in hooks
3151 (defun undo-tree-save-history-hook ()
3152   (when (and undo-tree-mode undo-tree-auto-save-history
3153          (not (eq buffer-undo-list t)))
3154     (undo-tree-save-history nil t) nil))
3155
3156 (defun undo-tree-load-history-hook ()
3157   (when (and undo-tree-mode undo-tree-auto-save-history
3158          (not (eq buffer-undo-list t))
3159          (not revert-buffer-in-progress-p))
3160     (undo-tree-load-history nil t)))
3161
3162
3163
3164
3165 ;;; =====================================================================
3166 ;;;                    Visualizer drawing functions
3167
3168 (defun undo-tree-visualize ()
3169   "Visualize the current buffer's undo tree."
3170   (interactive "*")
3171   (deactivate-mark)
3172   ;; throw error if undo is disabled in buffer
3173   (when (eq buffer-undo-list t)
3174     (user-error "No undo information in this buffer"))
3175   ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
3176   (undo-list-transfer-to-tree)
3177   ;; add hook to kill visualizer buffer if original buffer is changed
3178   (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t)
3179   ;; prepare *undo-tree* buffer, then draw tree in it
3180   (let ((undo-tree buffer-undo-tree)
3181         (buff (current-buffer))
3182     (display-buffer-mark-dedicated 'soft))
3183     (switch-to-buffer-other-window
3184      (get-buffer-create undo-tree-visualizer-buffer-name))
3185     (setq undo-tree-visualizer-parent-buffer buff)
3186     (setq undo-tree-visualizer-parent-mtime
3187       (and (buffer-file-name buff)
3188            (nth 5 (file-attributes (buffer-file-name buff)))))
3189     (setq undo-tree-visualizer-initial-node (undo-tree-current undo-tree))
3190     (setq undo-tree-visualizer-spacing
3191       (undo-tree-visualizer-calculate-spacing))
3192     (make-local-variable 'undo-tree-visualizer-timestamps)
3193     (make-local-variable 'undo-tree-visualizer-diff)
3194     (setq buffer-undo-tree undo-tree)
3195     (undo-tree-visualizer-mode)
3196     ;; FIXME; don't know why `undo-tree-visualizer-mode' clears this
3197     (setq buffer-undo-tree undo-tree)
3198     (set (make-local-variable 'undo-tree-visualizer-lazy-drawing)
3199      (or (eq undo-tree-visualizer-lazy-drawing t)
3200          (and (numberp undo-tree-visualizer-lazy-drawing)
3201           (>= (undo-tree-count undo-tree)
3202               undo-tree-visualizer-lazy-drawing))))
3203     (when undo-tree-visualizer-diff (undo-tree-visualizer-show-diff))
3204     (let ((inhibit-read-only t)) (undo-tree-draw-tree undo-tree))))
3205
3206
3207 (defun undo-tree-kill-visualizer (&rest _dummy)
3208   ;; Kill visualizer. Added to `before-change-functions' hook of original
3209   ;; buffer when visualizer is invoked.
3210   (unless (or undo-tree-inhibit-kill-visualizer
3211           (null (get-buffer undo-tree-visualizer-buffer-name)))
3212     (with-current-buffer undo-tree-visualizer-buffer-name
3213       (undo-tree-visualizer-quit))))
3214
3215
3216
3217 (defun undo-tree-draw-tree (undo-tree)
3218   ;; Draw undo-tree in current buffer starting from NODE (or root if nil).
3219   (let ((node (if undo-tree-visualizer-lazy-drawing
3220           (undo-tree-current undo-tree)
3221         (undo-tree-root undo-tree))))
3222     (erase-buffer)
3223     (setq undo-tree-visualizer-needs-extending-down nil
3224       undo-tree-visualizer-needs-extending-up nil)
3225     (undo-tree-clear-visualizer-data undo-tree)
3226     (undo-tree-compute-widths node)
3227     ;; lazy drawing starts vertically centred and displaced horizontally to
3228     ;; the left (window-width/4), since trees will typically grow right
3229     (if undo-tree-visualizer-lazy-drawing
3230     (progn
3231       (undo-tree-move-down (/ (window-height) 2))
3232       (undo-tree-move-forward (max 2 (/ (window-width) 4)))) ; left margin
3233       ;; non-lazy drawing starts in centre at top of buffer
3234       (undo-tree-move-down 1)  ; top margin
3235       (undo-tree-move-forward
3236        (max (/ (window-width) 2)
3237         (+ (undo-tree-node-char-lwidth node)
3238            ;; add space for left part of left-most time-stamp
3239            (if undo-tree-visualizer-timestamps
3240            (/ (- undo-tree-visualizer-spacing 4) 2)
3241          0)
3242            2))))  ; left margin
3243     ;; link starting node to its representation in visualizer
3244     (setf (undo-tree-node-marker node) (make-marker))
3245     (set-marker-insertion-type (undo-tree-node-marker node) nil)
3246     (move-marker (undo-tree-node-marker node) (point))
3247     ;; draw undo-tree
3248     (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)
3249       node-list)
3250       (if (not undo-tree-visualizer-lazy-drawing)
3251       (undo-tree-extend-down node t)
3252     (undo-tree-extend-down node)
3253     (undo-tree-extend-up node)
3254     (setq node-list undo-tree-visualizer-needs-extending-down
3255           undo-tree-visualizer-needs-extending-down nil)
3256     (while node-list (undo-tree-extend-down (pop node-list)))))
3257     ;; highlight active branch
3258     (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
3259       (undo-tree-highlight-active-branch
3260        (or undo-tree-visualizer-needs-extending-up
3261        (undo-tree-root undo-tree))))
3262     ;; highlight current node
3263     (undo-tree-draw-node (undo-tree-current undo-tree) 'current)))
3264
3265
3266 (defun undo-tree-extend-down (node &optional bottom)
3267   ;; Extend tree downwards starting from NODE and point. If BOTTOM is t,
3268   ;; extend all the way down to the leaves. If BOTTOM is a node, extend down
3269   ;; as far as that node. If BOTTOM is an integer, extend down as far as that
3270   ;; line. Otherwise, only extend visible portion of tree. NODE is assumed to
3271   ;; already have a node marker. Returns non-nil if anything was actually
3272   ;; extended.
3273   (let ((extended nil)
3274     (cur-stack (list node))
3275     next-stack)
3276     ;; don't bother extending if BOTTOM specifies an already-drawn node
3277     (unless (and (undo-tree-node-p bottom) (undo-tree-node-marker bottom))
3278       ;; draw nodes layer by layer
3279       (while (or cur-stack
3280          (prog1 (setq cur-stack next-stack)
3281            (setq next-stack nil)))
3282     (setq node (pop cur-stack))
3283     ;; if node is within range being drawn...
3284     (if (or (eq bottom t)
3285         (and (undo-tree-node-p bottom)
3286              (not (eq (undo-tree-node-previous node) bottom)))
3287         (and (integerp bottom)
3288              (>= bottom (line-number-at-pos
3289                  (undo-tree-node-marker node))))
3290         (and (null bottom)
3291              (pos-visible-in-window-p (undo-tree-node-marker node)
3292                           nil t)))
3293         ;; ...draw one layer of node's subtree (if not already drawn)
3294         (progn
3295           (unless (and (undo-tree-node-next node)
3296                (undo-tree-node-marker
3297                 (nth (undo-tree-node-branch node)
3298                  (undo-tree-node-next node))))
3299         (goto-char (undo-tree-node-marker node))
3300         (undo-tree-draw-subtree node)
3301         (setq extended t))
3302           (setq next-stack
3303             (append (undo-tree-node-next node) next-stack)))
3304       ;; ...otherwise, postpone drawing until later
3305       (push node undo-tree-visualizer-needs-extending-down))))
3306     extended))
3307
3308
3309 (defun undo-tree-extend-up (node &optional top)
3310   ;; Extend tree upwards starting from NODE. If TOP is t, extend all the way
3311   ;; to root. If TOP is a node, extend up as far as that node. If TOP is an
3312   ;; integer, extend up as far as that line. Otherwise, only extend visible
3313   ;; portion of tree. NODE is assumed to already have a node marker. Returns
3314   ;; non-nil if anything was actually extended.
3315   (let ((extended nil) parent)
3316     ;; don't bother extending if TOP specifies an already-drawn node
3317     (unless (and (undo-tree-node-p top) (undo-tree-node-marker top))
3318       (while node
3319     (setq parent (undo-tree-node-previous node))
3320     ;; if we haven't reached root...
3321     (if parent
3322         ;; ...and node is within range being drawn...
3323         (if (or (eq top t)
3324             (and (undo-tree-node-p top) (not (eq node top)))
3325             (and (integerp top)
3326              (< top (line-number-at-pos
3327                  (undo-tree-node-marker node))))
3328             (and (null top)
3329              ;; NOTE: we check point in case window-start is outdated
3330              (< (min (line-number-at-pos (point))
3331                  (line-number-at-pos (window-start)))
3332                 (line-number-at-pos
3333                  (undo-tree-node-marker node)))))
3334         ;; ...and it hasn't already been drawn
3335         (when (not (undo-tree-node-marker parent))
3336           ;; link parent node to its representation in visualizer
3337           (undo-tree-compute-widths parent)
3338           (undo-tree-move-to-parent node)
3339           (setf (undo-tree-node-marker parent) (make-marker))
3340           (set-marker-insertion-type
3341            (undo-tree-node-marker parent) nil)
3342           (move-marker (undo-tree-node-marker parent) (point))
3343           ;; draw subtree beneath parent
3344           (setq undo-tree-visualizer-needs-extending-down
3345             (nconc (delq node (undo-tree-draw-subtree parent))
3346                    undo-tree-visualizer-needs-extending-down))
3347           (setq extended t))
3348           ;; ...otherwise, postpone drawing for later and exit
3349           (setq undo-tree-visualizer-needs-extending-up (when parent node)
3350             parent nil))
3351
3352       ;; if we've reached root, stop extending and add top margin
3353       (setq undo-tree-visualizer-needs-extending-up nil)
3354       (goto-char (undo-tree-node-marker node))
3355       (undo-tree-move-up 1)  ; top margin
3356       (delete-region (point-min) (line-beginning-position)))
3357     ;; next iteration
3358     (setq node parent)))
3359     extended))
3360
3361
3362 (defun undo-tree-expand-down (from &optional to)
3363   ;; Expand tree downwards. FROM is the node to start expanding from. Stop
3364   ;; expanding at TO if specified. Otherwise, just expand visible portion of
3365   ;; tree and highlight active branch from FROM.
3366   (when undo-tree-visualizer-needs-extending-down
3367     (let ((inhibit-read-only t)
3368       node-list extended)
3369       ;; extend down as far as TO node
3370       (when to
3371     (setq extended (undo-tree-extend-down from to))
3372     (goto-char (undo-tree-node-marker to))
3373     (redisplay t))  ; force redisplay to scroll buffer if necessary
3374       ;; extend visible portion of tree downwards
3375       (setq node-list undo-tree-visualizer-needs-extending-down
3376         undo-tree-visualizer-needs-extending-down nil)
3377       (when node-list
3378     (dolist (n node-list)
3379       (when (undo-tree-extend-down n) (setq extended t)))
3380     ;; highlight active branch in newly-extended-down portion, if any
3381     (when extended
3382       (let ((undo-tree-insert-face
3383          'undo-tree-visualizer-active-branch-face))
3384         (undo-tree-highlight-active-branch from)))))))
3385
3386
3387 (defun undo-tree-expand-up (from &optional to)
3388   ;; Expand tree upwards. FROM is the node to start expanding from, TO is the
3389   ;; node to stop expanding at. If TO node isn't specified, just expand visible
3390   ;; portion of tree and highlight active branch down to FROM.
3391   (when undo-tree-visualizer-needs-extending-up
3392     (let ((inhibit-read-only t)
3393       extended node-list)
3394       ;; extend up as far as TO node
3395       (when to
3396     (setq extended (undo-tree-extend-up from to))
3397     (goto-char (undo-tree-node-marker to))
3398     ;; simulate auto-scrolling if close to top of buffer
3399     (when (<= (line-number-at-pos (point)) scroll-margin)
3400       (undo-tree-move-up (if (= scroll-conservatively 0)
3401                  (/ (window-height) 2) 3))
3402       (when (undo-tree-extend-up to) (setq extended t))
3403       (goto-char (undo-tree-node-marker to))
3404       (unless (= scroll-conservatively 0) (recenter scroll-margin))))
3405       ;; extend visible portion of tree upwards
3406       (and undo-tree-visualizer-needs-extending-up
3407        (undo-tree-extend-up undo-tree-visualizer-needs-extending-up)
3408        (setq extended t))
3409       ;; extend visible portion of tree downwards
3410       (setq node-list undo-tree-visualizer-needs-extending-down
3411         undo-tree-visualizer-needs-extending-down nil)
3412       (dolist (n node-list) (undo-tree-extend-down n))
3413       ;; highlight active branch in newly-extended-up portion, if any
3414       (when extended
3415     (let ((undo-tree-insert-face
3416            'undo-tree-visualizer-active-branch-face))
3417       (undo-tree-highlight-active-branch
3418        (or undo-tree-visualizer-needs-extending-up
3419            (undo-tree-root buffer-undo-tree))
3420        from))))))
3421
3422
3423
3424 (defun undo-tree-highlight-active-branch (node &optional end)
3425   ;; Draw highlighted active branch below NODE in current buffer. Stop
3426   ;; highlighting at END node if specified.
3427   (let ((stack (list node)))
3428     ;; draw active branch
3429     (while stack
3430       (setq node (pop stack))
3431       (unless (or (eq node end)
3432           (memq node undo-tree-visualizer-needs-extending-down))
3433     (goto-char (undo-tree-node-marker node))
3434     (setq node (undo-tree-draw-subtree node 'active)
3435           stack (nconc stack node))))))
3436
3437
3438 (defun undo-tree-draw-node (node &optional current)
3439   ;; Draw symbol representing NODE in visualizer. If CURRENT is non-nil, node
3440   ;; is current node.
3441   (goto-char (undo-tree-node-marker node))
3442   (when undo-tree-visualizer-timestamps
3443     (undo-tree-move-backward (/ undo-tree-visualizer-spacing 2)))
3444
3445   (let* ((undo-tree-insert-face (and undo-tree-insert-face
3446                      (or (and (consp undo-tree-insert-face)
3447                           undo-tree-insert-face)
3448                      (list undo-tree-insert-face))))
3449      (register (undo-tree-node-register node))
3450      (unmodified (if undo-tree-visualizer-parent-mtime
3451              (undo-tree-node-unmodified-p
3452               node undo-tree-visualizer-parent-mtime)
3453                (undo-tree-node-unmodified-p node)))
3454     node-string)
3455     ;; check node's register (if any) still stores appropriate undo-tree state
3456     (unless (and register
3457          (undo-tree-register-data-p
3458           (registerv-data (get-register register)))
3459          (eq node (undo-tree-register-data-node
3460                (registerv-data (get-register register)))))
3461       (setq register nil))
3462     ;; represent node by different symbols, depending on whether it's the
3463     ;; current node, is saved in a register, or corresponds to an unmodified
3464     ;; buffer
3465     (setq node-string
3466         (cond
3467          (undo-tree-visualizer-timestamps
3468             (undo-tree-timestamp-to-string
3469              (undo-tree-node-timestamp node)
3470          undo-tree-visualizer-relative-timestamps
3471          current register))
3472          (register (char-to-string register))
3473          (unmodified "s")
3474          (current "x")
3475          (t "o"))
3476       undo-tree-insert-face
3477         (nconc
3478          (cond
3479           (current    '(undo-tree-visualizer-current-face))
3480           (unmodified '(undo-tree-visualizer-unmodified-face))
3481           (register   '(undo-tree-visualizer-register-face)))
3482          undo-tree-insert-face))
3483     ;; draw node and link it to its representation in visualizer
3484     (undo-tree-insert node-string)
3485     (undo-tree-move-backward (if undo-tree-visualizer-timestamps
3486                  (1+ (/ undo-tree-visualizer-spacing 2))
3487                    1))
3488     (move-marker (undo-tree-node-marker node) (point))
3489     (put-text-property (point) (1+ (point)) 'undo-tree-node node)))
3490
3491
3492 (defun undo-tree-draw-subtree (node &optional active-branch)
3493   ;; Draw subtree rooted at NODE. The subtree will start from point.
3494   ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE. Returns
3495   ;; list of nodes below NODE.
3496   (let ((num-children (length (undo-tree-node-next node)))
3497         node-list pos trunk-pos n)
3498     ;; draw node itself
3499     (undo-tree-draw-node node)
3500
3501     (cond
3502      ;; if we're at a leaf node, we're done
3503      ((= num-children 0))
3504
3505      ;; if node has only one child, draw it (not strictly necessary to deal
3506      ;; with this case separately, but as it's by far the most common case
3507      ;; this makes the code clearer and more efficient)
3508      ((= num-children 1)
3509       (undo-tree-move-down 1)
3510       (undo-tree-insert ?|)
3511       (undo-tree-move-backward 1)
3512       (undo-tree-move-down 1)
3513       (undo-tree-insert ?|)
3514       (undo-tree-move-backward 1)
3515       (undo-tree-move-down 1)
3516       (setq n (car (undo-tree-node-next node)))
3517       ;; link next node to its representation in visualizer
3518       (unless (markerp (undo-tree-node-marker n))
3519         (setf (undo-tree-node-marker n) (make-marker))
3520         (set-marker-insertion-type (undo-tree-node-marker n) nil))
3521       (move-marker (undo-tree-node-marker n) (point))
3522       ;; add next node to list of nodes to draw next
3523       (push n node-list))
3524
3525      ;; if node has multiple children, draw branches
3526      (t
3527       (undo-tree-move-down 1)
3528       (undo-tree-insert ?|)
3529       (undo-tree-move-backward 1)
3530       (move-marker (setq trunk-pos (make-marker)) (point))
3531       ;; left subtrees
3532       (undo-tree-move-backward
3533        (- (undo-tree-node-char-lwidth node)
3534           (undo-tree-node-char-lwidth
3535            (car (undo-tree-node-next node)))))
3536       (move-marker (setq pos (make-marker)) (point))
3537       (setq n (cons nil (undo-tree-node-next node)))
3538       (dotimes (i (/ num-children 2))
3539         (setq n (cdr n))
3540         (when (or (null active-branch)
3541                   (eq (car n)
3542                       (nth (undo-tree-node-branch node)
3543                            (undo-tree-node-next node))))
3544           (undo-tree-move-forward 2)
3545           (undo-tree-insert ?_ (- trunk-pos pos 2))
3546           (goto-char pos)
3547           (undo-tree-move-forward 1)
3548           (undo-tree-move-down 1)
3549           (undo-tree-insert ?/)
3550           (undo-tree-move-backward 2)
3551           (undo-tree-move-down 1)
3552           ;; link node to its representation in visualizer
3553           (unless (markerp (undo-tree-node-marker (car n)))
3554             (setf (undo-tree-node-marker (car n)) (make-marker))
3555             (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
3556           (move-marker (undo-tree-node-marker (car n)) (point))
3557           ;; add node to list of nodes to draw next
3558           (push (car n) node-list))
3559         (goto-char pos)
3560         (undo-tree-move-forward
3561          (+ (undo-tree-node-char-rwidth (car n))
3562             (undo-tree-node-char-lwidth (cadr n))
3563             undo-tree-visualizer-spacing 1))
3564         (move-marker pos (point)))
3565       ;; middle subtree (only when number of children is odd)
3566       (when (= (mod num-children 2) 1)
3567         (setq n (cdr n))
3568         (when (or (null active-branch)
3569                   (eq (car n)
3570                       (nth (undo-tree-node-branch node)
3571                            (undo-tree-node-next node))))
3572           (undo-tree-move-down 1)
3573           (undo-tree-insert ?|)
3574           (undo-tree-move-backward 1)
3575           (undo-tree-move-down 1)
3576           ;; link node to its representation in visualizer
3577           (unless (markerp (undo-tree-node-marker (car n)))
3578             (setf (undo-tree-node-marker (car n)) (make-marker))
3579             (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
3580           (move-marker (undo-tree-node-marker (car n)) (point))
3581           ;; add node to list of nodes to draw next
3582           (push (car n) node-list))
3583         (goto-char pos)
3584         (undo-tree-move-forward
3585          (+ (undo-tree-node-char-rwidth (car n))
3586             (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
3587             undo-tree-visualizer-spacing 1))
3588         (move-marker pos (point)))
3589       ;; right subtrees
3590       (move-marker trunk-pos (1+ trunk-pos))
3591       (dotimes (i (/ num-children 2))
3592         (setq n (cdr n))
3593         (when (or (null active-branch)
3594                   (eq (car n)
3595                       (nth (undo-tree-node-branch node)
3596                            (undo-tree-node-next node))))
3597           (goto-char trunk-pos)
3598           (undo-tree-insert ?_ (- pos trunk-pos 1))
3599           (goto-char pos)
3600           (undo-tree-move-backward 1)
3601           (undo-tree-move-down 1)
3602           (undo-tree-insert ?\\)
3603           (undo-tree-move-down 1)
3604           ;; link node to its representation in visualizer
3605           (unless (markerp (undo-tree-node-marker (car n)))
3606             (setf (undo-tree-node-marker (car n)) (make-marker))
3607             (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
3608           (move-marker (undo-tree-node-marker (car n)) (point))
3609           ;; add node to list of nodes to draw next
3610           (push (car n) node-list))
3611         (when (cdr n)
3612           (goto-char pos)
3613           (undo-tree-move-forward
3614            (+ (undo-tree-node-char-rwidth (car n))
3615               (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
3616               undo-tree-visualizer-spacing 1))
3617           (move-marker pos (point))))
3618       ))
3619     ;; return list of nodes to draw next
3620     (nreverse node-list)))
3621
3622
3623 (defun undo-tree-node-char-lwidth (node)
3624   ;; Return left-width of NODE measured in characters.
3625   (if (= (length (undo-tree-node-next node)) 0) 0
3626     (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node))
3627        (if (= (undo-tree-node-cwidth node) 0)
3628            (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
3629
3630
3631 (defun undo-tree-node-char-rwidth (node)
3632   ;; Return right-width of NODE measured in characters.
3633   (if (= (length (undo-tree-node-next node)) 0) 0
3634     (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node))
3635        (if (= (undo-tree-node-cwidth node) 0)
3636            (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
3637
3638
3639 (defun undo-tree-insert (str &optional arg)
3640   ;; Insert character or string STR ARG times, overwriting, and using
3641   ;; `undo-tree-insert-face'.
3642   (unless arg (setq arg 1))
3643   (when (characterp str)
3644     (setq str (make-string arg str))
3645     (setq arg 1))
3646   (dotimes (i arg) (insert str))
3647   (setq arg (* arg (length str)))
3648   (undo-tree-move-forward arg)
3649   ;; make sure mark isn't active, otherwise `backward-delete-char' might
3650   ;; delete region instead of single char if transient-mark-mode is enabled
3651   (setq mark-active nil)
3652   (backward-delete-char arg)
3653   (when undo-tree-insert-face
3654     (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face)))
3655
3656
3657 (defun undo-tree-move-down (&optional arg)
3658   ;; Move down, extending buffer if necessary.
3659   (let ((row (line-number-at-pos))
3660         (col (current-column))
3661         line)
3662     (unless arg (setq arg 1))
3663     (forward-line arg)
3664     (setq line (line-number-at-pos))
3665     ;; if buffer doesn't have enough lines, add some
3666     (when (/= line (+ row arg))
3667       (cond
3668        ((< arg 0)
3669     (insert (make-string (- line row arg) ?\n))
3670     (forward-line (+ arg (- row line))))
3671        (t (insert (make-string (- arg (- line row)) ?\n)))))
3672     (undo-tree-move-forward col)))
3673
3674
3675 (defun undo-tree-move-up (&optional arg)
3676   ;; Move up, extending buffer if necessary.
3677   (unless arg (setq arg 1))
3678   (undo-tree-move-down (- arg)))
3679
3680
3681 (defun undo-tree-move-forward (&optional arg)
3682   ;; Move forward, extending buffer if necessary.
3683   (unless arg (setq arg 1))
3684   (let (n)
3685     (cond
3686      ((>= arg 0)
3687       (setq n (- (line-end-position) (point)))
3688       (if (> n arg)
3689       (forward-char arg)
3690     (end-of-line)
3691     (insert (make-string (- arg n) ? ))))
3692      ((< arg 0)
3693       (setq arg (- arg))
3694       (setq n (- (point) (line-beginning-position)))
3695       (when (< (- n 2) arg)  ; -2 to create left-margin
3696     ;; no space left - shift entire buffer contents right!
3697     (let ((pos (move-marker (make-marker) (point))))
3698       (set-marker-insertion-type pos t)
3699       (goto-char (point-min))
3700       (while (not (eobp))
3701         (insert-before-markers (make-string (- arg -2 n) ? ))
3702         (forward-line 1))
3703       (goto-char pos)))
3704       (backward-char arg)))))
3705
3706
3707 (defun undo-tree-move-backward (&optional arg)
3708   ;; Move backward, extending buffer if necessary.
3709   (unless arg (setq arg 1))
3710   (undo-tree-move-forward (- arg)))
3711
3712
3713 (defun undo-tree-move-to-parent (node)
3714   ;; Move to position of parent of NODE, extending buffer if necessary.
3715   (let* ((parent (undo-tree-node-previous node))
3716      (n (undo-tree-node-next parent))
3717      (l (length n)) p)
3718     (goto-char (undo-tree-node-marker node))
3719     (unless (= l 1)
3720       ;; move horizontally
3721       (setq p (undo-tree-position node n))
3722       (cond
3723        ;; node in centre subtree: no horizontal movement
3724        ((and (= (mod l 2) 1) (= p (/ l 2))))
3725        ;; node in left subtree: move right
3726        ((< p (/ l 2))
3727     (setq n (nthcdr p n))
3728     (undo-tree-move-forward
3729      (+ (undo-tree-node-char-rwidth (car n))
3730         (/ undo-tree-visualizer-spacing 2) 1))
3731     (dotimes (i (- (/ l 2) p 1))
3732       (setq n (cdr n))
3733       (undo-tree-move-forward
3734        (+ (undo-tree-node-char-lwidth (car n))
3735           (undo-tree-node-char-rwidth (car n))
3736           undo-tree-visualizer-spacing 1)))
3737     (when (= (mod l 2) 1)
3738       (setq n (cdr n))
3739       (undo-tree-move-forward
3740        (+ (undo-tree-node-char-lwidth (car n))
3741           (/ undo-tree-visualizer-spacing 2) 1))))
3742        (t ;; node in right subtree: move left
3743     (setq n (nthcdr (/ l 2) n))
3744     (when (= (mod l 2) 1)
3745       (undo-tree-move-backward
3746        (+ (undo-tree-node-char-rwidth (car n))
3747           (/ undo-tree-visualizer-spacing 2) 1))
3748       (setq n (cdr n)))
3749     (dotimes (i (- p (/ l 2) (mod l 2)))
3750       (undo-tree-move-backward
3751        (+ (undo-tree-node-char-lwidth (car n))
3752           (undo-tree-node-char-rwidth (car n))
3753           undo-tree-visualizer-spacing 1))
3754       (setq n (cdr n)))
3755     (undo-tree-move-backward
3756      (+ (undo-tree-node-char-lwidth (car n))
3757         (/ undo-tree-visualizer-spacing 2) 1)))))
3758     ;; move vertically
3759     (undo-tree-move-up 3)))
3760
3761
3762 (defun undo-tree-timestamp-to-string
3763   (timestamp &optional relative current register)
3764   ;; Convert TIMESTAMP to string (either absolute or RELATVE time), indicating
3765   ;; if it's the CURRENT node and/or has an associated REGISTER.
3766   (if relative
3767       ;; relative time
3768       (let ((time (floor (float-time
3769               (subtract-time (current-time) timestamp))))
3770         n)
3771     (setq time
3772           ;; years
3773           (if (> (setq n (/ time 315360000)) 0)
3774           (if (> n 999) "-ages" (format "-%dy" n))
3775         (setq time (% time 315360000))
3776         ;; days
3777         (if (> (setq n (/ time 86400)) 0)
3778             (format "-%dd" n)
3779           (setq time (% time 86400))
3780           ;; hours
3781           (if (> (setq n (/ time 3600)) 0)
3782               (format "-%dh" n)
3783             (setq time (% time 3600))
3784             ;; mins
3785             (if (> (setq n (/ time 60)) 0)
3786             (format "-%dm" n)
3787               ;; secs
3788               (format "-%ds" (% time 60)))))))
3789     (setq time (concat
3790             (if current "*" " ")
3791             time
3792             (if register (concat "[" (char-to-string register) "]")
3793               "   ")))
3794     (setq n (length time))
3795     (if (< n 9)
3796         (concat (make-string (- 9 n) ? ) time)
3797       time))
3798     ;; absolute time
3799     (concat (if current " *" "  ")
3800         (format-time-string "%H:%M:%S" timestamp)
3801         (if register
3802         (concat "[" (char-to-string register) "]")
3803           "   "))))
3804
3805
3806
3807
3808 ;;; =====================================================================
3809 ;;;                        Visualizer commands
3810
3811 (define-derived-mode
3812   undo-tree-visualizer-mode special-mode "undo-tree-visualizer"
3813   "Major mode used in undo-tree visualizer.
3814
3815 The undo-tree visualizer can only be invoked from a buffer in
3816 which `undo-tree-mode' is enabled. The visualizer displays the
3817 undo history tree graphically, and allows you to browse around
3818 the undo history, undoing or redoing the corresponding changes in
3819 the parent buffer.
3820
3821 Within the undo-tree visualizer, the following keys are available:
3822
3823   \\{undo-tree-visualizer-mode-map}"
3824   :syntax-table nil
3825   :abbrev-table nil
3826   (setq truncate-lines t)
3827   (setq cursor-type nil)
3828   (setq undo-tree-visualizer-selected-node nil))
3829
3830
3831
3832 (defun undo-tree-visualize-undo (&optional arg)
3833   "Undo changes. A numeric ARG serves as a repeat count."
3834   (interactive "p")
3835   (let ((old (undo-tree-current buffer-undo-tree))
3836     current)
3837     ;; unhighlight old current node
3838     (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)
3839       (inhibit-read-only t))
3840       (undo-tree-draw-node old))
3841     ;; undo in parent buffer
3842     (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
3843     (deactivate-mark)
3844     (unwind-protect
3845     (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-undo-1 arg))
3846       (setq current (undo-tree-current buffer-undo-tree))
3847       (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
3848       ;; when using lazy drawing, extend tree upwards as required
3849       (when undo-tree-visualizer-lazy-drawing
3850     (undo-tree-expand-up old current))
3851       ;; highlight new current node
3852       (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current))
3853       ;; update diff display, if any
3854       (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))))
3855
3856
3857 (defun undo-tree-visualize-redo (&optional arg)
3858   "Redo changes. A numeric ARG serves as a repeat count."
3859   (interactive "p")
3860   (let ((old (undo-tree-current buffer-undo-tree))
3861     current)
3862     ;; unhighlight old current node
3863     (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)
3864       (inhibit-read-only t))
3865       (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
3866     ;; redo in parent buffer
3867     (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
3868     (deactivate-mark)
3869     (unwind-protect
3870     (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-redo-1 arg))
3871       (setq current (undo-tree-current buffer-undo-tree))
3872       (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
3873       ;; when using lazy drawing, extend tree downwards as required
3874       (when undo-tree-visualizer-lazy-drawing
3875     (undo-tree-expand-down old current))
3876       ;; highlight new current node
3877       (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current))
3878       ;; update diff display, if any
3879       (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))))
3880
3881
3882 (defun undo-tree-visualize-switch-branch-right (arg)
3883   "Switch to next branch of the undo tree.
3884 This will affect which branch to descend when *redoing* changes
3885 using `undo-tree-redo' or `undo-tree-visualizer-redo'."
3886   (interactive "p")
3887   ;; un-highlight old active branch below current node
3888   (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3889   (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)
3890     (inhibit-read-only t))
3891     (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
3892   ;; increment branch
3893   (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree))))
3894   (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
3895         (cond
3896          ((>= (+ branch arg) (undo-tree-num-branches))
3897           (1- (undo-tree-num-branches)))
3898          ((<= (+ branch arg) 0) 0)
3899          (t (+ branch arg))))
3900   (let ((inhibit-read-only t))
3901     ;; highlight new active branch below current node
3902     (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3903     (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
3904       (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
3905     ;; re-highlight current node
3906     (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current))))
3907
3908
3909 (defun undo-tree-visualize-switch-branch-left (arg)
3910   "Switch to previous branch of the undo tree.
3911 This will affect which branch to descend when *redoing* changes
3912 using `undo-tree-redo' or `undo-tree-visualizer-redo'."
3913   (interactive "p")
3914   (undo-tree-visualize-switch-branch-right (- arg)))
3915
3916
3917 (defun undo-tree-visualizer-quit ()
3918   "Quit the undo-tree visualizer."
3919   (interactive)
3920   (undo-tree-clear-visualizer-data buffer-undo-tree)
3921   ;; remove kill visualizer hook from parent buffer
3922   (unwind-protect
3923       (with-current-buffer undo-tree-visualizer-parent-buffer
3924     (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t))
3925     ;; kill diff buffer, if any
3926     (when undo-tree-visualizer-diff (undo-tree-visualizer-hide-diff))
3927     (let ((parent undo-tree-visualizer-parent-buffer)
3928       window)
3929       ;; kill visualizer buffer
3930       (kill-buffer nil)
3931       ;; switch back to parent buffer
3932       (unwind-protect
3933       (if (setq window (get-buffer-window parent))
3934           (select-window window)
3935         (switch-to-buffer parent))))))
3936
3937
3938 (defun undo-tree-visualizer-abort ()
3939   "Quit the undo-tree visualizer and return buffer to original state."
3940   (interactive)
3941   (let ((node undo-tree-visualizer-initial-node))
3942     (undo-tree-visualizer-quit)
3943     (undo-tree-set node)))
3944
3945
3946 (defun undo-tree-visualizer-set (&optional pos)
3947   "Set buffer to state corresponding to undo tree node
3948 at POS, or point if POS is nil."
3949   (interactive)
3950   (unless pos (setq pos (point)))
3951   (let ((node (get-text-property pos 'undo-tree-node)))
3952     (when node
3953       ;; set parent buffer to state corresponding to node at POS
3954       (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
3955       (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-set node))
3956       (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
3957       ;; re-draw undo tree
3958       (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree))
3959       (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))))
3960
3961
3962 (defun undo-tree-visualizer-mouse-set (pos)
3963   "Set buffer to state corresponding to undo tree node
3964 at mouse event POS."
3965   (interactive "@e")
3966   (undo-tree-visualizer-set (event-start (nth 1 pos))))
3967
3968
3969 (defun undo-tree-visualize-undo-to-x (&optional x)
3970   "Undo to last branch point, register, or saved state.
3971 If X is the symbol `branch', undo to last branch point. If X is
3972 the symbol `register', undo to last register. If X is the sumbol
3973 `saved', undo to last saved state. If X is null, undo to first of
3974 these that's encountered.
3975
3976 Interactively, a single \\[universal-argument] specifies
3977 `branch', a double \\[universal-argument] \\[universal-argument]
3978 specifies `saved', and a negative prefix argument specifies
3979 `register'."
3980   (interactive "P")
3981   (when (and (called-interactively-p 'any) x)
3982     (setq x (prefix-numeric-value x)
3983       x (cond
3984          ((< x 0)  'register)
3985          ((<= x 4) 'branch)
3986          (t        'saved))))
3987   (let ((current (if undo-tree-visualizer-selection-mode
3988              undo-tree-visualizer-selected-node
3989            (undo-tree-current buffer-undo-tree)))
3990     (diff undo-tree-visualizer-diff)
3991     r)
3992     (undo-tree-visualizer-hide-diff)
3993     (while (and (undo-tree-node-previous current)
3994         (or (if undo-tree-visualizer-selection-mode
3995             (progn
3996               (undo-tree-visualizer-select-previous)
3997               (setq current undo-tree-visualizer-selected-node))
3998               (undo-tree-visualize-undo)
3999               (setq current (undo-tree-current buffer-undo-tree)))
4000             t)
4001                  ;; branch point
4002         (not (or (and (or (null x) (eq x 'branch))
4003                   (> (undo-tree-num-branches) 1))
4004              ;; register
4005              (and (or (null x) (eq x 'register))
4006                   (setq r (undo-tree-node-register current))
4007                   (undo-tree-register-data-p
4008                    (setq r (registerv-data (get-register r))))
4009                   (eq current (undo-tree-register-data-node r)))
4010              ;; saved state
4011              (and (or (null x) (eq x 'saved))
4012                   (undo-tree-node-unmodified-p current))
4013              ))))
4014     ;; update diff display, if any
4015     (when diff
4016       (undo-tree-visualizer-show-diff
4017        (when undo-tree-visualizer-selection-mode
4018      undo-tree-visualizer-selected-node)))))
4019
4020
4021 (defun undo-tree-visualize-redo-to-x (&optional x)
4022   "Redo to last branch point, register, or saved state.
4023 If X is the symbol `branch', redo to last branch point. If X is
4024 the symbol `register', redo to last register. If X is the sumbol
4025 `saved', redo to last saved state. If X is null, redo to first of
4026 these that's encountered.
4027
4028 Interactively, a single \\[universal-argument] specifies
4029 `branch', a double \\[universal-argument] \\[universal-argument]
4030 specifies `saved', and a negative prefix argument specifies
4031 `register'."
4032   (interactive "P")
4033   (when (and (called-interactively-p 'any) x)
4034     (setq x (prefix-numeric-value x)
4035       x (cond
4036          ((< x 0)  'register)
4037          ((<= x 4) 'branch)
4038          (t        'saved))))
4039   (let ((current (if undo-tree-visualizer-selection-mode
4040              undo-tree-visualizer-selected-node
4041            (undo-tree-current buffer-undo-tree)))
4042     (diff undo-tree-visualizer-diff)
4043     r)
4044     (undo-tree-visualizer-hide-diff)
4045     (while (and (undo-tree-node-next current)
4046         (or (if undo-tree-visualizer-selection-mode
4047             (progn
4048               (undo-tree-visualizer-select-next)
4049               (setq current undo-tree-visualizer-selected-node))
4050               (undo-tree-visualize-redo)
4051               (setq current (undo-tree-current buffer-undo-tree)))
4052             t)
4053                  ;; branch point
4054         (not (or (and (or (null x) (eq x 'branch))
4055                   (> (undo-tree-num-branches) 1))
4056              ;; register
4057              (and (or (null x) (eq x 'register))
4058                   (setq r (undo-tree-node-register current))
4059                   (undo-tree-register-data-p
4060                    (setq r (registerv-data (get-register r))))
4061                   (eq current (undo-tree-register-data-node r)))
4062              ;; saved state
4063              (and (or (null x) (eq x 'saved))
4064                   (undo-tree-node-unmodified-p current))
4065              ))))
4066     ;; update diff display, if any
4067     (when diff
4068       (undo-tree-visualizer-show-diff
4069        (when undo-tree-visualizer-selection-mode
4070      undo-tree-visualizer-selected-node)))))
4071
4072
4073 (defun undo-tree-visualizer-toggle-timestamps ()
4074   "Toggle display of time-stamps."
4075   (interactive)
4076   (setq undo-tree-visualizer-timestamps (not undo-tree-visualizer-timestamps))
4077   (setq undo-tree-visualizer-spacing (undo-tree-visualizer-calculate-spacing))
4078   ;; redraw tree
4079   (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree)))
4080
4081
4082 (defun undo-tree-visualizer-scroll-left (&optional arg)
4083   (interactive "p")
4084   (scroll-left (or arg 1) t))
4085
4086
4087 (defun undo-tree-visualizer-scroll-right (&optional arg)
4088   (interactive "p")
4089   (scroll-right (or arg 1) t))
4090
4091
4092 (defun undo-tree-visualizer-scroll-up (&optional arg)
4093   (interactive "P")
4094   (if (or (and (numberp arg) (< arg 0)) (eq arg '-))
4095       (undo-tree-visualizer-scroll-down arg)
4096     ;; scroll up and expand newly-visible portion of tree
4097     (unwind-protect
4098     (scroll-up-command arg)
4099       (undo-tree-expand-down
4100        (nth (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
4101         (undo-tree-node-next (undo-tree-current buffer-undo-tree)))))
4102     ;; signal error if at eob
4103     (when (and (not undo-tree-visualizer-needs-extending-down) (eobp))
4104       (scroll-up))))
4105
4106
4107 (defun undo-tree-visualizer-scroll-down (&optional arg)
4108   (interactive "P")
4109   (if (or (and (numberp arg) (< arg 0)) (eq arg '-))
4110       (undo-tree-visualizer-scroll-up arg)
4111     ;; ensure there's enough room at top of buffer to scroll
4112     (let ((scroll-lines
4113        (or arg (- (window-height) next-screen-context-lines)))
4114       (window-line (1- (line-number-at-pos (window-start)))))
4115       (when (and undo-tree-visualizer-needs-extending-up
4116          (< window-line scroll-lines))
4117     (let ((inhibit-read-only t))
4118       (goto-char (point-min))
4119       (undo-tree-move-up (- scroll-lines window-line)))))
4120     ;; scroll down and expand newly-visible portion of tree
4121     (unwind-protect
4122     (scroll-down-command arg)
4123       (undo-tree-expand-up
4124        (undo-tree-node-previous (undo-tree-current buffer-undo-tree))))
4125     ;; signal error if at bob
4126     (when (and (not undo-tree-visualizer-needs-extending-down) (bobp))
4127       (scroll-down))))
4128
4129
4130
4131
4132 ;;; =====================================================================
4133 ;;;                    Visualizer selection mode
4134
4135 (define-minor-mode undo-tree-visualizer-selection-mode
4136   "Toggle mode to select nodes in undo-tree visualizer."
4137   :lighter "Select"
4138   :keymap undo-tree-visualizer-selection-mode-map
4139   :group undo-tree
4140   (cond
4141    ;; enable selection mode
4142    (undo-tree-visualizer-selection-mode
4143     (setq cursor-type 'box)
4144     (setq undo-tree-visualizer-selected-node
4145       (undo-tree-current buffer-undo-tree))
4146     ;; erase diff (if any), as initially selected node is identical to current
4147     (when undo-tree-visualizer-diff
4148       (let ((buff (get-buffer undo-tree-diff-buffer-name))
4149         (inhibit-read-only t))
4150     (when buff (with-current-buffer buff (erase-buffer))))))
4151    (t ;; disable selection mode
4152     (setq cursor-type nil)
4153     (setq undo-tree-visualizer-selected-node nil)
4154     (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
4155     (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))
4156    ))
4157
4158
4159 (defun undo-tree-visualizer-select-previous (&optional arg)
4160   "Move to previous node."
4161   (interactive "p")
4162   (let ((node undo-tree-visualizer-selected-node))
4163     (catch 'top
4164       (dotimes (i (or arg 1))
4165     (unless (undo-tree-node-previous node) (throw 'top t))
4166     (setq node (undo-tree-node-previous node))))
4167     ;; when using lazy drawing, extend tree upwards as required
4168     (when undo-tree-visualizer-lazy-drawing
4169       (undo-tree-expand-up undo-tree-visualizer-selected-node node))
4170     ;; update diff display, if any
4171     (when (and undo-tree-visualizer-diff
4172            (not (eq node undo-tree-visualizer-selected-node)))
4173       (undo-tree-visualizer-update-diff node))
4174     ;; move to selected node
4175     (goto-char (undo-tree-node-marker node))
4176     (setq undo-tree-visualizer-selected-node node)))
4177
4178
4179 (defun undo-tree-visualizer-select-next (&optional arg)
4180   "Move to next node."
4181   (interactive "p")
4182   (let ((node undo-tree-visualizer-selected-node))
4183     (catch 'bottom
4184       (dotimes (i (or arg 1))
4185     (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node))
4186       (throw 'bottom t))
4187     (setq node
4188           (nth (undo-tree-node-branch node) (undo-tree-node-next node)))))
4189     ;; when using lazy drawing, extend tree downwards as required
4190     (when undo-tree-visualizer-lazy-drawing
4191       (undo-tree-expand-down undo-tree-visualizer-selected-node node))
4192     ;; update diff display, if any
4193     (when (and undo-tree-visualizer-diff
4194            (not (eq node undo-tree-visualizer-selected-node)))
4195       (undo-tree-visualizer-update-diff node))
4196     ;; move to selected node
4197     (goto-char (undo-tree-node-marker node))
4198     (setq undo-tree-visualizer-selected-node node)))
4199
4200
4201 (defun undo-tree-visualizer-select-right (&optional arg)
4202   "Move right to a sibling node."
4203   (interactive "p")
4204   (let ((node undo-tree-visualizer-selected-node)
4205     end)
4206     (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node))
4207     (setq end (line-end-position))
4208     (catch 'end
4209       (dotimes (i arg)
4210     (while (or (null node) (eq node undo-tree-visualizer-selected-node))
4211       (forward-char)
4212       (setq node (get-text-property (point) 'undo-tree-node))
4213       (when (= (point) end) (throw 'end t)))))
4214     (goto-char (undo-tree-node-marker
4215         (or node undo-tree-visualizer-selected-node)))
4216     (when (and undo-tree-visualizer-diff node
4217            (not (eq node undo-tree-visualizer-selected-node)))
4218       (undo-tree-visualizer-update-diff node))
4219     (when node (setq undo-tree-visualizer-selected-node node))))
4220
4221
4222 (defun undo-tree-visualizer-select-left (&optional arg)
4223   "Move left to a sibling node."
4224   (interactive "p")
4225   (let ((node (get-text-property (point) 'undo-tree-node))
4226     beg)
4227     (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node))
4228     (setq beg (line-beginning-position))
4229     (catch 'beg
4230       (dotimes (i arg)
4231     (while (or (null node) (eq node undo-tree-visualizer-selected-node))
4232       (backward-char)
4233       (setq node (get-text-property (point) 'undo-tree-node))
4234       (when (= (point) beg) (throw 'beg t)))))
4235     (goto-char (undo-tree-node-marker
4236         (or node undo-tree-visualizer-selected-node)))
4237     (when (and undo-tree-visualizer-diff node
4238            (not (eq node undo-tree-visualizer-selected-node)))
4239       (undo-tree-visualizer-update-diff node))
4240     (when node (setq undo-tree-visualizer-selected-node node))))
4241
4242
4243 (defun undo-tree-visualizer-select (pos)
4244   (let ((node (get-text-property pos 'undo-tree-node)))
4245     (when node
4246       ;; select node at POS
4247       (goto-char (undo-tree-node-marker node))
4248       ;; when using lazy drawing, extend tree up and down as required
4249       (when undo-tree-visualizer-lazy-drawing
4250     (undo-tree-expand-up undo-tree-visualizer-selected-node node)
4251     (undo-tree-expand-down undo-tree-visualizer-selected-node node))
4252       ;; update diff display, if any
4253       (when (and undo-tree-visualizer-diff
4254          (not (eq node undo-tree-visualizer-selected-node)))
4255     (undo-tree-visualizer-update-diff node))
4256       ;; update selected node
4257       (setq undo-tree-visualizer-selected-node node)
4258       )))
4259
4260
4261 (defun undo-tree-visualizer-mouse-select (pos)
4262   "Select undo tree node at mouse event POS."
4263   (interactive "@e")
4264   (undo-tree-visualizer-select (event-start (nth 1 pos))))
4265
4266
4267
4268
4269 ;;; =====================================================================
4270 ;;;                      Visualizer diff display
4271
4272 (defun undo-tree-visualizer-toggle-diff ()
4273   "Toggle diff display in undo-tree visualizer."
4274   (interactive)
4275   (if undo-tree-visualizer-diff
4276       (undo-tree-visualizer-hide-diff)
4277     (undo-tree-visualizer-show-diff)))
4278
4279
4280 (defun undo-tree-visualizer-selection-toggle-diff ()
4281   "Toggle diff display in undo-tree visualizer selection mode."
4282   (interactive)
4283   (if undo-tree-visualizer-diff
4284       (undo-tree-visualizer-hide-diff)
4285     (let ((node (get-text-property (point) 'undo-tree-node)))
4286       (when node (undo-tree-visualizer-show-diff node)))))
4287
4288
4289 (defun undo-tree-visualizer-show-diff (&optional node)
4290   ;; show visualizer diff display
4291   (setq undo-tree-visualizer-diff t)
4292   (let ((buff (with-current-buffer undo-tree-visualizer-parent-buffer
4293         (undo-tree-diff node)))
4294     (display-buffer-mark-dedicated 'soft)
4295     win)
4296     (setq win (split-window))
4297     (set-window-buffer win buff)
4298     (shrink-window-if-larger-than-buffer win)))
4299
4300
4301 (defun undo-tree-visualizer-hide-diff ()
4302   ;; hide visualizer diff display
4303   (setq undo-tree-visualizer-diff nil)
4304   (let ((win (get-buffer-window undo-tree-diff-buffer-name)))
4305     (when win (with-selected-window win (kill-buffer-and-window)))))
4306
4307
4308 (defun undo-tree-diff (&optional node)
4309   ;; Create diff between NODE and current state (or previous state and current
4310   ;; state, if NODE is null). Returns buffer containing diff.
4311   (let (tmpfile buff)
4312     ;; generate diff
4313     (let ((undo-tree-inhibit-kill-visualizer t)
4314       (current (undo-tree-current buffer-undo-tree)))
4315       (undo-tree-set (or node (undo-tree-node-previous current) current)
4316              'preserve-timestamps)
4317       (setq tmpfile (diff-file-local-copy (current-buffer)))
4318       (undo-tree-set current 'preserve-timestamps))
4319     (setq buff (diff-no-select
4320         tmpfile (current-buffer) nil 'noasync
4321         (get-buffer-create undo-tree-diff-buffer-name)))
4322     ;; delete process messages and useless headers from diff buffer
4323     (let ((inhibit-read-only t))
4324       (with-current-buffer buff
4325     (goto-char (point-min))
4326     (delete-region (point) (1+ (line-end-position 3)))
4327     (goto-char (point-max))
4328     (forward-line -2)
4329     (delete-region (point) (point-max))
4330     (setq cursor-type nil)
4331     (setq buffer-read-only t)))
4332     buff))
4333
4334
4335 (defun undo-tree-visualizer-update-diff (&optional node)
4336   ;; update visualizer diff display to show diff between current state and
4337   ;; NODE (or previous state, if NODE is null)
4338   (with-current-buffer undo-tree-visualizer-parent-buffer
4339     (undo-tree-diff node))
4340   (let ((win (get-buffer-window undo-tree-diff-buffer-name)))
4341     (when win
4342       (balance-windows)
4343       (shrink-window-if-larger-than-buffer win))))
4344
4345 ;;;; ChangeLog:
4346
4347 ;; 2013-12-28  Toby S. Cubitt  <tsc25@cantab.net>
4348 ;; 
4349 ;;     * undo-tree: Update to version 0.6.5.
4350 ;; 
4351 ;; 2012-12-05  Toby S. Cubitt  <tsc25@cantab.net>
4352 ;; 
4353 ;;     Update undo-tree to version 0.6.3
4354 ;; 
4355 ;;     * undo-tree.el: Implement lazy tree drawing to significantly speed up 
4356 ;;     visualization of large trees + various more minor improvements.
4357 ;; 
4358 ;; 2012-09-25  Toby S. Cubitt  <tsc25@cantab.net>
4359 ;; 
4360 ;;     Updated undo-tree package to version 0.5.5.
4361 ;; 
4362 ;;     Small bug-fix to avoid hooks triggering an error when trying to save
4363 ;;     undo history in a buffer where undo is disabled.
4364 ;; 
4365 ;; 2012-09-11  Toby S. Cubitt  <tsc25@cantab.net>
4366 ;; 
4367 ;;     Updated undo-tree package to version 0.5.4
4368 ;; 
4369 ;;     Bug-fixes and improvements to persistent history storage.
4370 ;; 
4371 ;; 2012-07-18  Toby S. Cubitt  <tsc25@cantab.net>
4372 ;; 
4373 ;;     Update undo-tree to version 0.5.3
4374 ;; 
4375 ;;     * undo-tree.el: Cope gracefully with undo boundaries being deleted
4376 ;;      (cf. bug#11774). Allow customization of directory to which undo
4377 ;;     history is
4378 ;;      saved.
4379 ;; 
4380 ;; 2012-05-24  Toby S. Cubitt  <tsc25@cantab.net>
4381 ;; 
4382 ;;     updated undo-tree package to version 0.5.2
4383 ;; 
4384 ;;     * undo-tree.el: add diff view feature in undo-tree visualizer.
4385 ;; 
4386 ;; 2012-05-02  Toby S. Cubitt  <tsc25@cantab.net>
4387 ;; 
4388 ;;     undo-tree.el: Update package to version 0.4
4389 ;; 
4390 ;; 2012-04-20  Toby S. Cubitt  <tsc25@cantab.net>
4391 ;; 
4392 ;;     undo-tree.el: Update package to version 0.3.4
4393 ;; 
4394 ;;     * undo-tree.el (undo-list-pop-changeset): fix pernicious bug causing
4395 ;;     undo history to be lost.
4396 ;;     (buffer-undo-tree): set permanent-local property.
4397 ;;     (undo-tree-enable-undo-in-region): add new customization option
4398 ;;     allowing undo-in-region to be disabled.
4399 ;; 
4400 ;; 2012-01-26  Toby S. Cubitt  <tsc25@cantab.net>
4401 ;; 
4402 ;;     undo-tree.el: Fixed copyright attribution and Emacs status.
4403 ;; 
4404 ;; 2012-01-26  Toby S. Cubitt  <tsc25@cantab.net>
4405 ;; 
4406 ;;     undo-tree.el: Update package to version 0.3.3
4407 ;; 
4408 ;; 2011-09-17  Stefan Monnier  <monnier@iro.umontreal.ca>
4409 ;; 
4410 ;;     Add undo-tree.el
4411 ;; 
4412
4413
4414
4415
4416 (provide 'undo-tree)
4417
4418 ;;; undo-tree.el ends here