Mercurial > hg > xemacs-beta
annotate lisp/occur.el @ 5882:bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
lisp/ChangeLog addition:
2015-04-01 Aidan Kehoe <kehoea@parhasard.net>
When calling #'string-match with a REGEXP without regular
expression special characters, call #'search, #'mismatch, #'find,
etc. instead, making our code less likely to side-effect other
functions' match data and a little faster.
* apropos.el (apropos-command):
* apropos.el (apropos):
Call (position ?\n ...) rather than (string-match "\n" ...) here.
* buff-menu.el:
* buff-menu.el (buffers-menu-omit-invisible-buffers):
Don't fire up the regexp engine just to check if a string starts
with a space.
* buff-menu.el (select-buffers-tab-buffers-by-mode):
Don't fire up the regexp engine just to compare mode basenames.
* buff-menu.el (format-buffers-tab-line):
* buff-menu.el (build-buffers-tab-internal): Moved to being a
label within the following.
* buff-menu.el (buffers-tab-items): Use the label.
* bytecomp.el (byte-compile-log-1):
Don't fire up the regexp engine just to look for a newline.
* cus-edit.el (get):
Ditto.
* cus-edit.el (custom-variable-value-create):
Ditto, but for a colon.
* descr-text.el (describe-text-sexp):
Ditto.
* descr-text.el (describe-char-unicode-data):
Use #'split-string-by-char given that we're just looking for a
semicolon.
* descr-text.el (describe-char):
Don't fire up the regexp engine just to look for a newline.
* disass.el (disassemble-internal):
Ditto.
* files.el (file-name-sans-extension):
Implement this using #'position.
* files.el (file-name-extension):
Correct this function's docstring, implement it in terms of
#'position.
* files.el (insert-directory):
Don't fire up the regexp engine to split a string by space; don't
reverse the list of switches, this is actually a longstand bug as
far as I can see.
* gnuserv.el (gnuserv-process-filter):
Use #'position here, instead of consing inside #'split-string
needlessly.
* gtk-file-dialog.el (gtk-file-dialog-update-dropdown):
Use #'split-string-by-char here, don't fire up #'split-string for
directory-sep-char.
* gtk-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* hyper-apropos.el (hyper-apropos-grok-functions):
* hyper-apropos.el (hyper-apropos-grok-variables):
Look for a newline using #'position rather than #'string-match in
these functions.
* info.el (Info-insert-dir):
* info.el (Info-insert-file-contents):
* info.el (Info-follow-reference):
* info.el (Info-extract-menu-node-name):
* info.el (Info-menu):
Look for fixed strings using #'position or #'search as appropriate
in this file.
* ldap.el (ldap-decode-string):
* ldap.el (ldap-encode-string):
#'encode-coding-string, #'decode-coding-string are always
available, don't check if they're fboundp.
* ldap.el (ldap-decode-address):
* ldap.el (ldap-encode-address):
Use #'split-string-by-char in these functions.
* lisp-mnt.el (lm-creation-date):
* lisp-mnt.el (lm-last-modified-date):
Don't fire up the regexp engine just to look for spaces in this file.
* menubar-items.el (default-menubar):
Use (not (mismatch ...)) rather than #'string-match here, for
simple regexp.
Use (search "beta" ...) rather than (string-match "beta" ...)
* menubar-items.el (sort-buffers-menu-alphabetically):
* menubar-items.el (sort-buffers-menu-by-mode-then-alphabetically):
* menubar-items.el (group-buffers-menu-by-mode-then-alphabetically):
Don't fire up the regexp engine to check if a string starts with
a space or an asterisk.
Use the more fine-grained results of #'compare-strings; compare
case-insensitively for the buffer menu.
* menubar-items.el (list-all-buffers):
* menubar-items.el (tutorials-menu-filter):
Use #'equal rather than #'string-equal, which, in this context,
has the drawback of not having a bytecode, and no redeeming
features.
* minibuf.el:
* minibuf.el (un-substitute-in-file-name):
Use #'count, rather than counting the occurences of $ using the
regexp engine.
* minibuf.el (read-file-name-internal-1):
Don't fire up the regexp engine to search for ?=.
* mouse.el (mouse-eval-sexp):
Check for newline with #'find.
* msw-font-menu.el (mswindows-reset-device-font-menus):
Split a string by newline with #'split-string-by-char.
* mule/japanese.el:
* mule/japanese.el ("Japanese"):
Use #'search rather than #'string-match; canoncase before
comparing; fix a bug I had introduced where I had been making case
insensitive comparisons where the case mattered.
* mule/korea-util.el (default-korean-keyboard):
Look for ?3 using #'find, not #'string-march.
* mule/korea-util.el (quail-hangul-switch-hanja):
Search for a fixed string using #'search.
* mule/mule-cmds.el (set-locale-for-language-environment):
#'position, #'substitute rather than #'string-match,
#'replace-in-string.
* newcomment.el (comment-make-extra-lines):
Use #'search rather than #'string-match for a simple string.
* package-get.el (package-get-remote-filename):
Use #'position when looking for ?@
* process.el (setenv):
* process.el (read-envvar-name):
Use #'position when looking for ?=.
* replace.el (map-query-replace-regexp):
Use #'split-string-by-char instead of using an inline
implementation of it.
* select.el (select-convert-from-cf-text):
* select.el (select-convert-from-cf-unicodetext):
Use #'position rather than #'string-match in these functions.
* setup-paths.el (paths-emacs-data-root-p):
Use #'search when looking for simple string.
* sound.el (load-sound-file):
Use #'split-string-by-char rather than an inline reimplementation
of same.
* startup.el (splash-screen-window-body):
* startup.el (splash-screen-tty-body):
Search for simple strings using #'search.
* version.el (emacs-version):
Ditto.
* x-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* x-font-menu.el (x-reset-device-font-menus-core):
Use #'split-string-by-char here.
* x-init.el (x-initialize-keyboard):
Search for a simple string using #'search.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 01 Apr 2015 14:28:20 +0100 |
| parents | 0bddb59072b6 |
| children |
| 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) | |
|
5855
0bddb59072b6
Look for cased character classes when deciding on case-fold-search, #'isearch
Aidan Kehoe <kehoea@parhasard.net>
parents:
5652
diff
changeset
|
397 (and case-fold-search (no-case-regexp-p regexp)) |
| 3000 | 398 list-matching-lines-buffer-name-face |
| 399 nil list-matching-lines-face t))) | |
| 400 (let* ((bufcount (length active-bufs)) | |
| 401 (diff (- (length bufs) bufcount))) | |
| 402 (message "Searched %d buffer%s%s; %s match%s for `%s'" | |
| 403 bufcount (if (= bufcount 1) "" "s") | |
| 404 (if (zerop diff) "" (format " (%d killed)" diff)) | |
| 405 (if (zerop count) "no" (format "%d" count)) | |
| 406 (if (= count 1) "" "es") | |
| 407 regexp)) | |
| 408 (setq occur-revert-arguments (list regexp nlines bufs)) | |
| 409 (if (= count 0) | |
| 410 (kill-buffer occur-buf) | |
| 411 (display-buffer occur-buf) | |
| 412 (setq next-error-last-buffer occur-buf) | |
| 413 (setq buffer-read-only t) | |
| 414 (set-buffer-modified-p nil) | |
| 415 (run-hooks 'occur-hook))))))) | |
| 416 | |
| 417 (defun occur-engine-add-prefix (lines) | |
| 418 (mapcar | |
| 419 #'(lambda (line) | |
| 420 (concat " :" line "\n")) | |
| 421 lines)) | |
| 422 | |
| 423 (defun occur-engine (regexp buffers out-buf nlines case-fold-search | |
| 424 title-face prefix-face match-face keep-props) | |
| 425 (with-current-buffer out-buf | |
| 426 (let ((globalcount 0) | |
| 427 ;; Don't generate undo entries for creation of the initial contents. | |
| 428 (buffer-undo-list t) | |
| 429 (coding nil)) | |
| 430 ;; Map over all the buffers | |
| 431 (dolist (buf buffers) | |
| 432 (when (buffer-live-p buf) | |
| 433 (let ((matches 0) ;; count of matched lines | |
| 434 (lines 1) ;; line count | |
| 435 (matchbeg 0) | |
| 436 (origpt nil) | |
| 437 (begpt nil) | |
| 438 (endpt nil) | |
| 439 (marker nil) | |
| 440 (curstring "") | |
| 441 (headerpt (with-current-buffer out-buf (point)))) | |
| 442 (save-excursion | |
| 443 (set-buffer buf) | |
| 444 (or coding | |
| 445 ;; Set CODING only if the current buffer locally | |
| 446 ;; binds buffer-file-coding-system. | |
| 447 (not (local-variable-p 'buffer-file-coding-system (current-buffer))) | |
| 448 (setq coding buffer-file-coding-system)) | |
| 449 (save-excursion | |
| 450 (goto-char (point-min)) ;; begin searching in the buffer | |
| 451 (while (not (eobp)) | |
| 452 (setq origpt (point)) | |
| 453 (when (setq endpt (re-search-forward regexp nil t)) | |
| 454 (setq matches (1+ matches)) ;; increment match count | |
| 455 (setq matchbeg (match-beginning 0)) | |
| 456 (setq lines (+ lines (1- (count-lines origpt endpt)))) | |
| 457 (save-excursion | |
| 458 (goto-char matchbeg) | |
| 459 (setq begpt (line-beginning-position) | |
| 460 endpt (line-end-position))) | |
| 461 (setq marker (make-marker)) | |
| 462 (set-marker marker matchbeg) | |
| 463 (if (and keep-props | |
| 4103 | 464 (if-boundp 'jit-lock-mode jit-lock-mode) |
| 3000 | 465 (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
|
466 (if-fboundp 'jit-lock-fontify-now |
| 3000 | 467 (jit-lock-fontify-now begpt endpt))) |
| 468 (setq curstring (buffer-substring begpt endpt)) | |
| 469 ;; Depropertize the string, and maybe | |
| 470 ;; highlight the matches | |
| 471 (let ((len (length curstring)) | |
| 472 (start 0)) | |
| 473 (unless keep-props | |
| 474 (set-text-properties 0 len nil curstring)) | |
| 475 (while (and (< start len) | |
| 476 (string-match regexp curstring start)) | |
| 477 (add-text-properties | |
| 478 (match-beginning 0) (match-end 0) | |
| 479 (append | |
| 480 `(occur-match t) | |
| 481 (when match-face | |
| 482 ;; Use `face' rather than `font-lock-face' here | |
| 483 ;; so as to override faces copied from the buffer. | |
| 484 `(face ,match-face))) | |
| 485 curstring) | |
| 486 (setq start (match-end 0)))) | |
| 487 ;; Generate the string to insert for this match | |
| 488 (let* ((out-line | |
| 489 (concat | |
| 490 ;; Using 7 digits aligns tabs properly. | |
| 491 (apply #'propertize (format "%7d:" lines) | |
| 492 (append | |
| 493 (when prefix-face | |
| 494 `(font-lock-face prefix-face)) | |
| 495 '(occur-prefix t))) | |
| 496 ;; We don't put `mouse-face' on the newline, | |
| 497 ;; because that loses. And don't put it | |
| 498 ;; on context lines to reduce flicker. | |
| 499 (propertize curstring 'mouse-face 'highlight) | |
| 500 "\n")) | |
| 501 (data | |
| 502 (if (= nlines 0) | |
| 503 ;; The simple display style | |
| 504 out-line | |
| 505 ;; The complex multi-line display | |
| 506 ;; style. Generate a list of lines, | |
| 507 ;; concatenate them all together. | |
| 508 (apply #'concat | |
| 509 (nconc | |
| 510 (occur-engine-add-prefix (nreverse (cdr (occur-accumulate-lines (- (1+ (abs nlines))) keep-props)))) | |
| 511 (list out-line) | |
| 512 (if (> nlines 0) | |
| 513 (occur-engine-add-prefix | |
| 514 (cdr (occur-accumulate-lines (1+ nlines) keep-props))))))))) | |
| 515 ;; Actually insert the match display data | |
| 516 (with-current-buffer out-buf | |
| 517 (let ((beg (point)) | |
| 518 (end (progn (insert data) (point)))) | |
| 519 (unless (= nlines 0) | |
| 520 (insert "-------\n")) | |
| 521 (add-text-properties | |
| 522 beg end | |
| 523 `(occur-target ,marker help-echo "mouse-2: go to this occurrence"))))) | |
| 524 (goto-char endpt)) | |
| 525 (if endpt | |
| 526 (progn | |
| 527 (setq lines (1+ lines)) | |
| 528 ;; On to the next match... | |
| 529 (forward-line 1)) | |
| 530 (goto-char (point-max)))))) | |
| 531 (when (not (zerop matches)) ;; is the count zero? | |
| 532 (setq globalcount (+ globalcount matches)) | |
| 533 (with-current-buffer out-buf | |
| 534 (goto-char headerpt) | |
| 535 (let ((beg (point)) | |
| 536 end) | |
| 537 (insert (format "%d match%s for \"%s\" in buffer: %s\n" | |
| 538 matches (if (= matches 1) "" "es") | |
| 539 regexp (buffer-name buf))) | |
| 540 (setq end (point)) | |
| 541 (add-text-properties beg end | |
| 542 (append | |
| 543 (when title-face | |
| 544 `(font-lock-face ,title-face)) | |
| 545 `(occur-title ,buf)))) | |
| 546 (goto-char (point-min))))))) | |
| 547 (if coding | |
| 548 ;; CODING is buffer-file-coding-system of the first buffer | |
| 549 ;; that locally binds it. Let's use it also for the output | |
| 550 ;; buffer. | |
| 551 (set-buffer-file-coding-system coding)) | |
| 552 ;; Return the number of matches | |
| 553 globalcount))) | |
| 554 | |
| 555 (provide 'occur) |