Mercurial > emacs
changeset 109406:f9f0aa88b6f8
Merge from mainline.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Mon, 14 Jun 2010 22:48:13 +0000 |
| parents | 6730a174eb2b (current diff) 8f3a9d4ebe87 (diff) |
| children | 51e15604baa1 |
| files | lisp/compare-w.el lisp/vc/compare-w.el |
| diffstat | 7 files changed, 540 insertions(+), 408 deletions(-) [+] |
line wrap: on
line diff
--- a/etc/NEWS Sun Jun 13 23:57:38 2010 +0000 +++ b/etc/NEWS Mon Jun 14 22:48:13 2010 +0000 @@ -125,6 +125,9 @@ *** Calling `delete-file' or `delete-directory' with a prefix argument now forces true deletion, regardless of `delete-by-moving-to-trash'. +** New option `list-colors-sort' defines the color sort order +for `list-colors-display'. + * Editing Changes in Emacs 24.1
--- a/lisp/ChangeLog Sun Jun 13 23:57:38 2010 +0000 +++ b/lisp/ChangeLog Mon Jun 14 22:48:13 2010 +0000 @@ -1,3 +1,24 @@ +2010-06-14 Juri Linkov <juri@jurta.org> + + Add sort option `list-colors-sort'. (Bug#6332) + * facemenu.el (color-rgb-to-hsv): New function. + (list-colors-sort): New defcustom. + (list-colors-sort-key): New function. + (list-colors-display): Doc fix. Sort list according to the option + `list-colors-sort'. + (list-colors-print): Add HSV values to `help-echo' property of + RGB strings. + +2010-06-14 Juri Linkov <juri@jurta.org> + + * compare-w.el: Move to the "vc" subdirectory. + +2010-06-14 Stefan Monnier <monnier@iro.umontreal.ca> + + * image-mode.el (image-mode-map): Remap left-char and right-char. + + * nxml/nxml-mode.el (nxml-indent-line): Standardize indent behavior. + 2010-06-12 Chong Yidong <cyd@stupidchicken.com> * term/common-win.el (x-colors): Add all the color names defined
--- a/lisp/compare-w.el Sun Jun 13 23:57:38 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -;;; compare-w.el --- compare text between windows for Emacs - -;; Copyright (C) 1986, 1989, 1993, 1997, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: convenience files - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package provides one entry point, compare-windows. It compares -;; text starting from point in two adjacent windows, advancing point -;; until it finds a difference. Option variables permit you to ignore -;; whitespace differences, or case differences, or both. - -;;; Code: - -(defgroup compare-windows nil - "Compare text between windows." - :prefix "compare-" - :group 'tools) - -(defcustom compare-windows-whitespace "\\(\\s-\\|\n\\)+" - "Regexp or function that defines whitespace sequences for `compare-windows'. -That command optionally ignores changes in whitespace. - -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. - -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-windows) - -(defcustom compare-ignore-whitespace nil - "Non-nil means `compare-windows' ignores whitespace." - :type 'boolean - :group 'compare-windows - :version "22.1") - -(defcustom compare-ignore-case nil - "Non-nil means `compare-windows' ignores case differences." - :type 'boolean - :group 'compare-windows) - -(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' (option \"No sync\"), then -no synchronization is performed, and the function `ding' is called -to beep or flash the screen when points are mismatched." - :type '(choice function regexp (const :tag "No sync" nil)) - :group 'compare-windows - :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-windows - :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-windows - :version "22.1") - -(defcustom compare-windows-highlight t - "Non-nil means compare-windows highlights the differences. -The value t removes highlighting immediately after invoking a command -other than `compare-windows'. -The value `persistent' leaves all highlighted differences. You can clear -out all highlighting later with the command `compare-windows-dehighlight'." - :type '(choice (const :tag "No highlighting" nil) - (const :tag "Persistent highlighting" persistent) - (other :tag "Highlight until next command" t)) - :group 'compare-windows - :version "22.1") - -(defface compare-windows - '((t :inherit lazy-highlight)) - "Face for highlighting of compare-windows difference regions." - :group 'compare-windows - :version "22.1") - -(defvar compare-windows-overlay1 nil) -(defvar compare-windows-overlay2 nil) -(defvar compare-windows-overlays1 nil) -(defvar compare-windows-overlays2 nil) -(defvar compare-windows-sync-point nil) - -;;;###autoload -(defun compare-windows (ignore-whitespace) - "Compare text in current window with text in next window. -Compares the text starting at point in each window, -moving over text in each one as far as they match. - -This command pushes the mark in each window -at the prior location of point in that window. -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 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") - (if compare-ignore-whitespace - (setq ignore-whitespace (not ignore-whitespace))) - (let* (p1 p2 maxp1 maxp2 b1 b2 w2 - (progress 1) - (opoint1 (point)) - opoint2 - skip-func-1 - skip-func-2 - (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) - b2 (window-buffer w2)) - (setq opoint2 p2) - (setq maxp1 (point-max)) - - (setq skip-func-1 (if ignore-whitespace - (if (stringp compare-windows-whitespace) - (lambda (pos) - (compare-windows-skip-whitespace pos) - t) - compare-windows-whitespace))) - - (with-current-buffer b2 - (setq skip-func-2 (if ignore-whitespace - (if (stringp compare-windows-whitespace) - (lambda (pos) - (compare-windows-skip-whitespace pos) - t) - compare-windows-whitespace))) - (push-mark p2 t) - (setq maxp2 (point-max))) - (push-mark) - - (while (> progress 0) - ;; If both windows have whitespace next to point, - ;; optionally skip over it. - (and skip-func-1 - (save-excursion - (let (p1a p2a w1 w2 result1 result2) - (setq result1 (funcall skip-func-1 opoint1)) - (setq p1a (point)) - (set-buffer b2) - (goto-char p2) - (setq result2 (funcall skip-func-2 opoint2)) - (setq p2a (point)) - (if (and result1 result2 (eq result1 result2)) - (setq p1 p1a - p2 p2a))))) - - (let ((size (min (- maxp1 p1) (- maxp2 p2))) - (case-fold-search compare-ignore-case)) - (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) - (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. -;; Match it at various starting points before the original point -;; 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) - (let ((end (point)) - (beg (point)) - (opoint (point))) - (while (or (and (looking-at compare-windows-whitespace) - (<= end (match-end 0)) - ;; This match goes past END, so advance END. - (progn (setq end (match-end 0)) - (> (point) start))) - (and (/= (point) start) - ;; Consider at least the char before point, - ;; unless it is also before START. - (= (point) opoint))) - ;; keep going back until whitespace - ;; doesn't extend to or past end - (forward-char -1)) - (setq beg (point)) - (goto-char end) - (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 1000)) - (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 1000)) - (overlay-put compare-windows-overlay2 'window w2) - (if (not (eq compare-windows-highlight 'persistent)) - ;; Remove highlighting before next command is executed - (add-hook 'pre-command-hook 'compare-windows-dehighlight) - (when compare-windows-overlay1 - (push (copy-overlay compare-windows-overlay1) compare-windows-overlays1) - (delete-overlay compare-windows-overlay1)) - (when compare-windows-overlay2 - (push (copy-overlay compare-windows-overlay2) compare-windows-overlays2) - (delete-overlay compare-windows-overlay2))))) - -(defun compare-windows-dehighlight () - "Remove highlighting created by `compare-windows-highlight'." - (interactive) - (remove-hook 'pre-command-hook 'compare-windows-dehighlight) - (mapc 'delete-overlay compare-windows-overlays1) - (mapc 'delete-overlay compare-windows-overlays2) - (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
--- a/lisp/facemenu.el Sun Jun 13 23:57:38 2010 +0000 +++ b/lisp/facemenu.el Mon Jun 14 22:48:13 2010 +0000 @@ -479,6 +479,73 @@ nil col))) +(defun color-rgb-to-hsv (r g b) + "For R, G, B color components return a list of hue, saturation, value. +R, G, B input values should be in [0..65535] range. +Output values for hue are integers in [0..360] range. +Output values for saturation and value are integers in [0..100] range." + (let* ((r (/ r 65535.0)) + (g (/ g 65535.0)) + (b (/ b 65535.0)) + (max (max r g b)) + (min (min r g b)) + (h (cond ((= max min) 0) + ((= max r) (mod (+ (* 60 (/ (- g b) (- max min))) 360) 360)) + ((= max g) (+ (* 60 (/ (- b r) (- max min))) 120)) + ((= max b) (+ (* 60 (/ (- r g) (- max min))) 240)))) + (s (cond ((= max 0) 0) + (t (- 1 (/ min max))))) + (v max)) + (list (round h) (round s 0.01) (round v 0.01)))) + +(defcustom list-colors-sort nil + "Color sort order for `list-colors-display'. +`nil' means default implementation-dependent order (defined in `x-colors'). +`name' sorts by color name. +`rgb' sorts by red, green, blue components. +`rgb-dist' sorts by the RGB distance to the specified color. +`hsv' sorts by hue, saturation, value. +`hsv-dist' sorts by the HVS distance to the specified color +and excludes grayscale colors." + :type '(choice (const :tag "Unsorted" nil) + (const :tag "Color Name" name) + (const :tag "Red-Green-Blue" rgb) + (cons :tag "Distance on RGB cube" + (const :tag "Distance from Color" rgb-dist) + (color :tag "Source Color Name")) + (const :tag "Hue-Saturation-Value" hsv) + (cons :tag "Distance on HSV cylinder" + (const :tag "Distance from Color" hsv-dist) + (color :tag "Source Color Name"))) + :group 'facemenu + :version "24.1") + +(defun list-colors-sort-key (color) + "Return a list of keys for sorting colors depending on `list-colors-sort'. +COLOR is the name of the color. When return value is nil, +filter out the color from the output." + (cond + ((null list-colors-sort) color) + ((eq list-colors-sort 'name) + (downcase color)) + ((eq list-colors-sort 'rgb) + (color-values color)) + ((eq (car-safe list-colors-sort) 'rgb-dist) + (color-distance color (cdr list-colors-sort))) + ((eq list-colors-sort 'hsv) + (apply 'color-rgb-to-hsv (color-values color))) + ((eq (car-safe list-colors-sort) 'hsv-dist) + (let* ((c-rgb (color-values color)) + (c-hsv (apply 'color-rgb-to-hsv c-rgb)) + (o-hsv (apply 'color-rgb-to-hsv + (color-values (cdr list-colors-sort))))) + (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale + (eq (nth 1 c-rgb) (nth 2 c-rgb))) + ;; 3D Euclidean distance (sqrt is not needed for sorting) + (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue + (nth 0 o-hsv)))))) 2) + (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2) + (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))))) (defun list-colors-display (&optional list buffer-name callback) "Display names of defined colors, and show what they look like. @@ -492,10 +559,38 @@ If the optional argument CALLBACK is non-nil, it should be a function to call each time the user types RET or clicks on a color. The function should accept a single argument, the color -name." +name. + +You can change the color sort order by customizing `list-colors-sort'." (interactive) (when (and (null list) (> (display-color-cells) 0)) (setq list (list-colors-duplicates (defined-colors))) + (when list-colors-sort + ;; Schwartzian transform with `(color key1 key2 key3 ...)'. + (setq list (mapcar + 'car + (sort (delq nil (mapcar + (lambda (c) + (let ((key (list-colors-sort-key + (car c)))) + (when key + (cons c (if (consp key) key + (list key)))))) + list)) + (lambda (a b) + (let* ((a-keys (cdr a)) + (b-keys (cdr b)) + (a-key (car a-keys)) + (b-key (car b-keys))) + ;; Skip common keys at the beginning of key lists. + (while (and a-key b-key (equal a-key b-key)) + (setq a-keys (cdr a-keys) a-key (car a-keys) + b-keys (cdr b-keys) b-key (car b-keys))) + (cond + ((and (numberp a-key) (numberp b-key)) + (< a-key b-key)) + ((and (stringp a-key) (stringp b-key)) + (string< a-key b-key))))))))) (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color)) ;; Don't show more than what the display can handle. (let ((lc (nthcdr (1- (display-color-cells)) list))) @@ -550,9 +645,16 @@ (point) 'face (list :foreground (car color))) (indent-to (max (- (window-width) 8) 44)) - (insert (apply 'format "#%02x%02x%02x" - (mapcar (lambda (c) (lsh c -8)) - color-values))) + (insert (propertize + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (c) (lsh c -8)) + color-values)) + 'mouse-face 'highlight + 'help-echo + (let ((hsv (apply 'color-rgb-to-hsv + (color-values (car color))))) + (format "H:%d S:%d V:%d" + (nth 0 hsv) (nth 1 hsv) (nth 2 hsv))))) (when callback (make-text-button opoint (point)
--- a/lisp/image-mode.el Sun Jun 13 23:57:38 2010 +0000 +++ b/lisp/image-mode.el Mon Jun 14 22:48:13 2010 +0000 @@ -298,6 +298,8 @@ (define-key map (kbd "DEL") 'image-scroll-down) (define-key map [remap forward-char] 'image-forward-hscroll) (define-key map [remap backward-char] 'image-backward-hscroll) + (define-key map [remap right-char] 'image-forward-hscroll) + (define-key map [remap left-char] 'image-backward-hscroll) (define-key map [remap previous-line] 'image-previous-line) (define-key map [remap next-line] 'image-next-line) (define-key map [remap scroll-up] 'image-scroll-up)
--- a/lisp/nxml/nxml-mode.el Sun Jun 13 23:57:38 2010 +0000 +++ b/lisp/nxml/nxml-mode.el Mon Jun 14 22:48:13 2010 +0000 @@ -1370,17 +1370,21 @@ (defun nxml-indent-line () "Indent current line as XML." - (let ((indent (nxml-compute-indent)) - (from-end (- (point-max) (point)))) - (when (and indent - (/= indent (current-indentation))) - (beginning-of-line) - (let ((bol (point))) - (skip-chars-forward " \t") - (delete-region bol (point))) - (indent-to indent) - (when (> (- (point-max) from-end) (point)) - (goto-char (- (point-max) from-end)))))) + (let* ((savep (point)) + (indent (condition-case nil + (save-excursion + (forward-line 0) + (skip-chars-forward " \t") + (if (>= (point) savep) (setq savep nil)) + (or (nxml-compute-indent) 0)) + (error 0)))) + (if (not (numberp indent)) + ;; If something funny is used (e.g. `noindent'), return it. + indent + (if (< indent 0) (setq indent 0)) ;Just in case. + (if savep + (save-excursion (indent-line-to indent)) + (indent-line-to indent))))) (defun nxml-compute-indent () "Return the indent for the line containing point."
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/compare-w.el Mon Jun 14 22:48:13 2010 +0000 @@ -0,0 +1,393 @@ +;;; compare-w.el --- compare text between windows for Emacs + +;; Copyright (C) 1986, 1989, 1993, 1997, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: convenience files vc + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides one entry point, compare-windows. It compares +;; text starting from point in two adjacent windows, advancing point +;; until it finds a difference. Option variables permit you to ignore +;; whitespace differences, or case differences, or both. + +;;; Code: + +(defgroup compare-windows nil + "Compare text between windows." + :prefix "compare-" + :group 'tools) + +(defcustom compare-windows-whitespace "\\(\\s-\\|\n\\)+" + "Regexp or function that defines whitespace sequences for `compare-windows'. +That command optionally ignores changes in whitespace. + +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. + +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-windows) + +(defcustom compare-ignore-whitespace nil + "Non-nil means `compare-windows' ignores whitespace." + :type 'boolean + :group 'compare-windows + :version "22.1") + +(defcustom compare-ignore-case nil + "Non-nil means `compare-windows' ignores case differences." + :type 'boolean + :group 'compare-windows) + +(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' (option \"No sync\"), then +no synchronization is performed, and the function `ding' is called +to beep or flash the screen when points are mismatched." + :type '(choice function regexp (const :tag "No sync" nil)) + :group 'compare-windows + :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-windows + :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-windows + :version "22.1") + +(defcustom compare-windows-highlight t + "Non-nil means compare-windows highlights the differences. +The value t removes highlighting immediately after invoking a command +other than `compare-windows'. +The value `persistent' leaves all highlighted differences. You can clear +out all highlighting later with the command `compare-windows-dehighlight'." + :type '(choice (const :tag "No highlighting" nil) + (const :tag "Persistent highlighting" persistent) + (other :tag "Highlight until next command" t)) + :group 'compare-windows + :version "22.1") + +(defface compare-windows + '((t :inherit lazy-highlight)) + "Face for highlighting of compare-windows difference regions." + :group 'compare-windows + :version "22.1") + +(defvar compare-windows-overlay1 nil) +(defvar compare-windows-overlay2 nil) +(defvar compare-windows-overlays1 nil) +(defvar compare-windows-overlays2 nil) +(defvar compare-windows-sync-point nil) + +;;;###autoload +(defun compare-windows (ignore-whitespace) + "Compare text in current window with text in next window. +Compares the text starting at point in each window, +moving over text in each one as far as they match. + +This command pushes the mark in each window +at the prior location of point in that window. +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 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") + (if compare-ignore-whitespace + (setq ignore-whitespace (not ignore-whitespace))) + (let* (p1 p2 maxp1 maxp2 b1 b2 w2 + (progress 1) + (opoint1 (point)) + opoint2 + skip-func-1 + skip-func-2 + (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) + b2 (window-buffer w2)) + (setq opoint2 p2) + (setq maxp1 (point-max)) + + (setq skip-func-1 (if ignore-whitespace + (if (stringp compare-windows-whitespace) + (lambda (pos) + (compare-windows-skip-whitespace pos) + t) + compare-windows-whitespace))) + + (with-current-buffer b2 + (setq skip-func-2 (if ignore-whitespace + (if (stringp compare-windows-whitespace) + (lambda (pos) + (compare-windows-skip-whitespace pos) + t) + compare-windows-whitespace))) + (push-mark p2 t) + (setq maxp2 (point-max))) + (push-mark) + + (while (> progress 0) + ;; If both windows have whitespace next to point, + ;; optionally skip over it. + (and skip-func-1 + (save-excursion + (let (p1a p2a w1 w2 result1 result2) + (setq result1 (funcall skip-func-1 opoint1)) + (setq p1a (point)) + (set-buffer b2) + (goto-char p2) + (setq result2 (funcall skip-func-2 opoint2)) + (setq p2a (point)) + (if (and result1 result2 (eq result1 result2)) + (setq p1 p1a + p2 p2a))))) + + (let ((size (min (- maxp1 p1) (- maxp2 p2))) + (case-fold-search compare-ignore-case)) + (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) + (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. +;; Match it at various starting points before the original point +;; 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) + (let ((end (point)) + (beg (point)) + (opoint (point))) + (while (or (and (looking-at compare-windows-whitespace) + (<= end (match-end 0)) + ;; This match goes past END, so advance END. + (progn (setq end (match-end 0)) + (> (point) start))) + (and (/= (point) start) + ;; Consider at least the char before point, + ;; unless it is also before START. + (= (point) opoint))) + ;; keep going back until whitespace + ;; doesn't extend to or past end + (forward-char -1)) + (setq beg (point)) + (goto-char end) + (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 1000)) + (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 1000)) + (overlay-put compare-windows-overlay2 'window w2) + (if (not (eq compare-windows-highlight 'persistent)) + ;; Remove highlighting before next command is executed + (add-hook 'pre-command-hook 'compare-windows-dehighlight) + (when compare-windows-overlay1 + (push (copy-overlay compare-windows-overlay1) compare-windows-overlays1) + (delete-overlay compare-windows-overlay1)) + (when compare-windows-overlay2 + (push (copy-overlay compare-windows-overlay2) compare-windows-overlays2) + (delete-overlay compare-windows-overlay2))))) + +(defun compare-windows-dehighlight () + "Remove highlighting created by `compare-windows-highlight'." + (interactive) + (remove-hook 'pre-command-hook 'compare-windows-dehighlight) + (mapc 'delete-overlay compare-windows-overlays1) + (mapc 'delete-overlay compare-windows-overlays2) + (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