code.delx.au - gnu-emacs/blob - lisp/vc/compare-w.el

   1 ;;; compare-w.el --- compare text between windows for Emacs
   2
   3 ;; Copyright (C) 1986, 1989, 1993, 1997, 2001-2014 Free Software
   4 ;; Foundation, Inc.
   5
   6 ;; Maintainer: emacs-devel@gnu.org
   7 ;; Keywords: convenience files vc
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This package provides one entry point, compare-windows.  It compares
  27 ;; text starting from point in two adjacent windows, advancing point
  28 ;; until it finds a difference.  Option variables permit you to ignore
  29 ;; whitespace differences, or case differences, or both.
  30
  31 ;;; Code:
  32
  33 (defgroup compare-windows nil
  34   "Compare text between windows."
  35   :prefix "compare-"
  36   :group 'tools)
  37
  38 (defcustom compare-windows-whitespace "\\(\\s-\\|\n\\|\240\\)+"
  39   "Regexp or function that defines whitespace sequences for `compare-windows'.
  40 That command optionally ignores changes in whitespace.
  41
  42 The value of `compare-windows-whitespace' is normally a regexp, but it
  43 can also be a function.  The function's job is to categorize any
  44 whitespace around (including before) point; it should also advance
  45 past any whitespace.  The function is called in each window, with
  46 point at the current scanning point.  It gets one argument, the point
  47 where \\[compare-windows] was originally called; it should not look at
  48 any text before that point.
  49
  50 If the function returns the same value for both windows, then the
  51 whitespace is considered to match, and is skipped."
  52   :version "24.4"                       ; added \240
  53   :type '(choice regexp function)
  54   :group 'compare-windows)
  55
  56 (defcustom compare-ignore-whitespace nil
  57   "Non-nil means command `compare-windows' ignores whitespace."
  58   :type 'boolean
  59   :group 'compare-windows
  60   :version "22.1")
  61
  62 (defcustom compare-ignore-case nil
  63   "Non-nil means command `compare-windows' ignores case differences."
  64   :type 'boolean
  65   :group 'compare-windows)
  66
  67 (defcustom compare-windows-sync 'compare-windows-sync-default-function
  68   "Function or regexp that is used to synchronize points in two
  69 windows if before calling `compare-windows' points are located
  70 on mismatched positions.
  71
  72 The value of `compare-windows-sync' can be a function.  The
  73 function's job is to advance points in both windows to the next
  74 matching text.  If the value of `compare-windows-sync' is a
  75 regexp, then points in both windows are advanced to the next
  76 occurrence of this regexp.
  77
  78 The current default value is the general function
  79 `compare-windows-sync-default-function' that is able to
  80 synchronize points by using quadratic algorithm to find the first
  81 matching 32-character string in two windows.
  82
  83 The other useful values of this variable could be such functions
  84 as `forward-word', `forward-sentence', `forward-paragraph', or a
  85 regexp containing some field separator or a newline, depending on
  86 the nature of the difference units separator.  The variable can
  87 be made buffer-local.
  88
  89 If the value of this variable is `nil' (option \"No sync\"), then
  90 no synchronization is performed, and the function `ding' is called
  91 to beep or flash the screen when points are mismatched."
  92   :type '(choice function regexp (const :tag "No sync" nil))
  93   :group 'compare-windows
  94   :version "22.1")
  95
  96 (defcustom compare-windows-sync-string-size 32
  97   "Size of string from one window that is searched in second window.
  98
  99 Small number makes difference regions more fine-grained, but it
 100 may fail by finding the wrong match.  The bigger number makes
 101 difference regions more coarse-grained.
 102
 103 The default value 32 is good for the most cases."
 104   :type 'integer
 105   :group 'compare-windows
 106   :version "22.1")
 107
 108 (defcustom compare-windows-recenter nil
 109   "List of two values, each of which is used as argument of
 110 function `recenter' called in each of two windows to place
 111 matching points side-by-side.
 112
 113 The value `(-1 0)' is useful if windows are split vertically,
 114 and the value `((4) (4))' for horizontally split windows."
 115   :type '(list sexp sexp)
 116   :group 'compare-windows
 117   :version "22.1")
 118
 119 (defcustom compare-windows-highlight t
 120   "Non-nil means compare-windows highlights the differences.
 121 The value t removes highlighting immediately after invoking a command
 122 other than `compare-windows'.
 123 The value `persistent' leaves all highlighted differences.  You can clear
 124 out all highlighting later with the command `compare-windows-dehighlight'."
 125   :type '(choice (const :tag "No highlighting" nil)
 126                  (const :tag "Persistent highlighting" persistent)
 127                  (other :tag "Highlight until next command" t))
 128   :group 'compare-windows
 129   :version "22.1")
 130
 131 (defface compare-windows
 132   '((t :inherit lazy-highlight))
 133   "Face for highlighting of compare-windows difference regions."
 134   :group 'compare-windows
 135   :version "22.1")
 136
 137 (defvar compare-windows-overlay1 nil)
 138 (defvar compare-windows-overlay2 nil)
 139 (defvar compare-windows-overlays1 nil)
 140 (defvar compare-windows-overlays2 nil)
 141 (defvar compare-windows-sync-point nil)
 142
 143 (defcustom compare-windows-get-window-function 'compare-windows-get-recent-window
 144   "Function that provides the window to compare with."
 145   :type '(choice
 146           (function-item :tag "Most recently used window"
 147                          compare-windows-get-recent-window)
 148           (function-item :tag "Next window"
 149                          compare-windows-get-next-window)
 150           (function :tag "Your function"))
 151   :group 'compare-windows
 152   :version "25.0")
 153
 154 (defun compare-windows-get-recent-window ()
 155   "Return the most recently used window.
 156 First try to get the most recently used window on a visible frame,
 157 then try to get a window on an iconified frame, and finally
 158 consider all existing frames."
 159   (or (get-mru-window 'visible t t)
 160       (get-mru-window 0 t t)
 161       (get-mru-window t t t)))
 162
 163 (defun compare-windows-get-next-window ()
 164   "Return the window next in the cyclic ordering of windows.
 165 In the selected frame contains only one window, consider windows
 166 on all visible frames."
 167   (let ((w2 (next-window)))
 168     (if (eq w2 (selected-window))
 169         (setq w2 (next-window (selected-window) nil 'visible)))
 170     (if (eq w2 (selected-window))
 171         (error "No other window"))
 172     w2))
 173
 174 ;;;###autoload
 175 (defun compare-windows (ignore-whitespace)
 176   "Compare text in current window with text in another window.
 177 The option `compare-windows-get-window-function' defines how
 178 to get another window.
 179
 180 Compares the text starting at point in each window,
 181 moving over text in each one as far as they match.
 182
 183 This command pushes the mark in each window
 184 at the prior location of point in that window.
 185 If both windows display the same buffer,
 186 the mark is pushed twice in that buffer:
 187 first in the other window, then in the selected window.
 188
 189 A prefix arg means reverse the value of variable
 190 `compare-ignore-whitespace'.  If `compare-ignore-whitespace' is
 191 nil, then a prefix arg means ignore changes in whitespace.  If
 192 `compare-ignore-whitespace' is non-nil, then a prefix arg means
 193 don't ignore changes in whitespace.  The variable
 194 `compare-windows-whitespace' controls how whitespace is skipped.
 195 If `compare-ignore-case' is non-nil, changes in case are also
 196 ignored.
 197
 198 If `compare-windows-sync' is non-nil, then successive calls of
 199 this command work in interlaced mode:
 200 on first call it advances points to the next difference,
 201 on second call it synchronizes points by skipping the difference,
 202 on third call it again advances points to the next difference and so on."
 203   (interactive "P")
 204   (if compare-ignore-whitespace
 205       (setq ignore-whitespace (not ignore-whitespace)))
 206   (let* (p1 p2 maxp1 maxp2 b1 b2 w2
 207             (progress 1)
 208             (opoint1 (point))
 209             opoint2
 210             skip-func-1
 211             skip-func-2
 212             (sync-func (if (stringp compare-windows-sync)
 213                            'compare-windows-sync-regexp
 214                          compare-windows-sync)))
 215     (setq p1 (point) b1 (current-buffer))
 216     (setq w2 (funcall compare-windows-get-window-function))
 217     (setq p2 (window-point w2)
 218           b2 (window-buffer w2))
 219     (setq opoint2 p2)
 220     (setq maxp1 (point-max))
 221
 222     (setq skip-func-1 (if ignore-whitespace
 223                           (if (stringp compare-windows-whitespace)
 224                               (lambda (pos)
 225                                 (compare-windows-skip-whitespace pos)
 226                                 t)
 227                             compare-windows-whitespace)))
 228
 229     (with-current-buffer b2
 230       (setq skip-func-2 (if ignore-whitespace
 231                             (if (stringp compare-windows-whitespace)
 232                               (lambda (pos)
 233                                 (compare-windows-skip-whitespace pos)
 234                                 t)
 235                               compare-windows-whitespace)))
 236       (push-mark p2 t)
 237       (setq maxp2 (point-max)))
 238     (push-mark)
 239
 240     (while (> progress 0)
 241       ;; If both windows have whitespace next to point,
 242       ;; optionally skip over it.
 243       (and skip-func-1
 244            (save-excursion
 245              (let (p1a p2a result1 result2)
 246                (setq result1 (funcall skip-func-1 opoint1))
 247                (setq p1a (point))
 248                (set-buffer b2)
 249                (goto-char p2)
 250                (setq result2 (funcall skip-func-2 opoint2))
 251                (setq p2a (point))
 252                (if (and result1 result2 (eq result1 result2))
 253                    (setq p1 p1a
 254                          p2 p2a)))))
 255
 256       (let ((size (min (- maxp1 p1) (- maxp2 p2)))
 257             (case-fold-search compare-ignore-case))
 258         (setq progress (compare-buffer-substrings b2 p2 (+ size p2)
 259                                                   b1 p1 (+ size p1)))
 260         (setq progress (if (zerop progress) size (1- (abs progress))))
 261         (setq p1 (+ p1 progress) p2 (+ p2 progress)))
 262       ;; Advance point now rather than later, in case we're interrupted.
 263       (goto-char p1)
 264       (set-window-point w2 p2)
 265       (when compare-windows-recenter
 266         (recenter (car compare-windows-recenter))
 267         (with-selected-window w2 (recenter (cadr compare-windows-recenter)))))
 268
 269     (if (= (point) opoint1)
 270         (if (not sync-func)
 271             (ding)
 272           ;; If points are not advanced (i.e. already on mismatch position),
 273           ;; then synchronize points between both windows
 274           (save-excursion
 275             (setq compare-windows-sync-point nil)
 276             (funcall sync-func)
 277             (setq p1 (point))
 278             (set-buffer b2)
 279             (goto-char p2)
 280             (funcall sync-func)
 281             (setq p2 (point)))
 282           (goto-char p1)
 283           (set-window-point w2 p2)
 284           (when compare-windows-recenter
 285             (recenter (car compare-windows-recenter))
 286             (with-selected-window w2 (recenter (cadr compare-windows-recenter))))
 287           ;; If points are still not synchronized, then ding
 288           (if (and (= p1 opoint1) (= p2 opoint2))
 289               (progn
 290                 ;; Display error message when current points in two windows
 291                 ;; are unmatched and next matching points can't be found.
 292                 (compare-windows-dehighlight)
 293                 (ding)
 294                 (message "No more matches with %s" b2))
 295             (message "Diff -%s,%s +%s,%s with %s" opoint2 p2 opoint1 p1 b2)))
 296       (message "Match -%s,%s +%s,%s with %s" opoint2 p2 opoint1 p1 b2))))
 297
 298 ;; Move forward over whatever might be called whitespace.
 299 ;; compare-windows-whitespace is a regexp that matches whitespace.
 300 ;; Match it at various starting points before the original point
 301 ;; and find the latest point at which a match ends.
 302 ;; Don't try starting points before START, though.
 303 ;; Value is non-nil if whitespace is found.
 304 ;; If there is whitespace before point, but none after,
 305 ;; then return t, but don't advance point.
 306 (defun compare-windows-skip-whitespace (start)
 307   (let ((end (point))
 308         (beg (point))
 309         (opoint (point)))
 310     (while (or (and (looking-at compare-windows-whitespace)
 311                     (<= end (match-end 0))
 312                     ;; This match goes past END, so advance END.
 313                     (progn (setq end (match-end 0))
 314                            (> (point) start)))
 315                (and (/= (point) start)
 316                     ;; Consider at least the char before point,
 317                     ;; unless it is also before START.
 318                     (= (point) opoint)))
 319       ;; keep going back until whitespace
 320       ;; doesn't extend to or past end
 321       (forward-char -1))
 322     (setq beg (point))
 323     (goto-char end)
 324     (or (/= beg opoint)
 325         (/= end opoint))))
 326
 327 ;; Move forward to the next synchronization regexp.
 328 (defun compare-windows-sync-regexp ()
 329   (if (stringp compare-windows-sync)
 330       (re-search-forward compare-windows-sync nil t)))
 331
 332 ;; Function works in two passes: one call on each window.
 333 ;; On the first call both matching points are computed,
 334 ;; and one of them is stored in compare-windows-sync-point
 335 ;; to be used when this function is called on second window.
 336 (defun compare-windows-sync-default-function ()
 337   (if (not compare-windows-sync-point)
 338       (let* ((w1 (selected-window))
 339              (w2 (funcall compare-windows-get-window-function))
 340              (b2 (window-buffer w2))
 341              (point-max2 (with-current-buffer b2 (point-max)))
 342              (op2 (window-point w2))
 343              (op1 (point))
 344              (region-size compare-windows-sync-string-size)
 345              (string-size compare-windows-sync-string-size)
 346              in-bounds-p s1 p2 p12s p12)
 347         (while (and
 348                 ;; until matching points are found
 349                 (not p12s)
 350                 ;; until size exceeds the maximum points of both buffers
 351                 ;; (bounds below take care to not overdo in each of them)
 352                 (or (setq in-bounds-p (< region-size (max (- (point-max) op1)
 353                                                           (- point-max2 op2))))
 354                     ;; until string size becomes smaller than 4
 355                     (> string-size 4)))
 356           (if in-bounds-p
 357               ;; make the next search in the double-sized region;
 358               ;; on first iteration it is 2*compare-windows-sync-string-size,
 359               ;; on last iterations it exceeds both buffers maximum points
 360               (setq region-size (* region-size 2))
 361             ;; if region size exceeds the maximum points of both buffers,
 362             ;; then start to halve the string size until 4;
 363             ;; this helps to find differences near the end of buffers
 364             (setq string-size (/ string-size 2)))
 365           (let ((p1 op1)
 366                 (bound1 (- (min (+ op1 region-size) (point-max)) string-size))
 367                 (bound2 (min (+ op2 region-size) point-max2)))
 368             (while (< p1 bound1)
 369               (setq s1 (buffer-substring-no-properties p1 (+ p1 string-size)))
 370               (setq p2 (with-current-buffer b2
 371                          (goto-char op2)
 372                          (let ((case-fold-search compare-ignore-case))
 373                            (search-forward s1 bound2 t))))
 374               (when p2
 375                 (setq p2 (- p2 string-size))
 376                 (setq p12s (cons (list (+ p1 p2) p1 p2) p12s)))
 377               (setq p1 (1+ p1)))))
 378         (when p12s
 379           ;; use closest matching points (i.e. points with minimal sum)
 380           (setq p12 (cdr (assq (apply 'min (mapcar 'car p12s)) p12s)))
 381           (goto-char (car p12))
 382           (compare-windows-highlight op1 (car p12) (current-buffer) w1
 383                                      op2 (cadr p12) b2 w2))
 384         (setq compare-windows-sync-point (or (cadr p12) t)))
 385     ;; else set point in the second window to the pre-calculated value
 386     (if (numberp compare-windows-sync-point)
 387         (goto-char compare-windows-sync-point))
 388     (setq compare-windows-sync-point nil)))
 389
 390 ;; Highlight differences
 391 (defun compare-windows-highlight (beg1 end1 b1 w1 beg2 end2 b2 w2)
 392   (when compare-windows-highlight
 393     (if compare-windows-overlay1
 394         (move-overlay compare-windows-overlay1 beg1 end1 b1)
 395       (setq compare-windows-overlay1 (make-overlay beg1 end1 b1))
 396       (overlay-put compare-windows-overlay1 'face 'compare-windows)
 397       (overlay-put compare-windows-overlay1 'priority 1000))
 398     (overlay-put compare-windows-overlay1 'window w1)
 399     (if compare-windows-overlay2
 400         (move-overlay compare-windows-overlay2 beg2 end2 b2)
 401       (setq compare-windows-overlay2 (make-overlay beg2 end2 b2))
 402       (overlay-put compare-windows-overlay2 'face 'compare-windows)
 403       (overlay-put compare-windows-overlay2 'priority 1000))
 404     (overlay-put compare-windows-overlay2 'window w2)
 405     (if (not (eq compare-windows-highlight 'persistent))
 406         ;; Remove highlighting before next command is executed
 407         (add-hook 'pre-command-hook 'compare-windows-dehighlight)
 408       (when compare-windows-overlay1
 409         (push (copy-overlay compare-windows-overlay1) compare-windows-overlays1)
 410         (delete-overlay compare-windows-overlay1))
 411       (when compare-windows-overlay2
 412         (push (copy-overlay compare-windows-overlay2) compare-windows-overlays2)
 413         (delete-overlay compare-windows-overlay2)))))
 414
 415 (defun compare-windows-dehighlight ()
 416   "Remove highlighting created by function `compare-windows-highlight'."
 417   (interactive)
 418   (remove-hook 'pre-command-hook 'compare-windows-dehighlight)
 419   (mapc 'delete-overlay compare-windows-overlays1)
 420   (mapc 'delete-overlay compare-windows-overlays2)
 421   (and compare-windows-overlay1 (delete-overlay compare-windows-overlay1))
 422   (and compare-windows-overlay2 (delete-overlay compare-windows-overlay2)))
 423
 424 (provide 'compare-w)
 425
 426 ;;; compare-w.el ends here