home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / packages / compare-w.el < prev    next >
Encoding:
Text File  |  1995-05-12  |  6.4 KB  |  160 lines
  1. ;;; compare-w.el --- compare text between windows for Emacs.
  2.  
  3. ;; Copyright (C) 1986, 1989, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6.  
  7. ;; This file is part of XEmacs.
  8.  
  9. ;; XEmacs is free software; you can redistribute it and/or modify it
  10. ;; under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; XEmacs is distributed in the hope that it will be useful, but
  15. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. ;; General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  21. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23. ;;; Synched up with: FSF 19.28.
  24. ;;; This file has been somewhat rewritten in XEmacs.  It's not clear
  25. ;;; whether the changes between 19.22 and 19.28 can replace some of
  26. ;;; the rewriting.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;; This package provides one entry point, compare-windows.  It compares
  31. ;; text starting from point in two adjacent windows, advancing point
  32. ;; until it finds a difference.  Option variables permit you to ignore
  33. ;; whitespace differences, or case differences, or both.
  34.  
  35. ;;; Code:
  36.  
  37. (provide 'compare-w)
  38.  
  39. (defvar compare-windows-whitespace "[ \t\n]+"
  40.   "*Regexp that defines whitespace sequences for \\[compare-windows].
  41. Changes in whitespace are optionally ignored.
  42.  
  43. The value of `compare-windows-whitespace' may instead be a function; this
  44. function is called in each buffer, with point at the current scanning point.
  45. The function's job is to categorize any whitespace around (including before)
  46. point; it should also advance past any whitespace.
  47.  
  48. The function is passed one argument, the point where compare-windows
  49. was originally called; it should not consider any text before that point.
  50. If the function returns the same value for both buffers, then the
  51. whitespace is considered to match, and is skipped.")
  52.  
  53. (defvar compare-ignore-case nil
  54.   "*If the value of this variable evaluates to non-nil, \\[compare-windows]
  55. ignores case differences.  Some useful settings: nil, t or 'case-fold-search,
  56. meaning to track the value of the `case-fold-search' variable.")
  57.  
  58. ;;;###autoload
  59. (defun compare-windows (&optional ignore-whitespace)
  60.   "Compare text in current window with text in next window.
  61. Compares the text starting at point in each window,
  62. moving over text in each one as far as they match.
  63.  
  64. A prefix arg means ignore changes in whitespace.
  65. The variable `compare-windows-whitespace' controls how whitespace is skipped.
  66.  
  67. If `compare-ignore-case' is non-nil, changes in case are also ignored."
  68.   (interactive "P")
  69.   (let* ((p1 (point))
  70.          (opoint1 p1)
  71.          (b1 (current-buffer))
  72.          (w2 (let* ((w (selected-window))
  73.                     (n (next-window w)))
  74.                (if (eq n w) 
  75.                    (error "No other window")
  76.                    n)))
  77.          (p2 (window-point w2))
  78.          (b2 (window-buffer w2))
  79.          (opoint2 p2)
  80.          (success t)
  81.          (compare-ignore-case 
  82.           ;;#### ARGGGH
  83.           (eval compare-ignore-case))
  84.          (skip-whitespace (cond ((not ignore-whitespace)
  85.                                  nil)
  86.                                 ((stringp compare-windows-whitespace)
  87.                                  (function (lambda (start)
  88.                                    (let ((p (point))
  89.                                          (found nil))
  90.                                      (while (and (looking-at
  91.                                                   compare-windows-whitespace)
  92.                                                  ;; whitespace still covers p
  93.                                                  (<= p (match-end 0))
  94.                                                  (progn (setq p (match-end 0)
  95.                                                               found t)
  96.                                                         (> (point) start)))
  97.                                        ;; keep going back until whitespace
  98.                                        ;; doesn't extend to or past p
  99.                                        (backward-char 1))
  100.                                      (if found (goto-char p))
  101.                                      found))))
  102.                                 (t
  103.                                  compare-windows-whitespace))))
  104.     (while success
  105.       (setq success nil)
  106.       ;; if interrupted, show how far we've gotten
  107.       (goto-char p1)
  108.       (set-window-point w2 p2)
  109.  
  110.       ;; If both buffers have whitespace next to point,
  111.       ;; optionally skip over it.
  112.  
  113.       (if skip-whitespace
  114.           (save-excursion
  115.             (let* ((result1 (cond ((funcall skip-whitespace opoint1))
  116.                                   ((= p1 opoint1) nil)
  117.                                   (t
  118.                                    (goto-char (1- p1))
  119.                                    (funcall skip-whitespace opoint1))))
  120.                    (p1a (point))
  121.                    (result2 (cond ((progn (set-buffer b2) 
  122.                                           (goto-char p2)
  123.                                           (funcall skip-whitespace opoint2)))
  124.                                   ((= p2 opoint2) nil)
  125.                                   (t
  126.                                    (goto-char (1- p2))
  127.                                    (funcall skip-whitespace opoint2))))
  128.                    (p2a (point)))
  129.               (if (and (eq result1 result2) result1)
  130.                   (setq p1 p1a
  131.                         p2 p2a)))))
  132.       
  133.       (let ((case-fold-search compare-ignore-case))
  134.         (setq success (compare-buffer-substrings b1 p1 nil
  135.                                                  b2 p2 nil))
  136.         (if (< success 0) (setq success (- success)))
  137.         (cond ((= success 0)
  138.                ;; whole buffer matched
  139.                (set-buffer b1)
  140.                (setq p1 (point-max)
  141.                      p2 (save-excursion 
  142.                           (set-buffer b2)
  143.                           (point-max))
  144.                      ;; Can't be any more successful
  145.                      success nil))
  146.               ((= success 1)
  147.                ;; nothing matched
  148.                (setq success nil))
  149.               (t
  150.                (setq p1 (+ p1 success -1))
  151.                (setq p2 (+ p2 success -1))))))
  152.  
  153.     (goto-char p1)
  154.     (set-window-point w2 p2)
  155.     ;; Beep if nothing matched
  156.     (if (= (point) opoint1)
  157.     (beep))))
  158.  
  159. ;;; compare-w.el ends here
  160.