(Top): Delete duplicate words.
[emacs.git] / lisp / compare-w.el
blobe0a6d5cf73275d6a5766fd86756764bd80e983ff
1 ;;; compare-w.el --- compare text between windows for Emacs
3 ;; Copyright (C) 1986,1989,1993,1997,2003,2004,2005 Free Software Foundation, Inc.
5 ;; Maintainer: FSF
6 ;; Keywords: convenience files
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 2, or (at your option)
13 ;; 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; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
25 ;;; Commentary:
27 ;; This package provides one entry point, compare-windows. It compares
28 ;; text starting from point in two adjacent windows, advancing point
29 ;; until it finds a difference. Option variables permit you to ignore
30 ;; whitespace differences, or case differences, or both.
32 ;;; Code:
34 (defgroup compare-w nil
35 "Compare text between windows."
36 :prefix "compare-"
37 :group 'tools)
39 (defcustom compare-windows-whitespace "\\(\\s-\\|\n\\)+"
40 "*Regexp or function that defines whitespace sequences for `compare-windows'.
41 That command optionally ignores changes in whitespace.
43 The value of `compare-windows-whitespace' is normally a regexp, but it
44 can also be a function. The function's job is to categorize any
45 whitespace around (including before) point; it should also advance
46 past any whitespace. The function is called in each window, with
47 point at the current scanning point. It gets one argument, the point
48 where \\[compare-windows] was originally called; it should not look at
49 any text before that point.
51 If the function returns the same value for both windows, then the
52 whitespace is considered to match, and is skipped."
53 :type '(choice regexp function)
54 :group 'compare-w)
56 (defcustom compare-ignore-whitespace nil
57 "*Non-nil means `compare-windows' ignores whitespace."
58 :type 'boolean
59 :group 'compare-w)
61 (defcustom compare-ignore-case nil
62 "*Non-nil means `compare-windows' ignores case differences."
63 :type 'boolean
64 :group 'compare-w)
66 (defcustom compare-windows-sync 'compare-windows-sync-default-function
67 "*Function or regexp that is used to synchronize points in two
68 windows if before calling `compare-windows' points are located
69 on mismatched positions.
71 The value of `compare-windows-sync' can be a function. The
72 function's job is to advance points in both windows to the next
73 matching text. If the value of `compare-windows-sync' is a
74 regexp, then points in both windows are advanced to the next
75 occurrence of this regexp.
77 The current default value is the general function
78 `compare-windows-sync-default-function' that is able to
79 synchronize points by using quadratic algorithm to find the first
80 matching 32-character string in two windows.
82 The other useful values of this variable could be such functions
83 as `forward-word', `forward-sentence', `forward-paragraph', or a
84 regexp containing some field separator or a newline, depending on
85 the nature of the difference units separator. The variable can
86 be made buffer-local.
88 If the value of this variable is `nil', then function `ding' is
89 called to beep or flash the screen when points are mismatched."
90 :type '(choice regexp function)
91 :group 'compare-w)
93 (defcustom compare-windows-sync-string-size 32
94 "*Size of string from one window that is searched in second window.
96 Small number makes difference regions more fine-grained, but it
97 may fail by finding the wrong match. The bigger number makes
98 difference regions more coarse-grained.
100 The default value 32 is good for the most cases."
101 :type 'integer
102 :group 'compare-w)
104 (defcustom compare-windows-recenter nil
105 "*List of two values, each of which is used as argument of
106 function `recenter' called in each of two windows to place
107 matching points side-by-side.
109 The value `(-1 0)' is useful if windows are split vertically,
110 and the value `((4) (4))' for horizontally split windows."
111 :type '(list sexp sexp)
112 :group 'compare-w)
114 (defcustom compare-windows-highlight t
115 "*Non-nil means compare-windows highlights the differences."
116 :type 'boolean
117 :group 'compare-w)
119 (defface compare-windows
120 '((((class color) (min-colors 88) (background light))
121 (:background "paleturquoise"))
122 (((class color) (min-colors 88) (background dark))
123 (:background "paleturquoise4"))
124 (((class color))
125 (:background "turquoise3"))
126 (t (:underline t)))
127 "Face for highlighting of compare-windows difference regions."
128 :group 'compare-w)
129 ;; backward-compatibility alias
130 (put 'compare-windows-face 'face-alias 'compare-windows)
132 (defvar compare-windows-overlay1 nil)
133 (defvar compare-windows-overlay2 nil)
134 (defvar compare-windows-sync-point nil)
136 ;;;###autoload
137 (defun compare-windows (ignore-whitespace)
138 "Compare text in current window with text in next window.
139 Compares the text starting at point in each window,
140 moving over text in each one as far as they match.
142 This command pushes the mark in each window
143 at the prior location of point in that window.
144 If both windows display the same buffer,
145 the mark is pushed twice in that buffer:
146 first in the other window, then in the selected window.
148 A prefix arg means reverse the value of variable
149 `compare-ignore-whitespace'. If `compare-ignore-whitespace' is
150 nil, then a prefix arg means ignore changes in whitespace. If
151 `compare-ignore-whitespace' is non-nil, then a prefix arg means
152 don't ignore changes in whitespace. The variable
153 `compare-windows-whitespace' controls how whitespace is skipped.
154 If `compare-ignore-case' is non-nil, changes in case are also
155 ignored.
157 If `compare-windows-sync' is non-nil, then successive calls of
158 this command work in interlaced mode:
159 on first call it advances points to the next difference,
160 on second call it synchronizes points by skipping the difference,
161 on third call it again advances points to the next difference and so on."
162 (interactive "P")
163 (let* (p1 p2 maxp1 maxp2 b1 b2 w2
164 (progress 1)
165 (opoint1 (point))
166 opoint2
167 (skip-func (if (if ignore-whitespace ; XOR
168 (not compare-ignore-whitespace)
169 compare-ignore-whitespace)
170 (if (stringp compare-windows-whitespace)
171 'compare-windows-skip-whitespace
172 compare-windows-whitespace)))
173 (sync-func (if (stringp compare-windows-sync)
174 'compare-windows-sync-regexp
175 compare-windows-sync)))
176 (setq p1 (point) b1 (current-buffer))
177 (setq w2 (next-window (selected-window)))
178 (if (eq w2 (selected-window))
179 (setq w2 (next-window (selected-window) nil 'visible)))
180 (if (eq w2 (selected-window))
181 (error "No other window"))
182 (setq p2 (window-point w2)
183 b2 (window-buffer w2))
184 (setq opoint2 p2)
185 (setq maxp1 (point-max))
186 (save-excursion
187 (set-buffer b2)
188 (push-mark p2 t)
189 (setq maxp2 (point-max)))
190 (push-mark)
192 (while (> progress 0)
193 ;; If both windows have whitespace next to point,
194 ;; optionally skip over it.
195 (and skip-func
196 (save-excursion
197 (let (p1a p2a w1 w2 result1 result2)
198 (setq result1 (funcall skip-func opoint1))
199 (setq p1a (point))
200 (set-buffer b2)
201 (goto-char p2)
202 (setq result2 (funcall skip-func opoint2))
203 (setq p2a (point))
204 (if (or (stringp compare-windows-whitespace)
205 (and result1 result2 (eq result1 result2)))
206 (setq p1 p1a
207 p2 p2a)))))
209 (let ((size (min (- maxp1 p1) (- maxp2 p2)))
210 (case-fold-search compare-ignore-case))
211 (setq progress (compare-buffer-substrings b2 p2 (+ size p2)
212 b1 p1 (+ size p1)))
213 (setq progress (if (zerop progress) size (1- (abs progress))))
214 (setq p1 (+ p1 progress) p2 (+ p2 progress)))
215 ;; Advance point now rather than later, in case we're interrupted.
216 (goto-char p1)
217 (set-window-point w2 p2)
218 (when compare-windows-recenter
219 (recenter (car compare-windows-recenter))
220 (with-selected-window w2 (recenter (cadr compare-windows-recenter)))))
222 (if (= (point) opoint1)
223 (if (not sync-func)
224 (ding)
225 ;; If points are not advanced (i.e. already on mismatch position),
226 ;; then synchronize points between both windows
227 (save-excursion
228 (setq compare-windows-sync-point nil)
229 (funcall sync-func)
230 (setq p1 (point))
231 (set-buffer b2)
232 (goto-char p2)
233 (funcall sync-func)
234 (setq p2 (point)))
235 (goto-char p1)
236 (set-window-point w2 p2)
237 (when compare-windows-recenter
238 (recenter (car compare-windows-recenter))
239 (with-selected-window w2 (recenter (cadr compare-windows-recenter))))
240 ;; If points are still not synchronized, then ding
241 (when (and (= p1 opoint1) (= p2 opoint2))
242 ;; Display error message when current points in two windows
243 ;; are unmatched and next matching points can't be found.
244 (compare-windows-dehighlight)
245 (ding)
246 (message "No more matching points"))))))
248 ;; Move forward over whatever might be called whitespace.
249 ;; compare-windows-whitespace is a regexp that matches whitespace.
250 ;; Match it at various starting points before the original point
251 ;; and find the latest point at which a match ends.
252 ;; Don't try starting points before START, though.
253 ;; Value is non-nil if whitespace is found.
254 ;; If there is whitespace before point, but none after,
255 ;; then return t, but don't advance point.
256 (defun compare-windows-skip-whitespace (start)
257 (let ((end (point))
258 (beg (point))
259 (opoint (point)))
260 (while (or (and (looking-at compare-windows-whitespace)
261 (<= end (match-end 0))
262 ;; This match goes past END, so advance END.
263 (progn (setq end (match-end 0))
264 (> (point) start)))
265 (and (/= (point) start)
266 ;; Consider at least the char before point,
267 ;; unless it is also before START.
268 (= (point) opoint)))
269 ;; keep going back until whitespace
270 ;; doesn't extend to or past end
271 (forward-char -1))
272 (setq beg (point))
273 (goto-char end)
274 (or (/= beg opoint)
275 (/= end opoint))))
277 ;; Move forward to the next synchronization regexp.
278 (defun compare-windows-sync-regexp ()
279 (if (stringp compare-windows-sync)
280 (re-search-forward compare-windows-sync nil t)))
282 ;; Function works in two passes: one call on each window.
283 ;; On the first call both matching points are computed,
284 ;; and one of them is stored in compare-windows-sync-point
285 ;; to be used when this function is called on second window.
286 (defun compare-windows-sync-default-function ()
287 (if (not compare-windows-sync-point)
288 (let* ((w1 (selected-window))
289 (w2 (next-window w1))
290 (b2 (window-buffer w2))
291 (point-max2 (with-current-buffer b2 (point-max)))
292 (op2 (window-point w2))
293 (op1 (point))
294 (region-size compare-windows-sync-string-size)
295 (string-size compare-windows-sync-string-size)
296 in-bounds-p s1 p2 p12s p12)
297 (while (and
298 ;; until matching points are found
299 (not p12s)
300 ;; until size exceeds the maximum points of both buffers
301 ;; (bounds below take care to not overdo in each of them)
302 (or (setq in-bounds-p (< region-size (max (- (point-max) op1)
303 (- point-max2 op2))))
304 ;; until string size becomes smaller than 4
305 (> string-size 4)))
306 (if in-bounds-p
307 ;; make the next search in the double-sized region;
308 ;; on first iteration it is 2*compare-windows-sync-string-size,
309 ;; on last iterations it exceeds both buffers maximum points
310 (setq region-size (* region-size 2))
311 ;; if region size exceeds the maximum points of both buffers,
312 ;; then start to halve the string size until 4;
313 ;; this helps to find differences near the end of buffers
314 (setq string-size (/ string-size 2)))
315 (let ((p1 op1)
316 (bound1 (- (min (+ op1 region-size) (point-max)) string-size))
317 (bound2 (min (+ op2 region-size) point-max2)))
318 (while (< p1 bound1)
319 (setq s1 (buffer-substring-no-properties p1 (+ p1 string-size)))
320 (setq p2 (with-current-buffer b2
321 (goto-char op2)
322 (let ((case-fold-search compare-ignore-case))
323 (search-forward s1 bound2 t))))
324 (when p2
325 (setq p2 (- p2 string-size))
326 (setq p12s (cons (list (+ p1 p2) p1 p2) p12s)))
327 (setq p1 (1+ p1)))))
328 (when p12s
329 ;; use closest matching points (i.e. points with minimal sum)
330 (setq p12 (cdr (assq (apply 'min (mapcar 'car p12s)) p12s)))
331 (goto-char (car p12))
332 (compare-windows-highlight op1 (car p12) (current-buffer) w1
333 op2 (cadr p12) b2 w2))
334 (setq compare-windows-sync-point (or (cadr p12) t)))
335 ;; else set point in the second window to the pre-calculated value
336 (if (numberp compare-windows-sync-point)
337 (goto-char compare-windows-sync-point))
338 (setq compare-windows-sync-point nil)))
340 ;; Highlight differences
341 (defun compare-windows-highlight (beg1 end1 b1 w1 beg2 end2 b2 w2)
342 (when compare-windows-highlight
343 (if compare-windows-overlay1
344 (move-overlay compare-windows-overlay1 beg1 end1 b1)
345 (setq compare-windows-overlay1 (make-overlay beg1 end1 b1))
346 (overlay-put compare-windows-overlay1 'face 'compare-windows)
347 (overlay-put compare-windows-overlay1 'priority 1))
348 (overlay-put compare-windows-overlay1 'window w1)
349 (if compare-windows-overlay2
350 (move-overlay compare-windows-overlay2 beg2 end2 b2)
351 (setq compare-windows-overlay2 (make-overlay beg2 end2 b2))
352 (overlay-put compare-windows-overlay2 'face 'compare-windows)
353 (overlay-put compare-windows-overlay2 'priority 1))
354 (overlay-put compare-windows-overlay2 'window w2)
355 ;; Remove highlighting before next command is executed
356 (add-hook 'pre-command-hook 'compare-windows-dehighlight)))
358 (defun compare-windows-dehighlight ()
359 "Remove highlighting created by `compare-windows-highlight'."
360 (interactive)
361 (remove-hook 'pre-command-hook 'compare-windows-dehighlight)
362 (and compare-windows-overlay1 (delete-overlay compare-windows-overlay1))
363 (and compare-windows-overlay2 (delete-overlay compare-windows-overlay2)))
365 (provide 'compare-w)
367 ;;; arch-tag: 4177aab1-48e6-4a98-b7a1-000ee285de46
368 ;;; compare-w.el ends here