This is a sync of occur-mode with GNU Emacs 22.0.50.1 (CVS). Note that these are 21.5 core lisp files. New features include syntax hightlighting of the matched regular expression, the ability to rename the occur buffer, the ability to search multiple buffers and minor mode that allows movement between the matching lines while remaining in the occur buffer. Since the occur code has started using font-lock features it has been moved out of replace.el into its own files because the necessary functions are not available to replace.el during the dumping stage. This patch also changes the behaviour of read-buffer slightly to conform with GNU Emacs usage: It can return an empty string if 'require-match' is t and 'default' is nil. Previously it would insist that a buffer be entered. A search through the package code has shown that this is the only place that relies of this combination of argument values. Malcolm lisp/ChangeLog addition: 2005-10-10 Malcolm Purvis <malcolmp(a)xemacs.org&gt; * minibuf.el: * minibuf.el (read-buffer): Follow GNU Emacs behaviour: Can return empty string if require-match is t and default is nil. * replace.el: Moved occur code to occur.el * simple.el: * simple.el (line-number-at-pos): New. * subr.el: * subr.el (delete-dups): New. * occur.el: New. Sync with 22.0.50.1 (CVS) * next-error.el: New. Sync with 22.0.50.1 (CVS) xemacs-occur source patch: Diff command: cvs -q diff -u Files affected: lisp/subr.el lisp/simple.el lisp/replace.el lisp/minibuf.el Index: lisp/minibuf.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/minibuf.el,v retrieving revision 1.29 diff -u -r1.29 minibuf.el --- lisp/minibuf.el 2005/04/14 05:58:46 1.29 +++ lisp/minibuf.el 2005/10/09 20:52:48 ＠＠ -23,8 +23,8 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: all the minibuffer history stuff is synched with ;;; 19.30. Not sure about the rest. ＠＠ -1495,7 +1495,7 ＠＠ (setq result default) nil) ((not default) - t) + nil) ((not (get-buffer default)) t) (t Index: lisp/replace.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/replace.el,v retrieving revision 1.11 diff -u -r1.11 replace.el --- lisp/replace.el 2005/02/23 22:09:15 1.11 +++ lisp/replace.el 2005/10/09 20:52:50 ＠＠ -19,8 +19,8 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. +;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 19.34 [Partially]. ＠＠ -455,271 +455,7 ＠＠ (message "%d occurrences" count)))))  -(defvar occur-mode-map ()) -(if occur-mode-map - () - (setq occur-mode-map (make-sparse-keymap)) - (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs - (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) ; XEmacs - (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) - (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence)) - -(defvar occur-buffer nil) -(defvar occur-nlines nil) -(defvar occur-pos-list nil) - -(defun occur-mode () - "Major mode for output from \\[occur]. -\\<occur-mode-map>Move point to one of the items in this buffer, then use -\\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to. -Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. - -\\{occur-mode-map}" - (kill-all-local-variables) - (use-local-map occur-mode-map) - (setq major-mode 'occur-mode) - (setq mode-name (gettext "Occur")) ; XEmacs - (make-local-variable 'occur-buffer) - (make-local-variable 'occur-nlines) - (make-local-variable 'occur-pos-list) - (require 'mode-motion) ; XEmacs - (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs - (run-hooks 'occur-mode-hook)) - -;; FSF Version of next function: -; (let (buffer pos) -; (save-excursion -; (set-buffer (window-buffer (posn-window (event-end event)))) -; (save-excursion -; (goto-char (posn-point (event-end event))) -; (setq pos (occur-mode-find-occurrence)) -; (setq buffer occur-buffer))) -; (pop-to-buffer buffer) -; (goto-char (marker-position pos)))) - -(defun occur-mode-mouse-goto (event) - "Go to the occurrence highlighted by mouse. -This function should be bound to a mouse key in the `*Occur*' buffer." - (interactive "e") - (let ((window-save (selected-window)) - (frame-save (selected-frame))) - ;; preserve the window/frame setup - (unwind-protect - (progn - (mouse-set-point event) - (occur-mode-goto-occurrence)) - (select-frame frame-save) - (select-window window-save)))) - -;; Called occur-mode-find-occurrence in FSF -(defun occur-mode-goto-occurrence () - "Go to the occurrence the current line describes." - (interactive) - (if (or (null occur-buffer) - (null (buffer-name occur-buffer))) - (progn - (setq occur-buffer nil - occur-pos-list nil) - (error "Buffer in which occurrences were found is deleted"))) - (let* ((line-count - (count-lines (point-min) - (save-excursion - (beginning-of-line) - (point)))) - (occur-number (save-excursion - (beginning-of-line) - (/ (1- line-count) - (cond ((< occur-nlines 0) - (- 2 occur-nlines)) - ((> occur-nlines 0) - (+ 2 (* 2 occur-nlines))) - (t 1))))) - (pos (nth occur-number occur-pos-list)) - ;; removed t arg from Bob Weiner, 10/6/95 - (window (get-buffer-window occur-buffer)) - (occur-source-buffer occur-buffer)) - (if (< line-count 1) - (error "No occurrence on this line")) - (or pos - (error "No occurrence on this line")) - ;; XEmacs: don't raise window unless it isn't visible - ;; allow for the possibility that the occur buffer is on another frame - (or (and window - (window-live-p window) - (frame-visible-p (window-frame window)) - (set-buffer occur-source-buffer)) - (and (pop-to-buffer occur-source-buffer) - (setq window (get-buffer-window occur-source-buffer)))) - (goto-char pos) - (set-window-point window pos))) - - -(defvar list-matching-lines-default-context-lines 0 - "*Default number of context lines to include around a `list-matching-lines' -match. A negative number means to include that many lines before the match. -A positive number means to include that many lines both before and after.") - -;; XEmacs addition -;;; Damn you Jamie, this is utter trash. -(defvar list-matching-lines-whole-buffer t - "If t, occur operates on whole buffer, otherwise occur starts from point. -default is t.") - -(define-function 'occur 'list-matching-lines) -(defun list-matching-lines (regexp &optional nlines) - "Show all lines in the current buffer containing a match for REGEXP. - -If a match spreads across multiple lines, all those lines are shown. - -If variable `list-matching-lines-whole-buffer' is non-nil, the entire -buffer is searched, otherwise search begins at point. - -Each line is displayed with NLINES lines before and after, or -NLINES -before if NLINES is negative. -NLINES defaults to `list-matching-lines-default-context-lines'. -Interactively it is the prefix arg. - -The lines are shown in a buffer named `*Occur*'. -It serves as a menu to find any of the occurrences in this buffer. -\\[describe-mode] in that buffer will explain how." - (interactive - ;; XEmacs change - (list (let* ((default (or (symbol-near-point) - (and regexp-history - (car regexp-history)))) - (minibuffer-history-minimum-string-length 0) - (input - (if default - ;; rewritten for I18N3 snarfing - (read-from-minibuffer - (format "List lines matching regexp (default `%s'): " - default) nil nil nil 'regexp-history nil - default) - (read-from-minibuffer - "List lines matching regexp: " - nil nil nil - 'regexp-history)))) - (if (and (equal input "") default) - (progn - (setq input default) - (setcar regexp-history default))) - ;; clear extra entries - (setcdr regexp-history (delete (car regexp-history) - (cdr regexp-history))) - input) - current-prefix-arg)) - (if (equal regexp "") - (error "Must pass non-empty regexp to `list-matching-lines'")) - (setq nlines (if nlines (prefix-numeric-value nlines) - list-matching-lines-default-context-lines)) - (let ((first t) - (dir default-directory) - (buffer (current-buffer)) - (linenum 1) - (prevpos (point-min)) - ;; The rest of this function is very different from FSF. - ;; Presumably that's due to Jamie's misfeature - (final-context-start (make-marker))) - (if (not list-matching-lines-whole-buffer) - (save-excursion - (beginning-of-line) - (setq linenum (1+ (count-lines (point-min) (point)))) - (setq prevpos (point)))) - (with-output-to-temp-buffer "*Occur*" - (save-excursion - (set-buffer standard-output) - (setq default-directory dir) - ;; We will insert the number of lines, and "lines", later. - ;; #### Needs fixing for I18N3 - (let ((print-escape-newlines t)) - (insert (format " matching %s in buffer %s.\n" - regexp (buffer-name buffer)))) - (occur-mode) - (setq occur-buffer buffer) - (setq occur-nlines nlines) - (setq occur-pos-list ())) - (if (eq buffer standard-output) - (goto-char (point-max))) - (with-interactive-search-caps-disable-folding regexp t - (save-excursion - (if list-matching-lines-whole-buffer - (beginning-of-buffer)) - (message "Searching for %s ..." regexp) - ;; Find next match, but give up if prev match was at end of buffer. - (while (and (not (= prevpos (point-max))) - (re-search-forward regexp nil t)) - (goto-char (match-beginning 0)) - (beginning-of-line) - (save-match-data - (setq linenum (+ linenum (count-lines prevpos (point))))) - (setq prevpos (point)) - (goto-char (match-end 0)) - (let* ((start (save-excursion - (goto-char (match-beginning 0)) - (forward-line (if (< nlines 0) nlines (- nlines))) - (point))) - (end (save-excursion - (goto-char (match-end 0)) - (if (> nlines 0) - (forward-line (1+ nlines)) - (forward-line 1)) - (point))) - (tag (format "%5d" linenum)) - (empty (make-string (length tag) ?\ )) - tem) - (save-excursion - (setq tem (make-marker)) - (set-marker tem (point)) - (set-buffer standard-output) - (setq occur-pos-list (cons tem occur-pos-list)) - (or first (zerop nlines) - (insert "--------\n")) - (setq first nil) - (insert-buffer-substring buffer start end) - (set-marker final-context-start - (- (point) (- end (match-end 0)))) - (backward-char (- end start)) - (setq tem (if (< nlines 0) (- nlines) nlines)) - (while (> tem 0) - (insert empty ?:) - (forward-line 1) - (setq tem (1- tem))) - (let ((this-linenum linenum)) - (while (< (point) final-context-start) - (if (null tag) - (setq tag (format "%5d" this-linenum))) - (insert tag ?:) - ;; FSFmacs -- - ;; we handle this using mode-motion-highlight-line, above. - ;; (put-text-property (save-excursion - ;; (beginning-of-line) - ;; (point)) - ;; (save-excursion - ;; (end-of-line) - ;; (point)) - ;; 'mouse-face 'highlight) - (forward-line 1) - (setq tag nil) - (setq this-linenum (1+ this-linenum))) - (while (<= (point) final-context-start) - (insert empty ?:) - (forward-line 1) - (setq this-linenum (1+ this-linenum)))) - (while (< tem nlines) - (insert empty ?:) - (forward-line 1) - (setq tem (1+ tem))) - (goto-char (point-max))) - (forward-line 1))) - (set-buffer standard-output) - ;; Put positions in increasing order to go with buffer. - (setq occur-pos-list (nreverse occur-pos-list)) - (goto-char (point-min)) - (if (= (length occur-pos-list) 1) - (insert "1 line") - (insert (format "%d lines" (length occur-pos-list)))) - (if (interactive-p) - (message "%d matching lines." (length occur-pos-list)))))))) +;;; occur code moved to occur.el  ;; It would be nice to use \\[...], but there is no reasonable way ;; to make that display both SPC and Y. Index: lisp/simple.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/simple.el,v retrieving revision 1.52 diff -u -r1.52 simple.el --- lisp/simple.el 2005/10/05 04:32:45 1.52 +++ lisp/simple.el 2005/10/09 20:53:02 ＠＠ -21,12 +21,12 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. +;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 19.34 [But not very closely]. -;;; Occasional synching to FSF 21.2, as marked. Comment stuff also -;;; synched, and in newcomment.el. +;;; Occasional synching to FSF 21.2 and FSF 22.0, as marked. Comment stuff +;;; also synched, and in newcomment.el. ;;; Commentary: ＠＠ -745,6 +745,10 ＠＠ (goto-char pos) (line-number nil respect-narrowing)) (1+ (count-lines (if respect-narrowing (point-min) 1) (point-at-bol))))) + +;; FSF 22.0.50.1 (CVS) version of above. +(defun line-number-at-pos (&optional pos) + (line-number pos t)) (defun count-lines (start end &optional ignore-invisible-lines-flag) "Return number of lines between START and END. Index: lisp/subr.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/subr.el,v retrieving revision 1.36 diff -u -r1.36 subr.el --- lisp/subr.el 2005/01/28 02:05:05 1.36 +++ lisp/subr.el 2005/10/09 20:53:06 ＠＠ -23,8 +23,8 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. +;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 19.34. Some things synched up with later versions. ＠＠ -1619,6 +1619,20 ＠＠ (make-compatible 'eval-next-after-load "") ;; END SYNC WITH FSF 21.2 + +;; BEGIN SYNC WITH FSF 22.0.50.1 (CVS) +(defun delete-dups (list) + "Destructively remove `equal' duplicates from LIST. +Store the result in LIST and return it. LIST must be a proper list. +Of several `equal' occurrences of an element in LIST, the first +one is kept." + (let ((tail list)) + (while tail + (setcdr tail (delete (car tail) (cdr tail))) + (setq tail (cdr tail)))) + list) + +;; END SYNC WITH FSF 22.0.50.1 (CVS) ;; (defun shell-quote-argument (argument) in process.el. --------------------------------------------------------------------------- ;;; occur.el --- Show all lines in the current buffer containing a match for REGEXP. ;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1996, 1997, 2000, 2001, ;; 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Maintainer: XEmacs Development Team ;; Keywords: internal ;; This file is part of XEmacs. ;; XEmacs 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 2, or (at your option) ;; any later version. ;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 22.0.50.1 (CVS) (require 'next-error) (defun query-replace-descr (string) (mapconcat 'isearch-text-char-description string "")) (defvar occur-mode-map () "Keymap for `occur-mode'.") (if occur-mode-map () (setq occur-mode-map (make-sparse-keymap)) (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) ; XEmacs (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence) (define-key occur-mode-map "o" 'occur-mode-goto-occurrence-other-window) (define-key occur-mode-map "\C-o" 'occur-mode-display-occurrence) (define-key occur-mode-map "\M-n" 'occur-next) (define-key occur-mode-map "\M-p" 'occur-prev) (define-key occur-mode-map "r" 'occur-rename-buffer) (define-key occur-mode-map "c" 'clone-buffer) (define-key occur-mode-map "g" 'revert-buffer) (define-key occur-mode-map "q" 'quit-window) (define-key occur-mode-map "z" 'kill-this-buffer) (define-key occur-mode-map "\C-c\C-f" 'next-error-follow-minor-mode)) (defvar occur-revert-arguments nil "Arguments to pass to `occur-1' to revert an Occur mode buffer. See `occur-revert-function'.") (defcustom occur-mode-hook nil ; XEmacs "Hook run when entering Occur mode." :type 'hook :group 'matching) (defcustom occur-hook nil "Hook run by Occur when there are any matches." :type 'hook :group 'matching) (put 'occur-mode 'mode-class 'special) ;;;###autoload (defun occur-mode () "Major mode for output from \\[occur]. \\<occur-mode-map>Move point to one of the items in this buffer, then use \\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to. Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. \\{occur-mode-map}" (interactive) (kill-all-local-variables) (use-local-map occur-mode-map) (setq major-mode 'occur-mode) (setq mode-name (gettext "Occur")) ; XEmacs (set (make-local-variable 'revert-buffer-function) 'occur-revert-function) (make-local-variable 'occur-revert-arguments) (add-hook 'change-major-mode-hook 'turn-off-font-lock t t) (setq next-error-function 'occur-next-error) (require 'mode-motion) ; XEmacs (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs (run-mode-hooks 'occur-mode-hook)) (defun occur-revert-function (ignore1 ignore2) "Handle `revert-buffer' for Occur mode buffers." (apply 'occur-1 (append occur-revert-arguments (list (buffer-name))))) ;; FSF Version of next function: ; (defun occur-mode-mouse-goto (event) ; "In Occur mode, go to the occurrence whose line you click on." ; (interactive "e") ; (let (pos) ; (save-excursion ; (set-buffer (window-buffer (posn-window (event-end event)))) ; (save-excursion ; (goto-char (posn-point (event-end event))) ; (setq pos (occur-mode-find-occurrence)))) ; (pop-to-buffer (marker-buffer pos)) ; (goto-char pos))) (defun occur-mode-mouse-goto (event) "Go to the occurrence highlighted by mouse. This function should be bound to a mouse key in the `*Occur*' buffer." (interactive "e") (let ((window-save (selected-window)) (frame-save (selected-frame))) ;; preserve the window/frame setup (unwind-protect (progn (mouse-set-point event) (occur-mode-goto-occurrence)) (select-frame frame-save) (select-window window-save)))) (defun occur-mode-find-occurrence () (let ((pos (get-text-property (point) 'occur-target))) (unless pos (error "No occurrence on this line")) (unless (buffer-live-p (marker-buffer pos)) (error "Buffer for this occurrence was killed")) pos)) (defun occur-mode-goto-occurrence () "Go to the occurrence the current line describes." (interactive) (let ((pos (occur-mode-find-occurrence))) (pop-to-buffer (marker-buffer pos)) (goto-char pos))) (defun occur-mode-goto-occurrence-other-window () "Go to the occurrence the current line describes, in another window." (interactive) (let ((pos (occur-mode-find-occurrence))) (switch-to-buffer-other-window (marker-buffer pos)) (goto-char pos))) (defun occur-mode-display-occurrence () "Display in another window the occurrence the current line describes." (interactive) (let ((pos (occur-mode-find-occurrence)) window ;; Bind these to ensure `display-buffer' puts it in another window. same-window-buffer-names same-window-regexps) (setq window (display-buffer (marker-buffer pos))) ;; This is the way to set point in the proper window. (save-selected-window (select-window window) (goto-char pos)))) (defun occur-find-match (n search message) (if (not n) (setq n 1)) (let ((r)) (while (> n 0) (setq r (funcall search (point) 'occur-match)) (and r (get-text-property r 'occur-match) (setq r (funcall search r 'occur-match))) (if r (goto-char r) (error message)) (setq n (1- n))))) (defun occur-next (&optional n) "Move to the Nth (default 1) next match in an Occur mode buffer." (interactive "p") (occur-find-match n #'next-single-property-change "No more matches")) (defun occur-prev (&optional n) "Move to the Nth (default 1) previous match in an Occur mode buffer." (interactive "p") (occur-find-match n #'previous-single-property-change "No earlier matches")) (defun occur-next-error (&optional argp reset) "Move to the Nth (default 1) next match in an Occur mode buffer. Compatibility function for \\[next-error] invocations." (interactive "p") ;; we need to run occur-find-match from within the Occur buffer (with-current-buffer ;; Choose the buffer and make it current. (if (next-error-buffer-p (current-buffer)) (current-buffer) (next-error-find-buffer nil nil (lambda () (eq major-mode 'occur-mode)))) (goto-char (cond (reset (point-min)) ((< argp 0) (line-beginning-position)) ((line-end-position)))) (occur-find-match (abs argp) (if (> 0 argp) #'previous-single-property-change #'next-single-property-change) "No more matches") ;; In case the *Occur* buffer is visible in a nonselected window. (set-window-point (get-buffer-window (current-buffer)) (point)) (occur-mode-goto-occurrence)))  (defface match '((((class color) (background light)) (:background "Tan")) (((class color) (background dark)) (:background "RoyalBlue3")) (((class color)) (:background "blue" :foreground "white")) (((type tty) (class mono)) (:inverse-video t)) (t (:background "gray"))) "Face used to highlight matches permanently." :group 'matching :version "22.1") (defcustom list-matching-lines-default-context-lines 0 "*Default number of context lines included around `list-matching-lines' matches. A negative number means to include that many lines before the match. A positive number means to include that many lines both before and after." :type 'integer :group 'matching) (defalias 'list-matching-lines 'occur) (defcustom list-matching-lines-face 'match "*Face used by \\[list-matching-lines] to show the text that matches. If the value is nil, don't highlight the matching portions specially." :type 'face :group 'matching) (defcustom list-matching-lines-buffer-name-face 'underline "*Face used by \\[list-matching-lines] to show the names of buffers. If the value is nil, don't highlight the buffer names specially." :type 'face :group 'matching) (defun occur-accumulate-lines (count &optional keep-props) (save-excursion (let ((forwardp (> count 0)) result beg end) (while (not (or (zerop count) (if forwardp (eobp) (bobp)))) (setq count (+ count (if forwardp -1 1))) (setq beg (line-beginning-position) end (line-end-position)) (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode) (text-property-not-all beg end 'fontified t)) (if (fboundp 'jit-lock-fontify-now) (jit-lock-fontify-now beg end))) (push (funcall (if keep-props #'buffer-substring #'buffer-substring-no-properties) beg end) result) (forward-line (if forwardp 1 -1))) (nreverse result)))) (defun occur-read-primary-args () (list (let* ((default (or (symbol-near-point) (and regexp-history (car regexp-history)))) (minibuffer-history-minimum-string-length 0) (input (if default ;; XEmacs: rewritten for I18N3 snarfing (read-from-minibuffer (format "List lines matching regexp (default `%s'): " default) nil nil nil 'regexp-history nil default) (read-from-minibuffer "List lines matching regexp: " nil nil nil 'regexp-history)))) (if (equal input "") default input)) (when current-prefix-arg (prefix-numeric-value current-prefix-arg)))) ;;;###autoload (defun occur-rename-buffer (&optional unique-p interactive-p) "Rename the current *Occur* buffer to *Occur: original-buffer-name*. Here `original-buffer-name' is the buffer name were Occur was originally run. When given the prefix argument, or called non-interactively, the renaming will not clobber the existing buffer(s) of that name, but use `generate-new-buffer-name' instead. You can add this to `occur-hook' if you always want a separate *Occur* buffer for each buffer where you invoke `occur'." (interactive "P\np") (with-current-buffer (if (eq major-mode 'occur-mode) (current-buffer) (get-buffer "*Occur*")) (rename-buffer (concat "*Occur: " (mapconcat #'buffer-name (car (cddr occur-revert-arguments)) "/") "*") (or unique-p (not interactive-p))))) ;;;###autoload (defun occur (regexp &optional nlines) "Show all lines in the current buffer containing a match for REGEXP. This function can not handle matches that span more than one line. Each line is displayed with NLINES lines before and after, or -NLINES before if NLINES is negative. NLINES defaults to `list-matching-lines-default-context-lines'. Interactively it is the prefix arg. The lines are shown in a buffer named `*Occur*'. It serves as a menu to find any of the occurrences in this buffer. \\<occur-mode-map>\\[describe-mode] in that buffer will explain how. If REGEXP contains upper case characters (excluding those preceded by `\\'), the matching is case-sensitive." (interactive (occur-read-primary-args)) (occur-1 regexp nlines (list (current-buffer)))) ;;;###autoload (defun multi-occur (bufs regexp &optional nlines) "Show all lines in buffers BUFS containing a match for REGEXP. This function acts on multiple buffers; otherwise, it is exactly like `occur'." (interactive (cons (let* ((bufs (list (read-buffer "First buffer to search: " (current-buffer) t))) (buf nil) (ido-ignore-item-temp-list bufs)) (while (not (string-equal (setq buf (read-buffer (if (and-boundp 'read-buffer-function '(eq read-buffer-function 'ido-read-buffer)) "Next buffer to search (C-j to end): " "Next buffer to search (RET to end): ") nil t)) "")) (add-to-list 'bufs buf) (setq ido-ignore-item-temp-list bufs)) (nreverse (mapcar #'get-buffer bufs))) (occur-read-primary-args))) (occur-1 regexp nlines bufs)) ;;;###autoload (defun multi-occur-by-filename-regexp (bufregexp regexp &optional nlines) "Show all lines matching REGEXP in buffers named by BUFREGEXP. See also `multi-occur'." (interactive (cons (let* ((default (car regexp-history)) (input (read-from-minibuffer "List lines in buffers whose filename matches regexp: " nil nil nil 'regexp-history))) (if (equal input "") default input)) (occur-read-primary-args))) (when bufregexp (occur-1 regexp nlines (delq nil (mapcar (lambda (buf) (when (and (buffer-file-name buf) (string-match bufregexp (buffer-file-name buf))) buf)) (buffer-list)))))) (defun occur-1 (regexp nlines bufs &optional buf-name) (unless buf-name (setq buf-name "*Occur*")) (let (occur-buf (active-bufs (delq nil (mapcar #'(lambda (buf) (when (buffer-live-p buf) buf)) bufs)))) ;; Handle the case where one of the buffers we're searching is the ;; output buffer. Just rename it. (when (member buf-name (mapcar 'buffer-name active-bufs)) (with-current-buffer (get-buffer buf-name) (rename-uniquely))) ;; Now find or create the output buffer. ;; If we just renamed that buffer, we will make a new one here. (setq occur-buf (get-buffer-create buf-name)) (with-current-buffer occur-buf (occur-mode) (let ((inhibit-read-only t)) (erase-buffer) (let ((count (occur-engine regexp active-bufs occur-buf (or nlines list-matching-lines-default-context-lines) (and case-fold-search (no-upper-case-p regexp t)) list-matching-lines-buffer-name-face nil list-matching-lines-face t))) (let* ((bufcount (length active-bufs)) (diff (- (length bufs) bufcount))) (message "Searched %d buffer%s%s; %s match%s for `%s'" bufcount (if (= bufcount 1) "" "s") (if (zerop diff) "" (format " (%d killed)" diff)) (if (zerop count) "no" (format "%d" count)) (if (= count 1) "" "es") regexp)) (setq occur-revert-arguments (list regexp nlines bufs)) (if (= count 0) (kill-buffer occur-buf) (display-buffer occur-buf) (setq next-error-last-buffer occur-buf) (setq buffer-read-only t) (set-buffer-modified-p nil) (run-hooks 'occur-hook))))))) (defun occur-engine-add-prefix (lines) (mapcar #'(lambda (line) (concat " :" line "\n")) lines)) (defun occur-engine (regexp buffers out-buf nlines case-fold-search title-face prefix-face match-face keep-props) (with-current-buffer out-buf (let ((globalcount 0) ;; Don't generate undo entries for creation of the initial contents. (buffer-undo-list t) (coding nil)) ;; Map over all the buffers (dolist (buf buffers) (when (buffer-live-p buf) (let ((matches 0) ;; count of matched lines (lines 1) ;; line count (matchbeg 0) (origpt nil) (begpt nil) (endpt nil) (marker nil) (curstring "") (headerpt (with-current-buffer out-buf (point)))) (save-excursion (set-buffer buf) (or coding ;; Set CODING only if the current buffer locally ;; binds buffer-file-coding-system. (not (local-variable-p 'buffer-file-coding-system (current-buffer))) (setq coding buffer-file-coding-system)) (save-excursion (goto-char (point-min)) ;; begin searching in the buffer (while (not (eobp)) (setq origpt (point)) (when (setq endpt (re-search-forward regexp nil t)) (setq matches (1+ matches)) ;; increment match count (setq matchbeg (match-beginning 0)) (setq lines (+ lines (1- (count-lines origpt endpt)))) (save-excursion (goto-char matchbeg) (setq begpt (line-beginning-position) endpt (line-end-position))) (setq marker (make-marker)) (set-marker marker matchbeg) (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode) (text-property-not-all begpt endpt 'fontified t)) (if (fboundp 'jit-lock-fontify-now) (jit-lock-fontify-now begpt endpt))) (setq curstring (buffer-substring begpt endpt)) ;; Depropertize the string, and maybe ;; highlight the matches (let ((len (length curstring)) (start 0)) (unless keep-props (set-text-properties 0 len nil curstring)) (while (and (< start len) (string-match regexp curstring start)) (add-text-properties (match-beginning 0) (match-end 0) (append `(occur-match t) (when match-face ;; Use `face' rather than `font-lock-face' here ;; so as to override faces copied from the buffer. `(face ,match-face))) curstring) (setq start (match-end 0)))) ;; Generate the string to insert for this match (let* ((out-line (concat ;; Using 7 digits aligns tabs properly. (apply #'propertize (format "%7d:" lines) (append (when prefix-face `(font-lock-face prefix-face)) '(occur-prefix t))) ;; We don't put `mouse-face' on the newline, ;; because that loses. And don't put it ;; on context lines to reduce flicker. (propertize curstring 'mouse-face 'highlight) "\n")) (data (if (= nlines 0) ;; The simple display style out-line ;; The complex multi-line display ;; style. Generate a list of lines, ;; concatenate them all together. (apply #'concat (nconc (occur-engine-add-prefix (nreverse (cdr (occur-accumulate-lines (- (1+ (abs nlines))) keep-props)))) (list out-line) (if (> nlines 0) (occur-engine-add-prefix (cdr (occur-accumulate-lines (1+ nlines) keep-props))))))))) ;; Actually insert the match display data (with-current-buffer out-buf (let ((beg (point)) (end (progn (insert data) (point)))) (unless (= nlines 0) (insert "-------\n")) (add-text-properties beg end `(occur-target ,marker help-echo "mouse-2: go to this occurrence"))))) (goto-char endpt)) (if endpt (progn (setq lines (1+ lines)) ;; On to the next match... (forward-line 1)) (goto-char (point-max)))))) (when (not (zerop matches)) ;; is the count zero? (setq globalcount (+ globalcount matches)) (with-current-buffer out-buf (goto-char headerpt) (let ((beg (point)) end) (insert (format "%d match%s for \"%s\" in buffer: %s\n" matches (if (= matches 1) "" "es") regexp (buffer-name buf))) (setq end (point)) (add-text-properties beg end (append (when title-face `(font-lock-face ,title-face)) `(occur-title ,buf)))) (goto-char (point-min))))))) (if coding ;; CODING is buffer-file-coding-system of the first buffer ;; that locally binds it. Let's use it also for the output ;; buffer. (set-buffer-file-coding-system coding)) ;; Return the number of matches globalcount))) (provide 'occur) --------------------------------------------------------------------------- ;;; next-error.el --- Next error support framework ;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 1999, ;; 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Maintainer: XEmacs Development Team ;; Keywords: internal ;; This file is part of XEmacs. ;; XEmacs 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 2, or (at your option) ;; any later version. ;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 22.0.50.1 (CVS) (defgroup next-error nil "`next-error' support framework." :group 'compilation :version "22.1") (defface next-error '((t (:inherit region))) "Face used to highlight next error locus." :group 'next-error :version "22.1") (defcustom next-error-highlight 0.1 "*Highlighting of locations in selected source buffers. If number, highlight the locus in `next-error' face for given time in seconds. If t, use persistent overlays fontified in `next-error' face. If nil, don't highlight the locus in the source buffer. If `fringe-arrow', indicate the locus by the fringe arrow." :type '(choice (number :tag "Delay") (const :tag "Persistent overlay" t) (const :tag "No highlighting" nil) (const :tag "Fringe arrow" 'fringe-arrow)) :group 'next-error :version "22.1") (defcustom next-error-highlight-no-select 0.1 "*Highlighting of locations in non-selected source buffers. If number, highlight the locus in `next-error' face for given time in seconds. If t, use persistent overlays fontified in `next-error' face. If nil, don't highlight the locus in the source buffer. If `fringe-arrow', indicate the locus by the fringe arrow." :type '(choice (number :tag "Delay") (const :tag "Persistent overlay" t) (const :tag "No highlighting" nil) (const :tag "Fringe arrow" 'fringe-arrow)) :group 'next-error :version "22.1") (defcustom next-error-hook nil "*List of hook functions run by `next-error' after visiting source file." :type 'hook :group 'next-error) (defvar next-error-highlight-timer nil) ;(defvar next-error-overlay-arrow-position nil) ;(put 'next-error-overlay-arrow-position 'overlay-arrow-string "=>") ;(add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position) (defvar next-error-last-buffer nil "The most recent `next-error' buffer. A buffer becomes most recent when its compilation, grep, or similar mode is started, or when it is used with \\[next-error] or \\[compile-goto-error].") (defvar next-error-function nil "Function to use to find the next error in the current buffer. The function is called with 2 parameters: ARG is an integer specifying by how many errors to move. RESET is a boolean which, if non-nil, says to go back to the beginning of the errors before moving. Major modes providing compile-like functionality should set this variable to indicate to `next-error' that this is a candidate buffer and how to navigate in it.") (make-variable-buffer-local 'next-error-function) (defsubst next-error-buffer-p (buffer &optional avoid-current extra-test-inclusive extra-test-exclusive) "Test if BUFFER is a `next-error' capable buffer. If AVOID-CURRENT is non-nil, treat the current buffer as an absolute last resort only. The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer that normally would not qualify. If it returns t, the buffer in question is treated as usable. The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer that would normally be considered usable. If it returns nil, that buffer is rejected." (and (buffer-name buffer) ;First make sure it's live. (not (and avoid-current (eq buffer (current-buffer)))) (with-current-buffer buffer (if next-error-function ; This is the normal test. ;; Optionally reject some buffers. (if extra-test-exclusive (funcall extra-test-exclusive) t) ;; Optionally accept some other buffers. (and extra-test-inclusive (funcall extra-test-inclusive)))))) (defun next-error-find-buffer (&optional avoid-current extra-test-inclusive extra-test-exclusive) "Return a `next-error' capable buffer. If AVOID-CURRENT is non-nil, treat the current buffer as an absolute last resort only. The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer that normally would not qualify. If it returns t, the buffer in question is treated as usable. The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer that would normally be considered usable. If it returns nil, that buffer is rejected." (or ;; 1. If one window on the selected frame displays such buffer, return it. (let ((window-buffers (delete-dups (delq nil (mapcar (lambda (w) (if (next-error-buffer-p (window-buffer w) avoid-current extra-test-inclusive extra-test-exclusive) (window-buffer w))) (window-list)))))) (if (eq (length window-buffers) 1) (car window-buffers))) ;; 2. If next-error-last-buffer is an acceptable buffer, use that. (if (and next-error-last-buffer (next-error-buffer-p next-error-last-buffer avoid-current extra-test-inclusive extra-test-exclusive)) next-error-last-buffer) ;; 3. If the current buffer is acceptable, choose it. (if (next-error-buffer-p (current-buffer) avoid-current extra-test-inclusive extra-test-exclusive) (current-buffer)) ;; 4. Look for any acceptable buffer. (let ((buffers (buffer-list))) (while (and buffers (not (next-error-buffer-p (car buffers) avoid-current extra-test-inclusive extra-test-exclusive))) (setq buffers (cdr buffers))) (car buffers)) ;; 5. Use the current buffer as a last resort if it qualifies, ;; even despite AVOID-CURRENT. (and avoid-current (next-error-buffer-p (current-buffer) nil extra-test-inclusive extra-test-exclusive) (progn (message "This is the only next-error capable buffer") (current-buffer))) ;; 6. Give up. (error "No next-error capable buffer found"))) ;;;###autoload (defun next-error (&optional arg reset) "Visit next `next-error' message and corresponding source code. If all the error messages parsed so far have been processed already, the message buffer is checked for new ones. A prefix ARG specifies how many error messages to move; negative means move back to previous error messages. Just \\[universal-argument] as a prefix means reparse the error message buffer and start at the first error. The RESET argument specifies that we should restart from the beginning. \\[next-error] normally uses the most recently started compilation, grep, or occur buffer. It can also operate on any buffer with output from the \\[compile], \\[grep] commands, or, more generally, on any buffer in Compilation mode or with Compilation Minor mode enabled, or any buffer in which `next-error-function' is bound to an appropriate function. To specify use of a particular buffer for error messages, type \\[next-error] in that buffer when it is the only one displayed in the current frame. Once \\[next-error] has chosen the buffer for error messages, it runs `next-error-hook' with `run-hooks', and stays with that buffer until you use it in some other buffer which uses Compilation mode or Compilation Minor mode. See variables `compilation-parse-errors-function' and \`compilation-error-regexp-alist' for customization ideas." (interactive "P") (if (consp arg) (setq reset t arg nil)) (when (setq next-error-last-buffer (next-error-find-buffer)) ;; we know here that next-error-function is a valid symbol we can funcall (with-current-buffer next-error-last-buffer (funcall next-error-function (prefix-numeric-value arg) reset) (run-hooks 'next-error-hook)))) (defalias 'goto-next-locus 'next-error) (defalias 'next-match 'next-error) (defun previous-error (&optional n) "Visit previous `next-error' message and corresponding source code. Prefix arg N says how many error messages to move backwards (or forwards, if negative). This operates on the output from the \\[compile] and \\[grep] commands." (interactive "p") (next-error (- (or n 1)))) (defun first-error (&optional n) "Restart at the first error. Visit corresponding source code. With prefix arg N, visit the source code of the Nth error. This operates on the output from the \\[compile] command, for instance." (interactive "p") (next-error n t)) (defun next-error-no-select (&optional n) "Move point to the next error in the `next-error' buffer and highlight match. Prefix arg N says how many error messages to move forwards (or backwards, if negative). Finds and highlights the source line like \\[next-error], but does not select the source buffer." (interactive "p") (let ((next-error-highlight next-error-highlight-no-select)) (next-error n)) (pop-to-buffer next-error-last-buffer)) (defun previous-error-no-select (&optional n) "Move point to the previous error in the `next-error' buffer and highlight match. Prefix arg N says how many error messages to move backwards (or forwards, if negative). Finds and highlights the source line like \\[previous-error], but does not select the source buffer." (interactive "p") (next-error-no-select (- (or n 1)))) ;;; Internal variable for `next-error-follow-mode-post-command-hook'. (defvar next-error-follow-last-line nil) (define-minor-mode next-error-follow-minor-mode "Minor mode for compilation, occur and diff modes. When turned on, cursor motion in the compilation, grep, occur or diff buffer causes automatic display of the corresponding source code location." :group 'next-error :init-value nil :lighter " Fol" (if (not next-error-follow-minor-mode) (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t) (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t) (make-local-variable 'next-error-follow-last-line))) ;;; Used as a `post-command-hook' by `next-error-follow-mode' ;;; for the *Compilation* *grep* and *Occur* buffers. (defun next-error-follow-mode-post-command-hook () (unless (equal next-error-follow-last-line (line-number-at-pos)) (setq next-error-follow-last-line (line-number-at-pos)) (condition-case nil (let ((compilation-context-lines nil)) (setq compilation-current-error (point)) (next-error-no-select 0)) (error t)))) (provide 'next-error) --------------------------------------------------------------------------- -- Malcolm Purvis <malcolmp(a)xemacs.org&gt;