Generate curved quotes in pseudo-info nodes
[emacs.git] / lisp / hilit-chg.el
blob8d012947128dcf4a9eb82525f39e05199986a4a7
1 ;;; hilit-chg.el --- minor mode displaying buffer changes with special face
3 ;; Copyright (C) 1998, 2000-2015 Free Software Foundation, Inc.
5 ;; Author: Richard Sharman <rsharman@pobox.com>
6 ;; Keywords: faces
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;; A minor mode: "Highlight Changes mode".
27 ;; When Highlight Changes mode is enabled changes to the buffer are
28 ;; recorded with a text property. Normally these ranges of text are
29 ;; displayed in a distinctive face. However, sometimes it is
30 ;; desirable to temporarily not see these changes. Instead of
31 ;; disabling Highlight Changes mode (which would remove the text property)
32 ;; use the command highlight-changes-visible-mode.
34 ;; Two faces are supported: one for changed or inserted text and
35 ;; another for the first character after text has been deleted.
37 ;; When Highlight Changes mode is on (even if changes are not visible)
38 ;; you can go to the next or previous change with
39 ;; `highlight-changes-next-change' or `highlight-changes-previous-change'.
41 ;; Command highlight-compare-with-file shows changes in this file
42 ;; compared with another file (by default the previous version of the
43 ;; file).
45 ;; The command highlight-compare-buffers compares two buffers by
46 ;; highlighting their differences.
48 ;; You can "age" different sets of changes by using
49 ;; `highlight-changes-rotate-faces'. This rotates through a series
50 ;; of different faces, so you can distinguish "new" changes from "older"
51 ;; changes. You can customize these "rotated" faces in two ways. You can
52 ;; either explicitly define each face by customizing
53 ;; `highlight-changes-face-list'. If, however, the faces differ from
54 ;; `highlight-changes-face' only in the foreground color, you can simply set
55 ;; `highlight-changes-colors'. If `highlight-changes-face-list' is nil when
56 ;; the faces are required they will be constructed from
57 ;; `highlight-changes-colors'.
59 ;; You can automatically rotate faces when the buffer is saved;
60 ;; see function `highlight-changes-rotate-faces' for how to do this.
62 ;; The hook `highlight-changes-mode-hook' is called when
63 ;; Highlight Changes mode is turned on or off.
64 ;; When it called, variable `highlight-changes-mode' has been updated
65 ;; to the new value.
67 ;; Example usage:
68 ;; (defun my-highlight-changes-mode-hook ()
69 ;; (if highlight-changes-mode
70 ;; (add-hook 'write-file-functions 'highlight-changes-rotate-faces nil t)
71 ;; (remove-hook 'write-file-functions 'highlight-changes-rotate-faces t)
72 ;; ))
75 ;; Automatically enabling Highlight Changes mode
78 ;; Normally, Highlight Changes mode is turned on explicitly in a buffer.
80 ;; If you prefer to have it automatically invoked you can do it as
81 ;; follows.
83 ;; 1. Most modes have a major-hook, typically called MODE-hook. You
84 ;; can use `add-hook' to call `highlight-changes-mode'.
86 ;; Example:
87 ;; (add-hook 'c-mode-hook 'highlight-changes-mode)
89 ;; However, this cannot be done for Fundamental mode for there is no
90 ;; such hook.
92 ;; 2. You can use the function `global-highlight-changes-mode'
94 ;; This function, which is fashioned after the way `global-font-lock' works,
95 ;; toggles on or off global Highlight Changes mode. When activated, it turns
96 ;; on Highlight Changes mode in all "suitable" existing buffers and will turn
97 ;; it on in new "suitable" buffers to be created.
99 ;; A buffer's "suitability" is determined by variable
100 ;; `highlight-changes-global-modes', as follows. If it is
101 ;; * nil -- then no buffers are suitable;
102 ;; * a function -- this function is called and the result is used. As
103 ;; an example, if the value is `buffer-file-name' then all buffers
104 ;; who are visiting files are suitable, but others (like dired
105 ;; buffers) are not;
106 ;; * a list -- then the buffer is suitable if and only if its mode is in the
107 ;; list, except if the first element is `not', in which case the test
108 ;; is reversed (i.e. it is a list of unsuitable modes).
109 ;; * Otherwise, the buffer is suitable if its name does not begin with
110 ;; ` ' or `*' and if `buffer-file-name' returns true.
112 ;; To enable it for future sessions put this in your ~/.emacs file:
113 ;; (global-highlight-changes-mode t)
116 ;; Possible bindings:
117 ;; (global-set-key '[C-right] 'highlight-changes-next-change)
118 ;; (global-set-key '[C-left] 'highlight-changes-previous-change)
120 ;; Other interactive functions (that could be bound if desired):
121 ;; highlight-changes-mode
122 ;; highlight-changes-toggle-visibility
123 ;; highlight-changes-remove-highlight
124 ;; highlight-compare-with-file
125 ;; highlight-compare-buffers
126 ;; highlight-changes-rotate-faces
129 ;;; Bugs:
131 ;; - the next-change and previous-change functions are too literal;
132 ;; they should find the next "real" change, in other words treat
133 ;; consecutive changes as one.
136 ;;; To do (maybe), notes, ...
138 ;; - having different faces for deletion and non-deletion: is it
139 ;; really worth the hassle?
140 ;; - highlight-compare-with-file should allow RCS files - e.g. nice to be
141 ;; able to say show changes compared with version 2.1.
144 ;;; History:
146 ;; R Sharman (rsharman@pobox.com) Feb 1998:
147 ;; - initial release as change-mode.
148 ;; Jari Aalto <jari.aalto@ntc.nokia.com> Mar 1998
149 ;; - fixes for byte compile errors
150 ;; - use eval-and-compile for autoload
151 ;; Marijn Ros <J.M.Ros@fys.ruu.nl> Mar 98
152 ;; - suggested turning it on by default
153 ;; Eric Ludlam <zappo@gnu.org> Suggested using overlays.
154 ;; July 98
155 ;; - global mode and various stuff added
156 ;; - Changed to use overlays
157 ;; August 98
158 ;; - renamed to Highlight Changes mode.
159 ;; Dec 2003
160 ;; - Use require for ediff stuff
161 ;; - Added highlight-compare-buffers
162 ;; Mar 2008
163 ;; - Made highlight-changes-mode like other modes (toggle on/off)
164 ;; - Added new command highlight-changes-visible-mode to replace the
165 ;; previous active/passive aspect of highlight-changes-mode.
166 ;; - Removed highlight-changes-toggle-hook
167 ;; - Put back eval-and-compile inadvertently dropped
168 ;; May 2008
169 ;; - Removed highlight-changes-disable-hook and highlight-changes-enable-hook
170 ;; because highlight-changes-mode-hook can do both.
172 ;;; Code:
174 (require 'wid-edit)
176 ;; ====================== Customization =======================
177 (defgroup highlight-changes nil
178 "Highlight Changes mode."
179 :version "20.4"
180 :group 'faces)
183 ;; Face information: How the changes appear.
185 ;; Defaults for face: red foreground, no change to background,
186 ;; and underlined if a change is because of a deletion.
187 ;; Note: underlining is helpful in that it shows up changes in white space.
188 ;; However, having it set for non-delete changes can be annoying because all
189 ;; indentation on inserts gets underlined (which can look pretty ugly!).
191 (defface highlight-changes
192 '((((min-colors 88) (class color)) (:foreground "red1"))
193 (((class color)) (:foreground "red" ))
194 (t (:inverse-video t)))
195 "Face used for highlighting changes."
196 :group 'highlight-changes)
197 (define-obsolete-face-alias 'highlight-changes-face
198 'highlight-changes "22.1")
200 ;; This looks pretty ugly, actually. Maybe the underline should be removed.
201 (defface highlight-changes-delete
202 '((((min-colors 88) (class color)) (:foreground "red1" :underline t))
203 (((class color)) (:foreground "red" :underline t))
204 (t (:inverse-video t)))
205 "Face used for highlighting deletions."
206 :group 'highlight-changes)
207 (define-obsolete-face-alias 'highlight-changes-delete-face
208 'highlight-changes-delete "22.1")
211 ;; A (not very good) default list of colors to rotate through.
212 (define-obsolete-variable-alias 'highlight-changes-colours
213 'highlight-changes-colors "22.1")
215 (defcustom highlight-changes-colors
216 (if (eq (frame-parameter nil 'background-mode) 'light)
217 ;; defaults for light background:
218 '( "magenta" "blue" "darkgreen" "chocolate" "sienna4" "NavyBlue")
219 ;; defaults for dark background:
220 '("yellow" "magenta" "blue" "maroon" "firebrick" "green4" "DarkOrchid"))
221 "Colors used by `highlight-changes-rotate-faces'.
222 The newest rotated change will be displayed in the first element of this list,
223 the next older will be in the second element etc.
225 This list is used if `highlight-changes-face-list' is nil, otherwise that
226 variable overrides this list. If you only care about foreground
227 colors then use this, if you want fancier faces then set
228 `highlight-changes-face-list'."
229 :type '(repeat color)
230 :group 'highlight-changes)
232 ;; When you invoke highlight-changes-mode, should highlight-changes-visible-mode
233 ;; be on or off?
235 (define-obsolete-variable-alias 'highlight-changes-initial-state
236 'highlight-changes-visibility-initial-state "23.1")
238 (defcustom highlight-changes-visibility-initial-state t
239 "Controls whether changes are initially visible in Highlight Changes mode.
241 This controls the initial value of `highlight-changes-visible-mode'.
242 When a buffer is in Highlight Changes mode the function
243 `highlight-changes-visible-mode' is used to toggle the mode on or off."
244 :type 'boolean
245 :group 'highlight-changes)
247 ;; highlight-changes-global-initial-state has been removed
251 ;; These are the strings displayed in the mode-line for the minor mode:
252 (define-obsolete-variable-alias 'highlight-changes-active-string
253 'highlight-changes-visible-string "23.1")
255 (defcustom highlight-changes-visible-string " +Chg"
256 "The string used when in Highlight Changes mode and changes are visible.
257 This should be set to nil if no indication is desired, or to
258 a string with a leading space."
259 :type '(choice string
260 (const :tag "None" nil))
261 :group 'highlight-changes)
263 (define-obsolete-variable-alias 'highlight-changes-passive-string
264 'highlight-changes-invisible-string "23.1")
266 (defcustom highlight-changes-invisible-string " -Chg"
267 "The string used when in Highlight Changes mode and changes are hidden.
268 This should be set to nil if no indication is desired, or to
269 a string with a leading space."
270 :type '(choice string
271 (const :tag "None" nil))
272 :group 'highlight-changes)
274 (defcustom highlight-changes-global-modes t
275 "Determine whether a buffer is suitable for global Highlight Changes mode.
277 A function means call that function to decide: if it returns non-nil,
278 the buffer is suitable.
280 A list means the elements are major modes suitable for Highlight
281 Changes mode, or a list whose first element is `not' followed by major
282 modes which are not suitable.
284 A value of t means the buffer is suitable if it is visiting a file and
285 its name does not begin with ` ' or `*'.
287 A value of nil means no buffers are suitable for `global-highlight-changes-mode'
288 \(effectively disabling the mode).
290 Example:
291 (c-mode c++-mode)
292 means that Highlight Changes mode is turned on for buffers in C and C++
293 modes only."
294 :type '(choice
295 (const :tag "all non-special buffers visiting files" t)
296 (set :menu-tag "specific modes" :tag "modes"
297 :value (not)
298 (const :tag "All except these" not)
299 (repeat :tag "Modes" :inline t (symbol :tag "mode")))
300 (function :menu-tag "determined by function"
301 :value buffer-file-name)
302 (const :tag "none" nil)
304 :group 'highlight-changes)
306 (defcustom highlight-changes-global-changes-existing-buffers nil
307 "If non-nil, toggling global Highlight Changes mode affects existing buffers.
308 Normally, `global-highlight-changes' affects only new buffers (to be
309 created). However, if `highlight-changes-global-changes-existing-buffers'
310 is non-nil, then turning on `global-highlight-changes' will turn on
311 Highlight Changes mode in suitable buffers, and turning the mode off will
312 remove it from existing buffers."
313 :type 'boolean
314 :group 'highlight-changes)
316 ;; These are for internal use.
318 (defvar hilit-chg-list nil)
319 (defvar hilit-chg-string " ??")
321 (make-variable-buffer-local 'hilit-chg-string)
325 ;;; Functions...
327 ;;;###autoload
328 (define-minor-mode highlight-changes-mode
329 "Toggle highlighting changes in this buffer (Highlight Changes mode).
330 With a prefix argument ARG, enable Highlight Changes mode if ARG
331 is positive, and disable it otherwise. If called from Lisp,
332 enable the mode if ARG is omitted or nil.
334 When Highlight Changes is enabled, changes are marked with a text
335 property. Normally they are displayed in a distinctive face, but
336 command \\[highlight-changes-visible-mode] can be used to toggle
337 this on and off.
339 Other functions for buffers in this mode include:
340 \\[highlight-changes-next-change] - move point to beginning of next change
341 \\[highlight-changes-previous-change] - move to beginning of previous change
342 \\[highlight-changes-remove-highlight] - remove the change face from the region
343 \\[highlight-changes-rotate-faces] - rotate different \"ages\" of changes
344 through various faces.
345 \\[highlight-compare-with-file] - mark text as changed by comparing this
346 buffer with the contents of a file
347 \\[highlight-compare-buffers] highlights differences between two buffers."
348 nil ;; init-value
349 hilit-chg-string ;; lighter
350 nil ;; keymap
351 (if (or (display-color-p)
352 (and (fboundp 'x-display-grayscale-p) (x-display-grayscale-p)))
353 (progn
354 (if (and (eq this-command 'global-highlight-changes-mode)
355 (not highlight-changes-global-changes-existing-buffers))
356 ;; The global mode has toggled the value of the mode variable,
357 ;; but not other changes have been mode, so we are safe
358 ;; to retoggle it.
359 (setq highlight-changes-mode (not highlight-changes-mode)))
360 (if highlight-changes-mode
361 ;; it is being turned on
362 (hilit-chg-set)
363 ;; mode is turned off
364 (hilit-chg-clear)))
365 (message "Highlight Changes mode requires color or grayscale display")))
368 ;;;###autoload
369 (define-minor-mode highlight-changes-visible-mode
370 "Toggle visibility of highlighting due to Highlight Changes mode.
371 With a prefix argument ARG, enable Highlight Changes Visible mode
372 if ARG is positive, and disable it otherwise. If called from
373 Lisp, enable the mode if ARG is omitted or nil.
375 Highlight Changes Visible mode only has an effect when Highlight
376 Changes mode is on. When enabled, the changed text is displayed
377 in a distinctive face.
379 The default value can be customized with variable
380 `highlight-changes-visibility-initial-state'.
382 This command does not itself set Highlight Changes mode."
384 t ;; init-value
385 nil ;; lighter
386 nil ;; keymap
388 (hilit-chg-update)
392 (defun hilit-chg-cust-fix-changes-face-list (w _wc &optional event)
393 ;; When customization function `highlight-changes-face-list' inserts a new
394 ;; face it uses the default face. We don't want the user to modify this
395 ;; face, so we rename the faces in the list on an insert. The rename is
396 ;; actually done by copying the faces so user-defined faces still remain
397 ;; in the same order.
398 ;; The notifying the parent is needed because without it changes to the
399 ;; faces are saved but not to the actual list itself.
400 (let ((old-list (widget-value w)))
401 (if (member 'default old-list)
402 (let
403 ((p (reverse old-list))
404 (n (length old-list))
405 new-name old-name
406 (new-list nil)
408 (while p
409 (setq old-name (car p))
410 (setq new-name (intern (format "highlight-changes-%d" n)))
411 (if (eq old-name new-name)
413 ;; A new face has been inserted: we don't want to modify the
414 ;; default face so copy it. Better, though, (I think) is to
415 ;; make a new face have the same attributes as
416 ;; the `highlight-changes' face.
417 (if (eq old-name 'default)
418 (copy-face 'highlight-changes new-name)
419 (copy-face old-name new-name)
421 (setq new-list (append (list new-name) new-list))
422 (setq n (1- n))
423 (setq p (cdr p)))
424 (if (equal new-list (widget-value w))
425 nil ;; (message "notify: no change!")
426 (widget-value-set w new-list)
427 (widget-setup)
430 ;; (message "notify: no default here!")
432 (let ((parent (widget-get w :parent)))
433 (when parent
434 (widget-apply parent :notify w event))))
437 (defcustom highlight-changes-face-list nil
438 "A list of faces used when rotating changes.
439 Normally the variable is initialized to nil and the list is created from
440 `highlight-changes-colors' when needed. However, you can set this variable
441 to any list of faces. You will have to do this if you want faces which
442 don't just differ from the `highlight-changes' face by the foreground color.
443 Otherwise, this list will be constructed when needed from
444 `highlight-changes-colors'."
445 :type '(choice
446 (repeat
447 :notify hilit-chg-cust-fix-changes-face-list
448 face )
449 (const :tag "Derive from highlight-changes-colors" nil)
451 :group 'highlight-changes)
454 (defun hilit-chg-map-changes (func &optional start-position end-position)
455 "Call function FUNC for each region used by Highlight Changes mode.
456 If START-POSITION is nil, (point-min) is used.
457 If END-POSITION is nil, (point-max) is used.
458 FUNC is called with three params: PROPERTY START STOP."
459 (let ((start (or start-position (point-min)))
460 (limit (or end-position (point-max)))
461 prop end)
462 (while (and start (< start limit))
463 (setq prop (get-text-property start 'hilit-chg))
464 (setq end (text-property-not-all start limit 'hilit-chg prop))
465 (if prop
466 (funcall func prop start (or end limit)))
467 (setq start end))))
470 (defun hilit-chg-display-changes (&optional beg end)
471 "Display face information for Highlight Changes mode.
473 An overlay from BEG to END containing a change face is added
474 from the information in the text property of type `hilit-chg'.
476 This is the opposite of `hilit-chg-hide-changes'."
477 (hilit-chg-map-changes 'hilit-chg-make-ov beg end))
480 (defun hilit-chg-make-ov (prop start end)
481 (or prop
482 (error "hilit-chg-make-ov: prop is nil"))
483 ;; For the region create overlays with a distinctive face
484 ;; and the text property 'hilit-chg.
485 (let ((ov (make-overlay start end))
486 (face (if (eq prop 'hilit-chg-delete)
487 'highlight-changes-delete
488 (nth 1 (member prop hilit-chg-list)))))
489 (if face
490 (progn
491 ;; We must mark the face, that is the purpose of the overlay.
492 (overlay-put ov 'face face)
493 ;; I don't think we need to set evaporate since we should
494 ;; be controlling them!
495 (overlay-put ov 'evaporate t)
496 ;; We set the change property so we can tell this is one
497 ;; of our overlays (so we don't delete someone else's).
498 (overlay-put ov 'hilit-chg t)
500 (error "hilit-chg-make-ov: no face for prop: %s" prop))))
502 (defun hilit-chg-hide-changes (&optional beg end)
503 "Remove face information for Highlight Changes mode.
505 The overlay containing the face is removed, but the text property
506 containing the change information is retained.
508 This is the opposite of `hilit-chg-display-changes'."
509 (let ((start (or beg (point-min)))
510 (limit (or end (point-max))))
511 (dolist (p (overlays-in start limit))
512 ;; don't delete the overlay if it isn't ours!
513 (if (overlay-get p 'hilit-chg)
514 (delete-overlay p)))))
517 (defun hilit-chg-fixup (beg end)
518 "Fix change overlays in region between BEG and END.
520 Ensure the overlays agree with the changes as determined from
521 the text properties of type `hilit-chg'."
522 ;; Remove or alter overlays in region beg..end
523 (remove-overlays beg end 'hilit-chg t)
524 (hilit-chg-display-changes beg end))
526 ;;;###autoload
527 (defun highlight-changes-remove-highlight (beg end)
528 "Remove the change face from the region between BEG and END.
529 This allows you to manually remove highlighting from uninteresting changes."
530 (interactive "r")
531 (with-silent-modifications
532 (remove-text-properties beg end '(hilit-chg nil))
533 (hilit-chg-fixup beg end)))
535 (defun hilit-chg-set-face-on-change (beg end leng-before
536 &optional no-property-change)
537 "Record changes and optionally display them in a distinctive face.
538 `hilit-chg-set' adds this function to the `after-change-functions' hook."
540 ;; This function is called by the `after-change-functions' hook, which
541 ;; is how we are notified when text is changed.
542 ;; It is also called from `highlight-compare-with-file'.
544 ;; We do NOT want to simply do this if this is an undo command, because
545 ;; otherwise an undone change shows up as changed. While the properties
546 ;; are automatically restored by undo, we must fix up the overlay.
547 (save-match-data
548 (let (;;(beg-decr 1)
549 (end-incr 1)
550 (type 'hilit-chg))
551 (if undo-in-progress
552 (if (and highlight-changes-mode
553 highlight-changes-visible-mode)
554 (hilit-chg-fixup beg end))
555 (with-silent-modifications
556 (if (and (= beg end) (> leng-before 0))
557 ;; deletion
558 (progn
559 ;; The eolp and bolp tests are a kludge! But they prevent
560 ;; rather nasty looking displays when deleting text at the end
561 ;; of line, such as normal corrections as one is typing and
562 ;; immediately makes a correction, and when deleting first
563 ;; character of a line.
564 ;; (if (= leng-before 1)
565 ;; (if (eolp)
566 ;; (setq beg-decr 0 end-incr 0)
567 ;; (if (bolp)
568 ;; (setq beg-decr 0))))
569 ;; (setq beg (max (- beg beg-decr) (point-min)))
570 (setq end (min (+ end end-incr) (point-max)))
571 (setq type 'hilit-chg-delete))
572 ;; Not a deletion.
573 ;; Most of the time the following is not necessary, but
574 ;; if the current text was marked as a deletion then
575 ;; the old overlay is still in effect. So if the user adds some
576 ;; text where she earlier deleted text, we have to remove the
577 ;; deletion marking, and replace it explicitly with a `changed'
578 ;; marking, otherwise its highlighting would disappear.
579 (if (eq (get-text-property end 'hilit-chg) 'hilit-chg-delete)
580 (save-restriction
581 (widen)
582 (put-text-property end (+ end 1) 'hilit-chg 'hilit-chg)
583 (if highlight-changes-visible-mode
584 (hilit-chg-fixup end (+ end 1))))))
585 (unless no-property-change
586 (put-text-property beg end 'hilit-chg type))
587 (if (or highlight-changes-visible-mode no-property-change)
588 (hilit-chg-make-ov type beg end)))))))
590 (defun hilit-chg-update ()
591 "Update a buffer's highlight changes when visibility changed."
592 (if highlight-changes-visible-mode
593 ;; changes are visible
594 (progn
595 (setq hilit-chg-string highlight-changes-visible-string)
596 (or buffer-read-only
597 (hilit-chg-display-changes)))
598 ;; changes are invisible
599 (setq hilit-chg-string highlight-changes-invisible-string)
600 (or buffer-read-only
601 (hilit-chg-hide-changes))))
603 (defun hilit-chg-set ()
604 "Turn on Highlight Changes mode for this buffer."
605 (remove-hook 'after-change-functions 'hilit-chg-set-face-on-change t)
606 (hilit-chg-make-list)
607 (setq highlight-changes-mode t)
608 (setq highlight-changes-visible-mode highlight-changes-visibility-initial-state)
609 (hilit-chg-update)
610 (force-mode-line-update)
611 (add-hook 'after-change-functions 'hilit-chg-set-face-on-change nil t))
613 (defun hilit-chg-clear ()
614 "Remove Highlight Changes mode for this buffer.
615 This removes all saved change information."
616 (if buffer-read-only
617 ;; We print the buffer name because this function could be called
618 ;; on many buffers from `global-highlight-changes-mode'.
619 (message "Cannot remove highlighting from read-only mode buffer %s"
620 (buffer-name))
621 (remove-hook 'after-change-functions 'hilit-chg-set-face-on-change t)
622 (with-silent-modifications
623 (hilit-chg-hide-changes)
624 (hilit-chg-map-changes
625 (lambda (_prop start stop)
626 (remove-text-properties start stop '(hilit-chg nil)))))
627 (setq highlight-changes-mode nil)
628 (force-mode-line-update)))
631 ;;;###autoload
632 (defun highlight-changes-next-change ()
633 "Move to the beginning of the next change, if in Highlight Changes mode."
634 (interactive)
635 (if highlight-changes-mode
636 (let ((start (point))
637 prop)
638 (setq prop (get-text-property (point) 'hilit-chg))
639 (if prop
640 ;; we are in a change
641 (setq start (next-single-property-change (point) 'hilit-chg)))
642 (if start
643 (setq start (next-single-property-change start 'hilit-chg)))
644 (if start
645 (goto-char start)
646 (message "no next change")))
647 (message "This buffer is not in Highlight Changes mode.")))
650 ;;;###autoload
651 (defun highlight-changes-previous-change ()
652 "Move to the beginning of the previous change, if in Highlight Changes mode."
653 (interactive)
654 (if highlight-changes-mode
655 (let ( (start (point)) (prop nil) )
656 (or (bobp)
657 (setq prop (get-text-property (1- (point)) 'hilit-chg)))
658 (if prop
659 ;; we are in a change
660 (setq start (previous-single-property-change (point) 'hilit-chg)))
661 (if start
662 (setq start (previous-single-property-change start 'hilit-chg)))
663 ;; special handling for the case where (point-min) is a change
664 (if start
665 (setq start (or (previous-single-property-change start 'hilit-chg)
666 (if (get-text-property (point-min) 'hilit-chg)
667 (point-min)))))
668 (if start
669 (goto-char start)
670 (message "no previous change")))
671 (message "This buffer is not in Highlight Changes mode.")))
673 ;; ========================================================================
675 (defun hilit-chg-make-list (&optional force)
676 "Construct `hilit-chg-list' and `highlight-changes-face-list'."
677 ;; Constructs highlight-changes-face-list if necessary,
678 ;; and hilit-chg-list always:
679 ;; Maybe this should always be called when rotating a face
680 ;; so we pick up any changes?
681 (if (or (null highlight-changes-face-list) ; Don't do it if it
682 force) ; already exists unless FORCE non-nil.
683 (let ((p highlight-changes-colors)
684 (n 1) name)
685 (setq highlight-changes-face-list nil)
686 (while p
687 (setq name (intern (format "highlight-changes-%d" n)))
688 (copy-face 'highlight-changes name)
689 (set-face-foreground name (car p))
690 (setq highlight-changes-face-list
691 (append highlight-changes-face-list (list name)))
692 (setq p (cdr p))
693 (setq n (1+ n)))))
694 (setq hilit-chg-list (list 'hilit-chg 'highlight-changes))
695 (let ((p highlight-changes-face-list)
696 (n 1)
697 last-category last-face)
698 (while p
699 (setq last-category (intern (format "change-%d" n)))
700 ;; (setq last-face (intern (format "highlight-changes-%d" n)))
701 (setq last-face (car p))
702 (setq hilit-chg-list
703 (append hilit-chg-list
704 (list last-category last-face)))
705 (setq p (cdr p))
706 (setq n (1+ n)))
707 (setq hilit-chg-list
708 (append hilit-chg-list
709 (list last-category last-face)))))
711 (defun hilit-chg-bump-change (prop start end)
712 "Increment (age) the Highlight Changes mode text property."
713 (let ( new-prop )
714 (if (eq prop 'hilit-chg-delete)
715 (setq new-prop (nth 2 hilit-chg-list))
716 (setq new-prop (nth 2 (member prop hilit-chg-list))))
717 (if prop
718 (put-text-property start end 'hilit-chg new-prop)
719 (message "%d-%d unknown property %s not changed" start end prop))))
721 ;;;###autoload
722 (defun highlight-changes-rotate-faces ()
723 "Rotate the faces if in Highlight Changes mode and the changes are visible.
725 Current changes are displayed in the face described by the first element
726 of `highlight-changes-face-list', one level older changes are shown in
727 face described by the second element, and so on. Very old changes remain
728 shown in the last face in the list.
730 You can automatically rotate colors when the buffer is saved by adding
731 this function to `write-file-functions' as a buffer-local value. To do
732 this, eval the following in the buffer to be saved:
734 (add-hook 'write-file-functions 'highlight-changes-rotate-faces nil t)"
735 (interactive)
736 (when (and highlight-changes-mode highlight-changes-visible-mode)
737 (let ((modified (buffer-modified-p))
738 (inhibit-modification-hooks t))
739 ;; The `modified' related code tries to combine two goals: (1) Record the
740 ;; rotation in `buffer-undo-list' and (2) avoid setting the modified flag
741 ;; of the current buffer due to the rotation. We do this by inserting (in
742 ;; `buffer-undo-list') entries restoring buffer-modified-p to nil before
743 ;; and after the entry for the rotation.
744 ;; FIXME: this is no good: we need to test the `modified' state at the
745 ;; time of the undo, not at the time of the "do", otherwise the undo
746 ;; may erroneously clear the modified flag. --Stef
747 ;; (unless modified
748 ;; ;; Install the "before" entry.
749 ;; (push '(apply restore-buffer-modified-p nil) buffer-undo-list))
750 (unwind-protect
751 (progn
752 ;; ensure hilit-chg-list is made and up to date
753 (hilit-chg-make-list)
754 ;; remove our existing overlays
755 (hilit-chg-hide-changes)
756 ;; for each change text property, increment it
757 (hilit-chg-map-changes 'hilit-chg-bump-change)
758 ;; and display them
759 (hilit-chg-display-changes))
760 (unless modified
761 ;; Install the "after" entry. FIXME: See above.
762 ;; (push '(apply restore-buffer-modified-p nil) buffer-undo-list)
764 (restore-buffer-modified-p nil)))))
765 ;; This always returns nil so it is safe to use in write-file-functions
766 nil)
768 ;; ========================================================================
769 ;; Comparing buffers/files
770 ;; These use ediff to find the differences.
772 (defun highlight-markup-buffers
773 (buf-a file-a buf-b file-b &optional markup-a-only)
774 "Get differences between two buffers and set highlight changes.
775 Both buffers are done unless optional parameter MARKUP-A-ONLY
776 is non-nil."
777 (eval-and-compile
778 (require 'ediff-util))
779 (save-window-excursion
780 (let* (change-info
781 change-a change-b
782 a-start a-end len-a
783 b-start b-end len-b
784 (bufa-modified (buffer-modified-p buf-a))
785 (bufb-modified (buffer-modified-p buf-b))
786 (buf-a-read-only (with-current-buffer buf-a buffer-read-only))
787 (buf-b-read-only (with-current-buffer buf-b buffer-read-only))
788 temp-a temp-b)
789 (if (and file-a bufa-modified)
790 (if (y-or-n-p (format "Save buffer %s? " buf-a))
791 (with-current-buffer buf-a
792 (save-buffer)
793 (setq bufa-modified (buffer-modified-p buf-a)))
794 (setq file-a nil)))
795 (or file-a
796 (setq temp-a (setq file-a (ediff-make-temp-file buf-a nil))))
798 (if (and file-b bufb-modified)
799 (if (y-or-n-p (format "Save buffer %s? " buf-b))
800 (with-current-buffer buf-b
801 (save-buffer)
802 (setq bufb-modified (buffer-modified-p buf-b)))
803 (setq file-b nil)))
804 (or file-b
805 (setq temp-b (setq file-b (ediff-make-temp-file buf-b nil))))
806 (set-buffer buf-a)
807 (highlight-changes-mode 1)
808 (or markup-a-only (with-current-buffer buf-b
809 (highlight-changes-mode 1)))
810 (setq change-info (hilit-chg-get-diff-info buf-a file-a buf-b file-b))
813 (setq change-a (car change-info))
814 (setq change-b (car (cdr change-info)))
816 (hilit-chg-make-list)
817 (while change-a
818 (setq a-start (nth 0 (car change-a)))
819 (setq a-end (nth 1 (car change-a)))
820 (setq b-start (nth 0 (car change-b)))
821 (setq b-end (nth 1 (car change-b)))
822 (setq len-a (- a-end a-start))
823 (setq len-b (- b-end b-start))
824 (set-buffer buf-a)
825 (hilit-chg-set-face-on-change a-start a-end len-b buf-a-read-only)
826 (or markup-a-only
827 (with-current-buffer buf-b
828 (hilit-chg-set-face-on-change b-start b-end len-a
829 buf-b-read-only)
831 (setq change-a (cdr change-a))
832 (setq change-b (cdr change-b)))
833 (or bufa-modified
834 (with-current-buffer buf-a (set-buffer-modified-p nil)))
835 (or bufb-modified
836 (with-current-buffer buf-b (set-buffer-modified-p nil)))
837 (if temp-a
838 (delete-file temp-a))
839 (if temp-b
840 (delete-file temp-b)))
843 ;;;###autoload
844 (defun highlight-compare-buffers (buf-a buf-b)
845 "Compare two buffers and highlight the differences.
847 The default is the current buffer and the one in the next window.
849 If either buffer is modified and is visiting a file, you are prompted
850 to save the file.
852 Unless the buffer is unmodified and visiting a file, the buffer is
853 written to a temporary file for comparison.
855 If a buffer is read-only, differences will be highlighted but no property
856 changes are made, so \\[highlight-changes-next-change] and
857 \\[highlight-changes-previous-change] will not work."
858 (interactive
859 (list
860 (get-buffer (read-buffer "buffer-a " (current-buffer) t))
861 (get-buffer
862 (read-buffer "buffer-b "
863 (window-buffer (next-window)) t))))
864 (let ((file-a (buffer-file-name buf-a))
865 (file-b (buffer-file-name buf-b)))
866 (highlight-markup-buffers buf-a file-a buf-b file-b)
869 ;;;###autoload
870 (defun highlight-compare-with-file (file-b)
871 "Compare this buffer with a file, and highlight differences.
873 If the buffer has a backup filename, it is used as the default when
874 this function is called interactively.
876 If the current buffer is visiting the file being compared against, it
877 also will have its differences highlighted. Otherwise, the file is
878 read in temporarily but the buffer is deleted.
880 If the buffer is read-only, differences will be highlighted but no property
881 changes are made, so \\[highlight-changes-next-change] and
882 \\[highlight-changes-previous-change] will not work."
883 (interactive
884 (let ((file buffer-file-name)
885 (file-name nil)
886 (file-dir nil))
887 (and file
888 (setq file-name (file-name-nondirectory file)
889 file-dir (file-name-directory file)))
890 (setq file-name (make-backup-file-name file-name))
891 (unless (file-exists-p file-name)
892 (setq file-name nil))
893 (list (read-file-name
894 "Find to compare with: " ;; prompt
895 file-dir ;; directory
896 nil ;; default
897 nil ;; existing
898 file-name) ;; initial
900 (let* ((buf-a (current-buffer))
901 (file-a (buffer-file-name))
902 (existing-buf (get-file-buffer file-b))
903 (buf-b (or existing-buf
904 (find-file-noselect file-b))))
905 (highlight-markup-buffers buf-a file-a buf-b file-b (not existing-buf))
906 (unless existing-buf
907 (kill-buffer buf-b))
911 (defun hilit-chg-get-diff-info (buf-a file-a buf-b file-b)
912 ;; hilit-e,x,y are set by function hilit-chg-get-diff-list-hk.
913 (let (hilit-e hilit-x hilit-y)
914 (ediff-setup buf-a file-a buf-b file-b
915 nil nil ; buf-c file-C
916 'hilit-chg-get-diff-list-hk
917 (list (cons 'ediff-job-name 'something))
919 (ediff-with-current-buffer hilit-e (ediff-really-quit nil))
920 (list hilit-x hilit-y)))
923 (defun hilit-chg-get-diff-list-hk ()
924 ;; hilit-e/x/y are dynamically bound by hilit-chg-get-diff-info
925 ;; which calls this function as a hook.
926 (defvar hilit-x) ; placate the byte-compiler
927 (defvar hilit-y)
928 (defvar hilit-e)
929 (setq hilit-e (current-buffer))
930 (let ((n 0) extent p va vb a b)
931 (setq hilit-x nil hilit-y nil)
932 (while (< n ediff-number-of-differences)
933 (ediff-make-fine-diffs n)
934 (setq va (ediff-get-fine-diff-vector n 'A))
935 ;; va is a vector if there are fine differences
936 (if va
937 (setq a (append va nil))
938 ;; if not, get the unrefined difference
939 (setq va (ediff-get-difference n 'A))
940 (setq a (list (elt va 0))))
941 ;; a list a list
942 (setq p a)
943 (while p
944 (setq extent (list (overlay-start (car p))
945 (overlay-end (car p))))
946 (setq p (cdr p))
947 (setq hilit-x (append hilit-x (list extent) )));; while p
949 (setq vb (ediff-get-fine-diff-vector n 'B))
950 ;; vb is a vector
951 (if vb
952 (setq b (append vb nil))
953 ;; if not, get the unrefined difference
954 (setq vb (ediff-get-difference n 'B))
955 (setq b (list (elt vb 0))))
956 ;; b list a list
957 (setq p b)
958 (while p
959 (setq extent (list (overlay-start (car p))
960 (overlay-end (car p))))
961 (setq p (cdr p))
962 (setq hilit-y (append hilit-y (list extent) )))
963 (setq n (1+ n)));; while
964 ;; ediff-quit doesn't work here.
965 ;; No point in returning a value, since this is a hook function.
968 ;; ======================= global-highlight-changes-mode ==============
970 ;;;###autoload
971 (define-globalized-minor-mode global-highlight-changes-mode
972 highlight-changes-mode highlight-changes-mode-turn-on)
974 (define-obsolete-function-alias
975 'global-highlight-changes
976 'global-highlight-changes-mode "23.1")
978 (defun highlight-changes-mode-turn-on ()
979 "See if Highlight Changes mode should be turned on for this buffer.
980 This is called when `global-highlight-changes-mode' is turned on."
981 (or highlight-changes-mode ; do nothing if already on
983 (cond
984 ((null highlight-changes-global-modes)
985 nil)
986 ((functionp highlight-changes-global-modes)
987 (funcall highlight-changes-global-modes))
988 ((listp highlight-changes-global-modes)
989 (if (eq (car-safe highlight-changes-global-modes) 'not)
990 (not (memq major-mode (cdr highlight-changes-global-modes)))
991 (memq major-mode highlight-changes-global-modes)))
993 (and
994 (not (string-match "^[ *]" (buffer-name)))
995 (buffer-file-name))))
996 (highlight-changes-mode 1))
1000 ;;;; Desktop support.
1002 ;; Called by `desktop-create-buffer' to restore `highlight-changes-mode'.
1003 (defun hilit-chg-desktop-restore (desktop-buffer-locals)
1004 (highlight-changes-mode
1005 (or (cdr (assq 'highlight-changes-mode desktop-buffer-locals)) 1)))
1007 (add-to-list 'desktop-minor-mode-handlers
1008 '(highlight-changes-mode . hilit-chg-desktop-restore))
1010 (add-to-list 'desktop-locals-to-save 'highlight-changes-mode)
1012 ;; ===================== debug ==================
1013 ;; For debug & test use:
1015 ;; (defun hilit-chg-debug-show (&optional beg end)
1016 ;; (interactive)
1017 ;; (message "--- hilit-chg-debug-show ---")
1018 ;; (hilit-chg-map-changes (lambda (prop start end)
1019 ;; (message "%d-%d: %s" start end prop))
1020 ;; beg end
1021 ;; ))
1023 ;; ================== end of debug ===============
1025 (defun hilit-chg-unload-function ()
1026 "Unload the Highlight Changes library."
1027 (global-hi-lock-mode -1)
1028 ;; continue standard unloading
1029 nil)
1031 (provide 'hilit-chg)
1033 ;;; hilit-chg.el ends here