Mercurial > hg > xemacs-beta
annotate lisp/occur.el @ 5927:b58b74274fa2 cygwin
changes from long ago, never committed...
| author | Henry Thompson <ht@markup.co.uk> |
|---|---|
| date | Wed, 15 Dec 2021 19:02:33 +0000 |
| parents | cc6f0266bc36 |
| children | 0bddb59072b6 |
| rev | line source |
|---|---|
| 3000 | 1 ;;; occur.el --- Show all lines in the current buffer containing a match for REGEXP. |
| 2 | |
| 3 ;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1996, 1997, 2000, 2001, | |
| 4 ;; 2002, 2003, 2004, 2005 Free Software Foundation, Inc. | |
| 5 | |
| 6 ;; Maintainer: XEmacs Development Team | |
| 7 ;; Keywords: internal | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
14 ;; option) any later version. |
| 3000 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
19 ;; for more details. |
| 3000 | 20 |
| 21 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 3000 | 23 |
| 24 ;;; Synched up with: FSF 22.0.50.1 (CVS) | |
| 25 | |
| 26 (require 'next-error) | |
| 27 (defun query-replace-descr (string) | |
| 28 (mapconcat 'isearch-text-char-description string "")) | |
| 29 | |
| 30 (defvar occur-mode-map () | |
| 31 "Keymap for `occur-mode'.") | |
| 32 (if occur-mode-map | |
| 33 () | |
| 34 (setq occur-mode-map (make-sparse-keymap)) | |
| 35 (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs | |
| 36 (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) ; XEmacs | |
| 37 (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) | |
| 38 (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence) | |
| 39 (define-key occur-mode-map "o" 'occur-mode-goto-occurrence-other-window) | |
| 40 (define-key occur-mode-map "\C-o" 'occur-mode-display-occurrence) | |
| 41 (define-key occur-mode-map "\M-n" 'occur-next) | |
| 42 (define-key occur-mode-map "\M-p" 'occur-prev) | |
| 43 (define-key occur-mode-map "r" 'occur-rename-buffer) | |
| 44 (define-key occur-mode-map "c" 'clone-buffer) | |
| 45 (define-key occur-mode-map "g" 'revert-buffer) | |
| 46 (define-key occur-mode-map "q" 'quit-window) | |
| 47 (define-key occur-mode-map "z" 'kill-this-buffer) | |
| 48 (define-key occur-mode-map "\C-c\C-f" 'next-error-follow-minor-mode)) | |
| 49 | |
| 50 (defvar occur-revert-arguments nil | |
| 51 "Arguments to pass to `occur-1' to revert an Occur mode buffer. | |
| 52 See `occur-revert-function'.") | |
| 53 | |
| 54 (defcustom occur-mode-hook nil ; XEmacs | |
| 55 "Hook run when entering Occur mode." | |
| 56 :type 'hook | |
| 57 :group 'matching) | |
| 58 | |
| 59 (defcustom occur-hook nil | |
| 60 "Hook run by Occur when there are any matches." | |
| 61 :type 'hook | |
| 62 :group 'matching) | |
| 63 | |
| 64 (put 'occur-mode 'mode-class 'special) | |
| 65 ;;;###autoload | |
| 66 (defun occur-mode () | |
| 67 "Major mode for output from \\[occur]. | |
| 68 \\<occur-mode-map>Move point to one of the items in this buffer, then use | |
| 69 \\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to. | |
| 70 Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. | |
| 71 | |
| 72 \\{occur-mode-map}" | |
| 73 (interactive) | |
| 74 (kill-all-local-variables) | |
| 75 (use-local-map occur-mode-map) | |
| 76 (setq major-mode 'occur-mode) | |
| 77 (setq mode-name (gettext "Occur")) ; XEmacs | |
| 78 (set (make-local-variable 'revert-buffer-function) 'occur-revert-function) | |
| 79 (make-local-variable 'occur-revert-arguments) | |
| 80 (add-hook 'change-major-mode-hook 'turn-off-font-lock t t) | |
| 81 (setq next-error-function 'occur-next-error) | |
| 82 (require 'mode-motion) ; XEmacs | |
| 83 (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs | |
| 84 (run-mode-hooks 'occur-mode-hook)) | |
| 85 | |
| 86 (defun occur-revert-function (ignore1 ignore2) | |
| 87 "Handle `revert-buffer' for Occur mode buffers." | |
| 88 (apply 'occur-1 (append occur-revert-arguments (list (buffer-name))))) | |
| 89 | |
| 90 ;; FSF Version of next function: | |
| 91 ; (defun occur-mode-mouse-goto (event) | |
| 92 ; "In Occur mode, go to the occurrence whose line you click on." | |
| 93 ; (interactive "e") | |
| 94 ; (let (pos) | |
| 95 ; (save-excursion | |
| 96 ; (set-buffer (window-buffer (posn-window (event-end event)))) | |
| 97 ; (save-excursion | |
| 98 ; (goto-char (posn-point (event-end event))) | |
| 99 ; (setq pos (occur-mode-find-occurrence)))) | |
| 100 ; (pop-to-buffer (marker-buffer pos)) | |
| 101 ; (goto-char pos))) | |
| 102 | |
| 103 (defun occur-mode-mouse-goto (event) | |
| 104 "Go to the occurrence highlighted by mouse. | |
| 105 This function should be bound to a mouse key in the `*Occur*' buffer." | |
| 106 (interactive "e") | |
| 107 (let ((window-save (selected-window)) | |
| 108 (frame-save (selected-frame))) | |
| 109 ;; preserve the window/frame setup | |
| 110 (unwind-protect | |
| 111 (progn | |
| 112 (mouse-set-point event) | |
| 113 (occur-mode-goto-occurrence)) | |
| 114 (select-frame frame-save) | |
| 115 (select-window window-save)))) | |
| 116 | |
| 117 (defun occur-mode-find-occurrence () | |
| 118 (let ((pos (get-text-property (point) 'occur-target))) | |
| 119 (unless pos | |
| 120 (error "No occurrence on this line")) | |
| 121 (unless (buffer-live-p (marker-buffer pos)) | |
| 122 (error "Buffer for this occurrence was killed")) | |
| 123 pos)) | |
| 124 | |
| 125 (defun occur-mode-goto-occurrence () | |
| 126 "Go to the occurrence the current line describes." | |
| 127 (interactive) | |
| 128 (let ((pos (occur-mode-find-occurrence))) | |
| 129 (pop-to-buffer (marker-buffer pos)) | |
| 130 (goto-char pos))) | |
| 131 | |
| 132 (defun occur-mode-goto-occurrence-other-window () | |
| 133 "Go to the occurrence the current line describes, in another window." | |
| 134 (interactive) | |
| 135 (let ((pos (occur-mode-find-occurrence))) | |
| 136 (switch-to-buffer-other-window (marker-buffer pos)) | |
| 137 (goto-char pos))) | |
| 138 | |
| 139 (defun occur-mode-display-occurrence () | |
| 140 "Display in another window the occurrence the current line describes." | |
| 141 (interactive) | |
| 142 (let ((pos (occur-mode-find-occurrence)) | |
| 143 window | |
| 144 ;; Bind these to ensure `display-buffer' puts it in another window. | |
| 145 same-window-buffer-names | |
| 146 same-window-regexps) | |
| 147 (setq window (display-buffer (marker-buffer pos))) | |
| 148 ;; This is the way to set point in the proper window. | |
| 149 (save-selected-window | |
| 150 (select-window window) | |
| 151 (goto-char pos)))) | |
| 152 | |
| 153 (defun occur-find-match (n search message) | |
| 154 (if (not n) (setq n 1)) | |
| 155 (let ((r)) | |
| 156 (while (> n 0) | |
| 157 (setq r (funcall search (point) 'occur-match)) | |
| 158 (and r | |
| 159 (get-text-property r 'occur-match) | |
| 160 (setq r (funcall search r 'occur-match))) | |
| 161 (if r | |
| 162 (goto-char r) | |
| 163 (error message)) | |
| 164 (setq n (1- n))))) | |
| 165 | |
| 166 (defun occur-next (&optional n) | |
| 167 "Move to the Nth (default 1) next match in an Occur mode buffer." | |
| 168 (interactive "p") | |
| 169 (occur-find-match n #'next-single-property-change "No more matches")) | |
| 170 | |
| 171 (defun occur-prev (&optional n) | |
| 172 "Move to the Nth (default 1) previous match in an Occur mode buffer." | |
| 173 (interactive "p") | |
| 174 (occur-find-match n #'previous-single-property-change "No earlier matches")) | |
| 175 | |
| 176 (defun occur-next-error (&optional argp reset) | |
| 177 "Move to the Nth (default 1) next match in an Occur mode buffer. | |
| 3299 | 178 Compatibility function for \\[next-error-framework-next-error] invocations." |
| 3000 | 179 (interactive "p") |
| 180 ;; we need to run occur-find-match from within the Occur buffer | |
| 181 (with-current-buffer | |
| 182 ;; Choose the buffer and make it current. | |
| 183 (if (next-error-buffer-p (current-buffer)) | |
| 184 (current-buffer) | |
| 185 (next-error-find-buffer nil nil | |
| 186 (lambda () | |
| 187 (eq major-mode 'occur-mode)))) | |
| 188 | |
| 189 (goto-char (cond (reset (point-min)) | |
| 190 ((< argp 0) (line-beginning-position)) | |
| 191 ((line-end-position)))) | |
| 192 (occur-find-match | |
| 193 (abs argp) | |
| 194 (if (> 0 argp) | |
| 195 #'previous-single-property-change | |
| 196 #'next-single-property-change) | |
| 197 "No more matches") | |
| 198 ;; In case the *Occur* buffer is visible in a nonselected window. | |
| 199 (set-window-point (get-buffer-window (current-buffer)) (point)) | |
| 200 (occur-mode-goto-occurrence))) | |
| 201 | |
| 202 (defface match | |
| 203 '((((class color) (background light)) | |
| 204 (:background "Tan")) | |
| 205 (((class color) (background dark)) | |
| 206 (:background "RoyalBlue3")) | |
| 207 (((class color)) | |
| 208 (:background "blue" :foreground "white")) | |
| 209 (((type tty) (class mono)) | |
| 210 (:inverse-video t)) | |
| 211 (t (:background "gray"))) | |
| 212 "Face used to highlight matches permanently." | |
| 213 :group 'matching | |
| 214 :version "22.1") | |
| 215 | |
| 216 (defcustom list-matching-lines-default-context-lines 0 | |
| 217 "*Default number of context lines included around `list-matching-lines' matches. | |
| 218 A negative number means to include that many lines before the match. | |
| 219 A positive number means to include that many lines both before and after." | |
| 220 :type 'integer | |
| 221 :group 'matching) | |
| 222 | |
| 3112 | 223 ;;;###autoload |
| 3000 | 224 (defalias 'list-matching-lines 'occur) |
| 225 | |
| 226 (defcustom list-matching-lines-face 'match | |
| 227 "*Face used by \\[list-matching-lines] to show the text that matches. | |
| 228 If the value is nil, don't highlight the matching portions specially." | |
| 229 :type 'face | |
| 230 :group 'matching) | |
| 231 | |
| 232 (defcustom list-matching-lines-buffer-name-face 'underline | |
| 233 "*Face used by \\[list-matching-lines] to show the names of buffers. | |
| 234 If the value is nil, don't highlight the buffer names specially." | |
| 235 :type 'face | |
| 236 :group 'matching) | |
| 237 | |
| 238 (defun occur-accumulate-lines (count &optional keep-props) | |
| 239 (save-excursion | |
| 240 (let ((forwardp (> count 0)) | |
| 241 result beg end) | |
| 242 (while (not (or (zerop count) | |
| 243 (if forwardp | |
| 244 (eobp) | |
| 245 (bobp)))) | |
| 246 (setq count (+ count (if forwardp -1 1))) | |
| 247 (setq beg (line-beginning-position) | |
| 248 end (line-end-position)) | |
| 3017 | 249 (if (and keep-props (if-boundp 'jit-lock-mode jit-lock-mode) |
| 3000 | 250 (text-property-not-all beg end 'fontified t)) |
| 3017 | 251 (if-fboundp 'jit-lock-fontify-now |
| 3000 | 252 (jit-lock-fontify-now beg end))) |
| 253 (push | |
| 254 (funcall (if keep-props | |
| 255 #'buffer-substring | |
| 256 #'buffer-substring-no-properties) | |
| 257 beg end) | |
| 258 result) | |
| 259 (forward-line (if forwardp 1 -1))) | |
| 260 (nreverse result)))) | |
| 261 | |
| 262 (defun occur-read-primary-args () | |
| 263 (list (let* ((default (or (symbol-near-point) | |
| 264 (and regexp-history | |
| 265 (car regexp-history)))) | |
| 266 (minibuffer-history-minimum-string-length 0) | |
| 267 (input | |
| 268 (if default | |
| 269 ;; XEmacs: rewritten for I18N3 snarfing | |
| 270 (read-from-minibuffer | |
| 271 (format "List lines matching regexp (default `%s'): " | |
| 272 default) nil nil nil 'regexp-history nil | |
| 273 default) | |
| 274 (read-from-minibuffer | |
| 275 "List lines matching regexp: " | |
| 276 nil nil nil | |
| 277 'regexp-history)))) | |
| 278 (if (equal input "") | |
| 279 default | |
| 280 input)) | |
| 281 (when current-prefix-arg | |
| 282 (prefix-numeric-value current-prefix-arg)))) | |
| 283 | |
| 284 ;;;###autoload | |
| 285 (defun occur-rename-buffer (&optional unique-p interactive-p) | |
| 286 "Rename the current *Occur* buffer to *Occur: original-buffer-name*. | |
| 287 Here `original-buffer-name' is the buffer name were Occur was originally run. | |
| 288 When given the prefix argument, or called non-interactively, the renaming | |
| 289 will not clobber the existing buffer(s) of that name, but use | |
| 290 `generate-new-buffer-name' instead. You can add this to `occur-hook' | |
| 291 if you always want a separate *Occur* buffer for each buffer where you | |
| 292 invoke `occur'." | |
| 293 (interactive "P\np") | |
| 294 (with-current-buffer | |
| 295 (if (eq major-mode 'occur-mode) (current-buffer) (get-buffer "*Occur*")) | |
| 296 (rename-buffer (concat "*Occur: " | |
| 297 (mapconcat #'buffer-name | |
| 298 (car (cddr occur-revert-arguments)) "/") | |
| 299 "*") | |
| 300 (or unique-p (not interactive-p))))) | |
| 301 | |
| 302 ;;;###autoload | |
| 303 (defun occur (regexp &optional nlines) | |
| 304 "Show all lines in the current buffer containing a match for REGEXP. | |
| 305 This function can not handle matches that span more than one line. | |
| 306 | |
| 307 Each line is displayed with NLINES lines before and after, or -NLINES | |
| 308 before if NLINES is negative. | |
| 309 NLINES defaults to `list-matching-lines-default-context-lines'. | |
| 310 Interactively it is the prefix arg. | |
| 311 | |
| 312 The lines are shown in a buffer named `*Occur*'. | |
| 313 It serves as a menu to find any of the occurrences in this buffer. | |
| 314 \\<occur-mode-map>\\[describe-mode] in that buffer will explain how. | |
| 315 | |
| 316 If REGEXP contains upper case characters (excluding those preceded by `\\'), | |
| 317 the matching is case-sensitive." | |
| 318 (interactive (occur-read-primary-args)) | |
| 319 (occur-1 regexp nlines (list (current-buffer)))) | |
| 320 | |
| 321 ;;;###autoload | |
| 322 (defun multi-occur (bufs regexp &optional nlines) | |
| 323 "Show all lines in buffers BUFS containing a match for REGEXP. | |
| 324 This function acts on multiple buffers; otherwise, it is exactly like | |
| 325 `occur'." | |
| 326 (interactive | |
| 327 (cons | |
| 328 (let* ((bufs (list (read-buffer "First buffer to search: " | |
| 329 (current-buffer) t))) | |
| 330 (buf nil) | |
| 3299 | 331 ; (ido-ignore-item-temp-list bufs) |
| 332 ) | |
| 3000 | 333 (while (not (string-equal |
| 334 (setq buf (read-buffer | |
| 335 (if (and-boundp 'read-buffer-function | |
| 336 '(eq read-buffer-function 'ido-read-buffer)) | |
| 337 "Next buffer to search (C-j to end): " | |
| 338 "Next buffer to search (RET to end): ") | |
| 339 nil t)) | |
| 340 "")) | |
| 341 (add-to-list 'bufs buf) | |
| 3299 | 342 ; (setq ido-ignore-item-temp-list bufs) |
| 343 ) | |
| 3000 | 344 (nreverse (mapcar #'get-buffer bufs))) |
| 345 (occur-read-primary-args))) | |
| 346 (occur-1 regexp nlines bufs)) | |
| 347 | |
| 348 ;;;###autoload | |
| 349 (defun multi-occur-by-filename-regexp (bufregexp regexp &optional nlines) | |
| 350 "Show all lines matching REGEXP in buffers named by BUFREGEXP. | |
| 351 See also `multi-occur'." | |
| 352 (interactive | |
| 353 (cons | |
| 354 (let* ((default (car regexp-history)) | |
| 355 (input | |
| 356 (read-from-minibuffer | |
| 357 "List lines in buffers whose filename matches regexp: " | |
| 358 nil | |
| 359 nil | |
| 360 nil | |
| 361 'regexp-history))) | |
| 362 (if (equal input "") | |
| 363 default | |
| 364 input)) | |
| 365 (occur-read-primary-args))) | |
| 366 (when bufregexp | |
| 367 (occur-1 regexp nlines | |
|
5652
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
368 (mapcan #'(lambda (buf) |
|
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
369 (when (and (buffer-file-name buf) |
|
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
370 (string-match bufregexp |
|
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
371 (buffer-file-name buf))) |
|
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
372 (list buf))) |
|
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
373 (buffer-list))))) |
| 3000 | 374 |
| 375 (defun occur-1 (regexp nlines bufs &optional buf-name) | |
| 376 (unless buf-name | |
| 377 (setq buf-name "*Occur*")) | |
| 378 (let (occur-buf | |
|
5652
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
379 (active-bufs (remove-if-not #'buffer-live-p bufs))) |
| 3000 | 380 ;; Handle the case where one of the buffers we're searching is the |
| 381 ;; output buffer. Just rename it. | |
|
5652
cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
382 (when (position buf-name active-bufs :test #'equal :key #'buffer-name) |
| 3000 | 383 (with-current-buffer (get-buffer buf-name) |
| 384 (rename-uniquely))) | |
| 385 | |
| 386 ;; Now find or create the output buffer. | |
| 387 ;; If we just renamed that buffer, we will make a new one here. | |
| 388 (setq occur-buf (get-buffer-create buf-name)) | |
| 389 | |
| 390 (with-current-buffer occur-buf | |
| 391 (occur-mode) | |
| 392 (let ((inhibit-read-only t)) | |
| 393 (erase-buffer) | |
| 394 (let ((count (occur-engine | |
| 395 regexp active-bufs occur-buf | |
| 396 (or nlines list-matching-lines-default-context-lines) | |
| 397 (and case-fold-search | |
| 398 (no-upper-case-p regexp t)) | |
| 399 list-matching-lines-buffer-name-face | |
| 400 nil list-matching-lines-face t))) | |
| 401 (let* ((bufcount (length active-bufs)) | |
| 402 (diff (- (length bufs) bufcount))) | |
| 403 (message "Searched %d buffer%s%s; %s match%s for `%s'" | |
| 404 bufcount (if (= bufcount 1) "" "s") | |
| 405 (if (zerop diff) "" (format " (%d killed)" diff)) | |
| 406 (if (zerop count) "no" (format "%d" count)) | |
| 407 (if (= count 1) "" "es") | |
| 408 regexp)) | |
| 409 (setq occur-revert-arguments (list regexp nlines bufs)) | |
| 410 (if (= count 0) | |
| 411 (kill-buffer occur-buf) | |
| 412 (display-buffer occur-buf) | |
| 413 (setq next-error-last-buffer occur-buf) | |
| 414 (setq buffer-read-only t) | |
| 415 (set-buffer-modified-p nil) | |
| 416 (run-hooks 'occur-hook))))))) | |
| 417 | |
| 418 (defun occur-engine-add-prefix (lines) | |
| 419 (mapcar | |
| 420 #'(lambda (line) | |
| 421 (concat " :" line "\n")) | |
| 422 lines)) | |
| 423 | |
| 424 (defun occur-engine (regexp buffers out-buf nlines case-fold-search | |
| 425 title-face prefix-face match-face keep-props) | |
| 426 (with-current-buffer out-buf | |
| 427 (let ((globalcount 0) | |
| 428 ;; Don't generate undo entries for creation of the initial contents. | |
| 429 (buffer-undo-list t) | |
| 430 (coding nil)) | |
| 431 ;; Map over all the buffers | |
| 432 (dolist (buf buffers) | |
| 433 (when (buffer-live-p buf) | |
| 434 (let ((matches 0) ;; count of matched lines | |
| 435 (lines 1) ;; line count | |
| 436 (matchbeg 0) | |
| 437 (origpt nil) | |
| 438 (begpt nil) | |
| 439 (endpt nil) | |
| 440 (marker nil) | |
| 441 (curstring "") | |
| 442 (headerpt (with-current-buffer out-buf (point)))) | |
| 443 (save-excursion | |
| 444 (set-buffer buf) | |
| 445 (or coding | |
| 446 ;; Set CODING only if the current buffer locally | |
| 447 ;; binds buffer-file-coding-system. | |
| 448 (not (local-variable-p 'buffer-file-coding-system (current-buffer))) | |
| 449 (setq coding buffer-file-coding-system)) | |
| 450 (save-excursion | |
| 451 (goto-char (point-min)) ;; begin searching in the buffer | |
| 452 (while (not (eobp)) | |
| 453 (setq origpt (point)) | |
| 454 (when (setq endpt (re-search-forward regexp nil t)) | |
| 455 (setq matches (1+ matches)) ;; increment match count | |
| 456 (setq matchbeg (match-beginning 0)) | |
| 457 (setq lines (+ lines (1- (count-lines origpt endpt)))) | |
| 458 (save-excursion | |
| 459 (goto-char matchbeg) | |
| 460 (setq begpt (line-beginning-position) | |
| 461 endpt (line-end-position))) | |
| 462 (setq marker (make-marker)) | |
| 463 (set-marker marker matchbeg) | |
| 464 (if (and keep-props | |
| 4103 | 465 (if-boundp 'jit-lock-mode jit-lock-mode) |
| 3000 | 466 (text-property-not-all begpt endpt 'fontified t)) |
|
5368
ed74d2ca7082
Use ', not #', when a given symbol may not have a function binding at read time
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
467 (if-fboundp 'jit-lock-fontify-now |
| 3000 | 468 (jit-lock-fontify-now begpt endpt))) |
| 469 (setq curstring (buffer-substring begpt endpt)) | |
| 470 ;; Depropertize the string, and maybe | |
| 471 ;; highlight the matches | |
| 472 (let ((len (length curstring)) | |
| 473 (start 0)) | |
| 474 (unless keep-props | |
| 475 (set-text-properties 0 len nil curstring)) | |
| 476 (while (and (< start len) | |
| 477 (string-match regexp curstring start)) | |
| 478 (add-text-properties | |
| 479 (match-beginning 0) (match-end 0) | |
| 480 (append | |
| 481 `(occur-match t) | |
| 482 (when match-face | |
| 483 ;; Use `face' rather than `font-lock-face' here | |
| 484 ;; so as to override faces copied from the buffer. | |
| 485 `(face ,match-face))) | |
| 486 curstring) | |
| 487 (setq start (match-end 0)))) | |
| 488 ;; Generate the string to insert for this match | |
| 489 (let* ((out-line | |
| 490 (concat | |
| 491 ;; Using 7 digits aligns tabs properly. | |
| 492 (apply #'propertize (format "%7d:" lines) | |
| 493 (append | |
| 494 (when prefix-face | |
| 495 `(font-lock-face prefix-face)) | |
| 496 '(occur-prefix t))) | |
| 497 ;; We don't put `mouse-face' on the newline, | |
| 498 ;; because that loses. And don't put it | |
| 499 ;; on context lines to reduce flicker. | |
| 500 (propertize curstring 'mouse-face 'highlight) | |
| 501 "\n")) | |
| 502 (data | |
| 503 (if (= nlines 0) | |
| 504 ;; The simple display style | |
| 505 out-line | |
| 506 ;; The complex multi-line display | |
| 507 ;; style. Generate a list of lines, | |
| 508 ;; concatenate them all together. | |
| 509 (apply #'concat | |
| 510 (nconc | |
| 511 (occur-engine-add-prefix (nreverse (cdr (occur-accumulate-lines (- (1+ (abs nlines))) keep-props)))) | |
| 512 (list out-line) | |
| 513 (if (> nlines 0) | |
| 514 (occur-engine-add-prefix | |
| 515 (cdr (occur-accumulate-lines (1+ nlines) keep-props))))))))) | |
| 516 ;; Actually insert the match display data | |
| 517 (with-current-buffer out-buf | |
| 518 (let ((beg (point)) | |
| 519 (end (progn (insert data) (point)))) | |
| 520 (unless (= nlines 0) | |
| 521 (insert "-------\n")) | |
| 522 (add-text-properties | |
| 523 beg end | |
| 524 `(occur-target ,marker help-echo "mouse-2: go to this occurrence"))))) | |
| 525 (goto-char endpt)) | |
| 526 (if endpt | |
| 527 (progn | |
| 528 (setq lines (1+ lines)) | |
| 529 ;; On to the next match... | |
| 530 (forward-line 1)) | |
| 531 (goto-char (point-max)))))) | |
| 532 (when (not (zerop matches)) ;; is the count zero? | |
| 533 (setq globalcount (+ globalcount matches)) | |
| 534 (with-current-buffer out-buf | |
| 535 (goto-char headerpt) | |
| 536 (let ((beg (point)) | |
| 537 end) | |
| 538 (insert (format "%d match%s for \"%s\" in buffer: %s\n" | |
| 539 matches (if (= matches 1) "" "es") | |
| 540 regexp (buffer-name buf))) | |
| 541 (setq end (point)) | |
| 542 (add-text-properties beg end | |
| 543 (append | |
| 544 (when title-face | |
| 545 `(font-lock-face ,title-face)) | |
| 546 `(occur-title ,buf)))) | |
| 547 (goto-char (point-min))))))) | |
| 548 (if coding | |
| 549 ;; CODING is buffer-file-coding-system of the first buffer | |
| 550 ;; that locally binds it. Let's use it also for the output | |
| 551 ;; buffer. | |
| 552 (set-buffer-file-coding-system coding)) | |
| 553 ;; Return the number of matches | |
| 554 globalcount))) | |
| 555 | |
| 556 (provide 'occur) |