X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/827342364655e5ac2ae80d9b34b8abb20c186a0f..ad8b6d89ef6f038921104c219ff9010ee08cb0ca:/lisp/compare-w.el diff --git a/lisp/compare-w.el b/lisp/compare-w.el index 4f06ef8c53..3fda5f5de7 100644 --- a/lisp/compare-w.el +++ b/lisp/compare-w.el @@ -1,8 +1,10 @@ -;;; compare-w.el --- compare text between windows for Emacs. +;;; compare-w.el --- compare text between windows for Emacs -;; Copyright (C) 1986, 1989, 1993 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1989, 1993, 1997, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Maintainer: FSF +;; Keywords: convenience files ;; This file is part of GNU Emacs. @@ -17,8 +19,9 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -29,22 +32,105 @@ ;;; Code: -(defvar compare-windows-whitespace "[ \t\n]+" - "*Regexp that defines whitespace sequences for \\[compare-windows]. -Changes in whitespace are optionally ignored. +(defgroup compare-w nil + "Compare text between windows." + :prefix "compare-" + :group 'tools) -The value of `compare-windows-whitespace' may instead be a function; this -function is called in each buffer, with point at the current scanning point. -The function's job is to categorize any whitespace around (including before) -point; it should also advance past any whitespace. +(defcustom compare-windows-whitespace "\\(\\s-\\|\n\\)+" + "*Regexp or function that defines whitespace sequences for `compare-windows'. +That command optionally ignores changes in whitespace. -The function is passed one argument, the point where `compare-windows' -was originally called; it should not consider any text before that point. -If the function returns the same value for both buffers, then the -whitespace is considered to match, and is skipped.") +The value of `compare-windows-whitespace' is normally a regexp, but it +can also be a function. The function's job is to categorize any +whitespace around (including before) point; it should also advance +past any whitespace. The function is called in each window, with +point at the current scanning point. It gets one argument, the point +where \\[compare-windows] was originally called; it should not look at +any text before that point. -(defvar compare-ignore-case nil - "*Non-nil means \\[compare-windows] ignores case differences.") +If the function returns the same value for both windows, then the +whitespace is considered to match, and is skipped." + :type '(choice regexp function) + :group 'compare-w) + +(defcustom compare-ignore-whitespace nil + "*Non-nil means `compare-windows' ignores whitespace." + :type 'boolean + :group 'compare-w + :version "22.1") + +(defcustom compare-ignore-case nil + "*Non-nil means `compare-windows' ignores case differences." + :type 'boolean + :group 'compare-w) + +(defcustom compare-windows-sync 'compare-windows-sync-default-function + "*Function or regexp that is used to synchronize points in two +windows if before calling `compare-windows' points are located +on mismatched positions. + +The value of `compare-windows-sync' can be a function. The +function's job is to advance points in both windows to the next +matching text. If the value of `compare-windows-sync' is a +regexp, then points in both windows are advanced to the next +occurrence of this regexp. + +The current default value is the general function +`compare-windows-sync-default-function' that is able to +synchronize points by using quadratic algorithm to find the first +matching 32-character string in two windows. + +The other useful values of this variable could be such functions +as `forward-word', `forward-sentence', `forward-paragraph', or a +regexp containing some field separator or a newline, depending on +the nature of the difference units separator. The variable can +be made buffer-local. + +If the value of this variable is `nil', then function `ding' is +called to beep or flash the screen when points are mismatched." + :type '(choice regexp function) + :group 'compare-w + :version "22.1") + +(defcustom compare-windows-sync-string-size 32 + "*Size of string from one window that is searched in second window. + +Small number makes difference regions more fine-grained, but it +may fail by finding the wrong match. The bigger number makes +difference regions more coarse-grained. + +The default value 32 is good for the most cases." + :type 'integer + :group 'compare-w + :version "22.1") + +(defcustom compare-windows-recenter nil + "*List of two values, each of which is used as argument of +function `recenter' called in each of two windows to place +matching points side-by-side. + +The value `(-1 0)' is useful if windows are split vertically, +and the value `((4) (4))' for horizontally split windows." + :type '(list sexp sexp) + :group 'compare-w + :version "22.1") + +(defcustom compare-windows-highlight t + "*Non-nil means compare-windows highlights the differences." + :type 'boolean + :group 'compare-w + :version "22.1") + +(defface compare-windows + '((t :inherit lazy-highlight)) + "Face for highlighting of compare-windows difference regions." + :group 'compare-w + :version "22.1") + +(defvar compare-windows-overlay1 nil) +(defvar compare-windows-overlay2 nil) +(defvar compare-windows-sync-point nil) ;;;###autoload (defun compare-windows (ignore-whitespace) @@ -58,18 +144,38 @@ If both windows display the same buffer, the mark is pushed twice in that buffer: first in the other window, then in the selected window. -A prefix arg means ignore changes in whitespace. -The variable `compare-windows-whitespace' controls how whitespace is skipped. -If `compare-ignore-case' is non-nil, changes in case are also ignored." +A prefix arg means reverse the value of variable +`compare-ignore-whitespace'. If `compare-ignore-whitespace' is +nil, then a prefix arg means ignore changes in whitespace. If +`compare-ignore-whitespace' is non-nil, then a prefix arg means +don't ignore changes in whitespace. The variable +`compare-windows-whitespace' controls how whitespace is skipped. +If `compare-ignore-case' is non-nil, changes in case are also +ignored. + +If `compare-windows-sync' is non-nil, then successive calls of +this command work in interlaced mode: +on first call it advances points to the next difference, +on second call it synchronizes points by skipping the difference, +on third call it again advances points to the next difference and so on." (interactive "P") (let* (p1 p2 maxp1 maxp2 b1 b2 w2 - success size + (progress 1) (opoint1 (point)) opoint2 - (skip-whitespace (if ignore-whitespace - compare-windows-whitespace))) + (skip-func (if (if ignore-whitespace ; XOR + (not compare-ignore-whitespace) + compare-ignore-whitespace) + (if (stringp compare-windows-whitespace) + 'compare-windows-skip-whitespace + compare-windows-whitespace))) + (sync-func (if (stringp compare-windows-sync) + 'compare-windows-sync-regexp + compare-windows-sync))) (setq p1 (point) b1 (current-buffer)) (setq w2 (next-window (selected-window))) + (if (eq w2 (selected-window)) + (setq w2 (next-window (selected-window) nil 'visible))) (if (eq w2 (selected-window)) (error "No other window")) (setq p2 (window-point w2) @@ -82,60 +188,61 @@ If `compare-ignore-case' is non-nil, changes in case are also ignored." (setq maxp2 (point-max))) (push-mark) - (setq success t) - (while success - (setq success nil) - ;; if interrupted, show how far we've gotten - (goto-char p1) - (set-window-point w2 p2) - - ;; If both buffers have whitespace next to point, + (while (> progress 0) + ;; If both windows have whitespace next to point, ;; optionally skip over it. - - (and skip-whitespace + (and skip-func (save-excursion (let (p1a p2a w1 w2 result1 result2) - (setq result1 - (if (stringp skip-whitespace) - (compare-windows-skip-whitespace opoint1) - (funcall skip-whitespace opoint1))) + (setq result1 (funcall skip-func opoint1)) (setq p1a (point)) (set-buffer b2) (goto-char p2) - (setq result2 - (if (stringp skip-whitespace) - (compare-windows-skip-whitespace opoint2) - (funcall skip-whitespace opoint2))) + (setq result2 (funcall skip-func opoint2)) (setq p2a (point)) - (if (or (stringp skip-whitespace) + (if (or (stringp compare-windows-whitespace) (and result1 result2 (eq result1 result2))) (setq p1 p1a p2 p2a))))) - ;; Try advancing comparing 1000 chars at a time. - ;; When that fails, go 500 chars at a time, and so on. - (let ((size 1000) - success-1 + (let ((size (min (- maxp1 p1) (- maxp2 p2))) (case-fold-search compare-ignore-case)) - (while (> size 0) - (setq success-1 t) - ;; Try comparing SIZE chars at a time, repeatedly, till that fails. - (while success-1 - (setq size (min size (- maxp1 p1) (- maxp2 p2))) - (setq success-1 - (and (> size 0) - (= 0 (compare-buffer-substrings b2 p2 (+ size p2) - b1 p1 (+ size p1))))) - (if success-1 - (setq p1 (+ p1 size) p2 (+ p2 size) - success t))) - ;; If SIZE chars don't match, try fewer. - (setq size (/ size 2))))) - - (goto-char p1) - (set-window-point w2 p2) + (setq progress (compare-buffer-substrings b2 p2 (+ size p2) + b1 p1 (+ size p1))) + (setq progress (if (zerop progress) size (1- (abs progress)))) + (setq p1 (+ p1 progress) p2 (+ p2 progress))) + ;; Advance point now rather than later, in case we're interrupted. + (goto-char p1) + (set-window-point w2 p2) + (when compare-windows-recenter + (recenter (car compare-windows-recenter)) + (with-selected-window w2 (recenter (cadr compare-windows-recenter))))) + (if (= (point) opoint1) - (ding)))) + (if (not sync-func) + (ding) + ;; If points are not advanced (i.e. already on mismatch position), + ;; then synchronize points between both windows + (save-excursion + (setq compare-windows-sync-point nil) + (funcall sync-func) + (setq p1 (point)) + (set-buffer b2) + (goto-char p2) + (funcall sync-func) + (setq p2 (point))) + (goto-char p1) + (set-window-point w2 p2) + (when compare-windows-recenter + (recenter (car compare-windows-recenter)) + (with-selected-window w2 (recenter (cadr compare-windows-recenter)))) + ;; If points are still not synchronized, then ding + (when (and (= p1 opoint1) (= p2 opoint2)) + ;; Display error message when current points in two windows + ;; are unmatched and next matching points can't be found. + (compare-windows-dehighlight) + (ding) + (message "No more matching points")))))) ;; Move forward over whatever might be called whitespace. ;; compare-windows-whitespace is a regexp that matches whitespace. @@ -143,7 +250,6 @@ If `compare-ignore-case' is non-nil, changes in case are also ignored." ;; and find the latest point at which a match ends. ;; Don't try starting points before START, though. ;; Value is non-nil if whitespace is found. - ;; If there is whitespace before point, but none after, ;; then return t, but don't advance point. (defun compare-windows-skip-whitespace (start) @@ -167,6 +273,95 @@ If `compare-ignore-case' is non-nil, changes in case are also ignored." (or (/= beg opoint) (/= end opoint)))) +;; Move forward to the next synchronization regexp. +(defun compare-windows-sync-regexp () + (if (stringp compare-windows-sync) + (re-search-forward compare-windows-sync nil t))) + +;; Function works in two passes: one call on each window. +;; On the first call both matching points are computed, +;; and one of them is stored in compare-windows-sync-point +;; to be used when this function is called on second window. +(defun compare-windows-sync-default-function () + (if (not compare-windows-sync-point) + (let* ((w1 (selected-window)) + (w2 (next-window w1)) + (b2 (window-buffer w2)) + (point-max2 (with-current-buffer b2 (point-max))) + (op2 (window-point w2)) + (op1 (point)) + (region-size compare-windows-sync-string-size) + (string-size compare-windows-sync-string-size) + in-bounds-p s1 p2 p12s p12) + (while (and + ;; until matching points are found + (not p12s) + ;; until size exceeds the maximum points of both buffers + ;; (bounds below take care to not overdo in each of them) + (or (setq in-bounds-p (< region-size (max (- (point-max) op1) + (- point-max2 op2)))) + ;; until string size becomes smaller than 4 + (> string-size 4))) + (if in-bounds-p + ;; make the next search in the double-sized region; + ;; on first iteration it is 2*compare-windows-sync-string-size, + ;; on last iterations it exceeds both buffers maximum points + (setq region-size (* region-size 2)) + ;; if region size exceeds the maximum points of both buffers, + ;; then start to halve the string size until 4; + ;; this helps to find differences near the end of buffers + (setq string-size (/ string-size 2))) + (let ((p1 op1) + (bound1 (- (min (+ op1 region-size) (point-max)) string-size)) + (bound2 (min (+ op2 region-size) point-max2))) + (while (< p1 bound1) + (setq s1 (buffer-substring-no-properties p1 (+ p1 string-size))) + (setq p2 (with-current-buffer b2 + (goto-char op2) + (let ((case-fold-search compare-ignore-case)) + (search-forward s1 bound2 t)))) + (when p2 + (setq p2 (- p2 string-size)) + (setq p12s (cons (list (+ p1 p2) p1 p2) p12s))) + (setq p1 (1+ p1))))) + (when p12s + ;; use closest matching points (i.e. points with minimal sum) + (setq p12 (cdr (assq (apply 'min (mapcar 'car p12s)) p12s))) + (goto-char (car p12)) + (compare-windows-highlight op1 (car p12) (current-buffer) w1 + op2 (cadr p12) b2 w2)) + (setq compare-windows-sync-point (or (cadr p12) t))) + ;; else set point in the second window to the pre-calculated value + (if (numberp compare-windows-sync-point) + (goto-char compare-windows-sync-point)) + (setq compare-windows-sync-point nil))) + +;; Highlight differences +(defun compare-windows-highlight (beg1 end1 b1 w1 beg2 end2 b2 w2) + (when compare-windows-highlight + (if compare-windows-overlay1 + (move-overlay compare-windows-overlay1 beg1 end1 b1) + (setq compare-windows-overlay1 (make-overlay beg1 end1 b1)) + (overlay-put compare-windows-overlay1 'face 'compare-windows) + (overlay-put compare-windows-overlay1 'priority 1)) + (overlay-put compare-windows-overlay1 'window w1) + (if compare-windows-overlay2 + (move-overlay compare-windows-overlay2 beg2 end2 b2) + (setq compare-windows-overlay2 (make-overlay beg2 end2 b2)) + (overlay-put compare-windows-overlay2 'face 'compare-windows) + (overlay-put compare-windows-overlay2 'priority 1)) + (overlay-put compare-windows-overlay2 'window w2) + ;; Remove highlighting before next command is executed + (add-hook 'pre-command-hook 'compare-windows-dehighlight))) + +(defun compare-windows-dehighlight () + "Remove highlighting created by `compare-windows-highlight'." + (interactive) + (remove-hook 'pre-command-hook 'compare-windows-dehighlight) + (and compare-windows-overlay1 (delete-overlay compare-windows-overlay1)) + (and compare-windows-overlay2 (delete-overlay compare-windows-overlay2))) + (provide 'compare-w) +;;; arch-tag: 4177aab1-48e6-4a98-b7a1-000ee285de46 ;;; compare-w.el ends here