Download
(eval-when-compile (require 'cl))
(require 'thingatpt nil t)
(when (and (require 'thingatpt+ nil t)
(fboundp 'tap-put-thing-at-point-props))
(tap-define-aliases-wo-prefix)
(tap-put-thing-at-point-props))
(require 'frame-cmds nil t)
(require 'frame-fns nil t)
(require 'fit-frame nil t)
(require 'highlight nil t)
(require 'isearch+ nil t)
(require 'menu-bar+ nil t)
(defvar occur-collect-regexp-history)
(defmacro menu-bar-make-toggle-any-version (name variable doc message help &rest body)
"Return a valid `menu-bar-make-toggle' call in Emacs 20 or later.
NAME is the name of the toggle command to define.
VARIABLE is the variable to set.
DOC is the menu-item name.
MESSAGE is the toggle message, minus status.
HELP is :help string.
BODY is the function body to use. If present, it is responsible for
setting the variable and displaying a status message (not MESSAGE)."
(if (< emacs-major-version 21)
`(menu-bar-make-toggle ,name ,variable ,doc ,message ,@body)
`(menu-bar-make-toggle ,name ,variable ,doc ,message ,help ,@body)))
(defface occur-highlight-linenum '((t (:foreground "Red")))
"*Face to use to highlight line number of visited hit lines."
:group 'matching :group 'faces)
(unless (facep 'minibuffer-prompt)
(defface minibuffer-prompt '((((background dark)) (:foreground "cyan"))
(t (:foreground "dark blue")))
"*Face for minibuffer prompts."
:group 'basic-faces))
(defvar occur-regexp nil "Search pattern used by `occur' command.")
(defvar occur-searched-buffers ()
"Source buffers searched by `occur' and `multi-occur'.")
(defcustom replace-w-completion-flag nil
"*Non-nil means use completion for `query-replace'.
You can complete to any symbol name. During completion, you can
insert a SPC or TAB char by preceding it with `\\[quoted-insert]'. If this is
inconvenient, set this option to nil."
:type 'boolean :group 'matching)
(defun toggle-replace-w-completion (force-p)
"Toggle whether to use minibuffer completion for `query-replace'.
This toggles the value of option `replace-w-completion-flag'.
During completion, you can insert a SPC or TAB char by preceding it
with `\\[quoted-insert]'.
A non-negative prefix arg means set `replace-w-completion-flag' to t.
A negative prefix arg means set it to nil."
(interactive "P")
(if force-p
(if (natnump (prefix-numeric-value force-p))
(setq replace-w-completion-flag t)
(setq replace-w-completion-flag nil))
(setq replace-w-completion-flag (not replace-w-completion-flag))))
(defcustom search/replace-2nd-sel-as-default-flag nil
"*Non-nil means use secondary selection as default for search/replace.
That is, if there is currently a nonempty secondary selection, use it
as the default input. All text properties are removed from the text.
This is used only if `search/replace-region-as-default-flag' is nil or
the region is not active."
:type 'boolean :group 'matching)
(defcustom search/replace-region-as-default-flag nil
"*Non-nil means use the active region text as default for search/replace.
That is, if the region is currently active then use its text as the
default input. All text properties are removed from the text.
Note that in this case the active region is not used to limit the
search/replacement scope. But in that case you can of course just
narrow the buffer temporarily to restrict the operation scope.
A non-nil value of this option takes precedence over the use of option
`search/replace-2nd-sel-as-default-flag'. To give that option
precedence over using the active region, you can set this option to
nil and use `region-or-non-nil-symbol-name-nearest-point' as the value
of option `search/replace-default-fn'."
:type 'boolean :group 'matching)
(defun toggle-search/replace-region-as-default (msgp)
"Toggle whether to use the active region text as default.
This toggles the value of option
`search/replace-region-as-default-flag', which affects search and
replace commands."
(interactive "p")
(setq search/replace-region-as-default-flag (not search/replace-region-as-default-flag))
(when msgp (message "Using active region text as default is now %s"
(if search/replace-region-as-default-flag "ON" "OFF"))))
(defcustom search/replace-default-fn (if (fboundp 'non-nil-symbol-name-nearest-point)
'non-nil-symbol-name-nearest-point
'word-at-point)
"*Function to provide default input for search/replacement functions.
The function is called with no arguments.
This is used by `query-replace' and related commands: `occur',
`how-many', `flush-lines', `keep-lines', etc.
Reminder: Emacs 23 and later can use multiple default values. The
function you use here can return a single string default value or a
list of such strings.
Some reasonable choices are defined in library `thingatpt+.el':
`word-nearest-point', `non-nil-symbol-name-nearest-point',
`region-or-non-nil-symbol-name-nearest-point', `sexp-nearest-point'.
If you use `region-or-non-nil-symbol-name-nearest-point' for this then
you cannot also take advantage of the use of the active region to
bound the scope of query-replace operations. But in that case you can
of course just narrow the buffer temporarily to restrict the operation
scope.
See also options `search/replace-region-as-default-flag' and
`search/replace-2nd-sel-as-default-flag'."
:type '(choice
(const :tag "No default input search/replacement functions" nil)
(function :tag "Function of 0 args to provide default for search/replace"))
:group 'matching)
(defun usable-region (&optional no-props)
"Return the region text if the region is active and nonempty.
Non-nil optional arg NO-PROPS means return the text without any
properties."
(and transient-mark-mode mark-active (/= (region-end) (region-beginning))
(if no-props
(buffer-substring-no-properties (region-beginning) (region-end))
(buffer-substring (region-beginning) (region-end)))))
(defun search/replace-default (history)
"Return a default value or list of such for search & replace functions.
A list of default input strings is computed and returned for Emacs 23
or later. For Emacs 20-22, only the first such string is returned.
The possible strings are, in order:
* The active region, if option
`search/replace-region-as-default-flag' is non-nil.
* The secondary selection, if option
`search/replace-2nd-sel-as-default-flag' is non-nil.
* The result of calling the value of option
`search/replace-default-fn', if non-nil.
* The first entry in the history list HISTORY."
(let ((selection (usable-region t))
(second-sel (and (or (not search/replace-region-as-default-flag) (not (usable-region t)))
search/replace-2nd-sel-as-default-flag
(x-get-selection 'SECONDARY))))
(when second-sel (set-text-properties 0 (length second-sel) () second-sel))
(if (> emacs-major-version 22)
(delq nil (list selection
second-sel
(and (functionp search/replace-default-fn) (funcall search/replace-default-fn))
(car (symbol-value query-replace-from-history-variable))))
(or selection
second-sel
(and (functionp search/replace-default-fn) (funcall search/replace-default-fn))
(car history)))))
(when (> emacs-major-version 21)
(defun query-replace-read-from (string regexp-flag)
"Query and return the `from' argument of a query-replace operation.
The return value can also be a pair (FROM . TO) indicating that the user
wants to replace FROM with TO.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default value.
If option `replace-w-completion-flag' is non-nil then you can complete
to a symbol name."
(if query-replace-interactive
(car (if regexp-flag regexp-search-ring search-ring))
(let* ((default (search/replace-default (symbol-value query-replace-from-history-variable)))
(lastto (car (symbol-value query-replace-to-history-variable)))
(lastfrom (car (symbol-value query-replace-from-history-variable)))
(from-prompt
(progn
(when (equal lastfrom lastto)
(setq lastfrom (cadr (symbol-value query-replace-from-history-variable))))
(if (and lastto lastfrom)
(format "%s. OLD (empty means %s -> %s): " string (query-replace-descr lastfrom)
(query-replace-descr lastto))
(concat string ". OLD: "))))
(from (save-excursion
(if replace-w-completion-flag
(completing-read from-prompt obarray nil nil nil
query-replace-from-history-variable default t)
(if query-replace-interactive
(car (if regexp-flag regexp-search-ring search-ring))
(read-from-minibuffer from-prompt nil nil nil
query-replace-from-history-variable default t))))))
(if (and (zerop (length from)) lastto lastfrom)
(cons lastfrom lastto)
(and regexp-flag
(string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\(\\\\[nt]\\)" from)
(let ((match (match-string 3 from)))
(cond
((string= match "\\n")
(message "Note: `\\n' here doesn't match a newline; to do that, type C-q C-j instead"))
((string= match "\\t")
(message "Note: `\\t' here doesn't match a tab; to do that, just type TAB")))
(sit-for 2)))
from)))))
(when (> emacs-major-version 21)
(defun query-replace-read-to (from string regexp-flag)
"Query and return the `to' argument of a query-replace operation.
See `query-replace-read-from'."
(let* ((default (search/replace-default (symbol-value query-replace-to-history-variable)))
(to-prompt (format "%s. NEW (replacing %s): " string (query-replace-descr from)))
(to (save-excursion
(if replace-w-completion-flag
(completing-read to-prompt obarray nil nil nil
query-replace-to-history-variable default t)
(read-from-minibuffer to-prompt nil nil nil
query-replace-to-history-variable default t)))))
(when (and regexp-flag (string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\\\[,#]" to))
(let (pos list char)
(while (progn (setq pos (match-end 0))
(push (substring to 0 (- pos 2)) list)
(setq char (aref to (1- pos))
to (substring to pos))
(cond ((eq char ?\#) (push '(number-to-string replace-count) list))
((eq char ?\,)
(setq pos (read-from-string to))
(push `(replace-quote ,(car pos)) list)
(let ((end (if (and (or (symbolp (car pos))
(and (eq (car-safe (car pos)) 'quote)
(not (= ?\( (aref to 0)))))
(eq (string-match " " to (cdr pos))
(cdr pos)))
(1+ (cdr pos))
(cdr pos))))
(setq to (substring to end)))))
(string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\\\[,#]" to)))
(setq to (nreverse (delete "" (cons to list)))))
(replace-match-string-symbols to)
(setq to (cons 'replace-eval-replacement (if (> (length to) 1) (cons 'concat to) (car to)))))
to)))
(unless (> emacs-major-version 21)
(defun query-replace-read-args (string regexp-flag &optional noerror)
"Read arguments for replacement functions such as `\\[query-replace]'.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default value.
Option `replace-w-completion-flag', if non-nil, provides for
minibuffer completion while you type the arguments. In that case, to
insert a `SPC' or `TAB' character, you will need to precede it by \
`\\[quoted-insert]'."
(unless noerror (barf-if-buffer-read-only))
(let* ((default (search/replace-default regexp-history))
(old-prompt (concat string ". OLD (to be replaced): "))
(oldx (if replace-w-completion-flag
(completing-read old-prompt obarray nil nil nil
query-replace-from-history-variable default t)
(if query-replace-interactive
(car (if regexp-flag regexp-search-ring search-ring))
(read-from-minibuffer old-prompt nil nil nil
query-replace-from-history-variable default t))))
(new-prompt (format "NEW (replacing %s): " oldx))
(newx (if replace-w-completion-flag
(completing-read new-prompt obarray nil nil nil
query-replace-to-history-variable default t)
(read-from-minibuffer new-prompt nil nil nil
query-replace-to-history-variable default t))))
(when (and search/replace-region-as-default-flag (usable-region t)) (deactivate-mark))
(list oldx newx current-prefix-arg))))
(when (> emacs-major-version 21)
(defun query-replace-read-args (prompt regexp-flag &optional noerror)
"Read arguments for replacement functions such as `\\[query-replace]'.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default values.
Option `replace-w-completion-flag', if non-nil, provides for
minibuffer completion while you type the arguments. In that case, to
insert a `SPC' or `TAB' character, you will need to precede it by \
`\\[quoted-insert]'."
(unless noerror
(barf-if-buffer-read-only))
(let* ((from (query-replace-read-from prompt regexp-flag))
(to (if (consp from) (prog1 (cdr from) (setq from (car from)))
(query-replace-read-to from prompt regexp-flag))))
(when (and search/replace-region-as-default-flag (usable-region t)) (deactivate-mark))
(list from to current-prefix-arg))))
(when (boundp 'menu-bar-search-replace-menu)
(define-key menu-bar-search-replace-menu [query-replace]
'(menu-item "Query String" query-replace-w-options
:help "Replace string interactively asking about each occurrence"
:enable (not buffer-read-only))))
(define-key-after menu-bar-options-menu [replace-w-completion-flag]
(menu-bar-make-toggle-any-version menu-bar-toggle-replace-w-completion replace-w-completion-flag
"Completion for Query Replace"
"Using completion with query replace is %s"
"Using completion with query replace")
'case-fold-search)
(defun query-replace-w-options (old new &optional prefix start end)
"Replace some occurrences of OLD text with NEW one.
Fourth and fifth arg START and END specify the region to operate on.
This is the same as command `query-replace', except for the treatment
of a prefix argument.
No PREFIX argument (nil) means replace literal string matches.
Non-negative PREFIX argument means replace word matches.
Negative PREFIX argument means replace regexp matches.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default values of OLD and
NEW.
Option `replace-w-completion-flag', if non-nil, provides for
minibuffer completion while you type OLD and NEW. In that case, to
insert a SPC or TAB character, you will need to precede it by \
`\\[quoted-insert]'.
If option `isearchp-set-region-flag' is non-nil, then select the last
replacement."
(interactive
(let* ((kind (cond ((and current-prefix-arg (natnump (prefix-numeric-value current-prefix-arg)))
" WORD")
(current-prefix-arg " REGEXP")
(t " STRING")))
(common (query-replace-read-args (concat "Query replace" kind) (string= " REGEXP " kind))))
(list (nth 0 common) (nth 1 common) (nth 2 common)
(and transient-mark-mode mark-active (region-beginning))
(and transient-mark-mode mark-active (region-end)))))
(let ((kind (cond ((and prefix (natnump (prefix-numeric-value prefix))) 'WORD)
(prefix 'REGEXP)
(t 'STRING))))
(case kind
(WORD
(if (< emacs-major-version 21) (query-replace old new t) (query-replace old new t start end)))
(REGEXP
(if (< emacs-major-version 21)
(query-replace-regexp old new)
(query-replace-regexp old new nil start end)))
(STRING
(if (< emacs-major-version 21) (query-replace old new) (query-replace old new nil start end))))
(when (interactive-p) (message "query-replace %s `%s' by `%s'...done" kind old new)))
(when (and (boundp 'isearchp-set-region-flag) isearchp-set-region-flag)
(isearchp-set-region-around-search-target)))
(when (> emacs-major-version 21)
(defadvice query-replace (before respect-search/replace-region-as-default-flag activate)
nil
(interactive
(let ((common
(query-replace-read-args (concat "Query replace" (and current-prefix-arg " word")
(and transient-mark-mode mark-active
(not search/replace-region-as-default-flag)
" in region"))
nil)))
(list (nth 0 common) (nth 1 common) (nth 2 common)
(and transient-mark-mode mark-active (region-beginning))
(and transient-mark-mode mark-active (region-end)))))))
(when (> emacs-major-version 21)
(defadvice query-replace-regexp (before respect-search/replace-region-as-default-flag activate)
nil
(interactive
(let ((common
(query-replace-read-args (concat "Query replace" (and current-prefix-arg " word") " regexp"
(and transient-mark-mode mark-active
(not search/replace-region-as-default-flag)
" in region"))
t)))
(list (nth 0 common) (nth 1 common) (nth 2 common)
(and transient-mark-mode mark-active (region-beginning))
(and transient-mark-mode mark-active (region-end)))))))
(when (> emacs-major-version 21)
(defadvice replace-string (before respect-search/replace-region-as-default-flag activate)
nil
(interactive
(let ((common
(query-replace-read-args (concat "Replace" (and current-prefix-arg " word") " string"
(and transient-mark-mode mark-active
(not search/replace-region-as-default-flag)
" in region"))
nil)))
(list (nth 0 common) (nth 1 common) (nth 2 common)
(and transient-mark-mode mark-active (region-beginning))
(and transient-mark-mode mark-active (region-end)))))))
(when (> emacs-major-version 21)
(defadvice replace-regexp (before respect-search/replace-region-as-default-flag activate)
nil
(interactive
(let ((common
(query-replace-read-args (concat "Replace" (and current-prefix-arg " word") " regexp"
(and transient-mark-mode mark-active
(not search/replace-region-as-default-flag)
" in region"))
t)))
(list (nth 0 common) (nth 1 common) (nth 2 common)
(and transient-mark-mode mark-active (region-beginning))
(and transient-mark-mode mark-active (region-end)))))))
(when (or (= emacs-major-version 23) (and (= emacs-major-version 24) (< emacs-minor-version 3)))
(defun read-regexp (prompt &optional defaults)
"Read and return a regular expression as a string.
Prompt with PROMPT, which should not include a final `: '.
Non-nil optional arg DEFAULTS is a string or a list of strings that
are prepended to a list of standard default values, which include the
string at point, the last isearch regexp, the last isearch string, and
the last replacement regexp."
(when (and defaults (atom defaults)) (setq defaults (list defaults)))
(let* ((deflts (append
defaults
(list (regexp-quote
(or (funcall
(or find-tag-default-function
(get major-mode 'find-tag-default-function)
'find-tag-default))
""))
(car regexp-search-ring)
(regexp-quote (or (car search-ring) ""))
(car (symbol-value query-replace-from-history-variable)))))
(deflts (delete-dups (delq nil (delete "" deflts))))
(history-add-new-input nil)
(input (read-from-minibuffer
(if defaults
(format "%s (default `%s'): " prompt
(mapconcat 'isearch-text-char-description (car deflts) ""))
(format "%s: " prompt))
nil nil nil 'regexp-history deflts t)))
(if (equal input "")
(or (car defaults) input)
(prog1 input (add-to-history 'regexp-history input))))))
(when (< emacs-major-version 21)
(defun keep-lines (regexp)
"Delete all lines after point except those with a match for REGEXP.
A match split across lines preserves all the lines it lies in.
Note that the lines are deleted, not killed to the kill-ring.
If REGEXP contains upper case characters (excluding those preceded by `\\'),
the matching is case-sensitive.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default REGEXP value."
(interactive
(list (read-from-minibuffer "Keep lines after cursor that contain a match for REGEXP: "
(search/replace-default regexp-history) nil nil 'regexp-history nil t)))
(when (interactive-p) (message "Deleting non-matching lines..."))
(save-excursion
(unless (bolp) (forward-line 1))
(let ((start (point))
(case-fold-search (and case-fold-search (isearch-no-upper-case-p regexp t))))
(while (not (eobp))
(if (not (re-search-forward regexp nil 'move))
(delete-region start (point-max))
(let ((end (save-excursion (goto-char (match-beginning 0)) (line-beginning-position))))
(when (< start end) (delete-region start end))))
(setq start (save-excursion (forward-line 1) (point)))
(and (not (eobp)) (= (match-beginning 0) (match-end 0))
(forward-char 1)))))
(when (interactive-p) (message "Deleting non-matching lines...done"))))
(when (< emacs-major-version 21)
(defun flush-lines (regexp)
"Delete lines after point that contain a match for REGEXP.
If a match is split across lines, all the lines it lies in are deleted.
Note that the lines are deleted, not killed to the kill-ring.
If REGEXP contains upper case characters (excluding those preceded by `\\'),
the matching is case-sensitive.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default REGEXP value."
(interactive
(list (read-from-minibuffer "Delete lines after cursor that contain a match for REGEXP: "
(search/replace-default regexp-history) nil nil 'regexp-history nil t)))
(when (interactive-p) (message "Deleting matching lines..."))
(let ((case-fold-search (and case-fold-search (isearch-no-upper-case-p regexp t))))
(save-excursion
(while (and (not (eobp)) (re-search-forward regexp nil t))
(delete-region (save-excursion (goto-char (match-beginning 0)) (line-beginning-position))
(progn (forward-line 1) (point))))))
(when (interactive-p) (message "Deleting matching lines...done"))))
(when (< emacs-major-version 21)
(defun how-many (regexp)
"Print number of matches for REGEXP following point.
If REGEXP contains upper case characters (excluding those preceded by `\\'),
the matching is case-sensitive.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default REGEXP value."
(interactive (list (read-from-minibuffer "Count matches after point for REGEXP: "
(search/replace-default regexp-history)
nil nil 'regexp-history nil t)))
(when (interactive-p) (message "Counting matches after point..."))
(let ((count 0)
(case-fold-search (and case-fold-search (isearch-no-upper-case-p regexp t)))
opoint)
(save-excursion
(while (and (not (eobp))
(progn (setq opoint (point))
(re-search-forward regexp nil t)))
(if (= opoint (point))
(forward-char 1)
(setq count (1+ count))))
(message "%d matches after point." count)))))
(defalias 'list-matching-lines 'occur)
(when (< emacs-major-version 21)
(defun occur (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.
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*'. This serves as a
menu to find any of the occurrences in the current buffer.
\\<occur-mode-map>\\[describe-mode] in the `*Occur*' buffer will explain how.
If REGEXP contains upper case characters (excluding those preceded by `\\'),
the matching is case-sensitive.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default REGEXP value."
(interactive
(list (let ((default (search/replace-default regexp-history)))
(read-from-minibuffer "List lines matching regexp: " nil nil nil 'regexp-history default t))
current-prefix-arg))
(setq occur-regexp regexp)
(let ((nlines (if nlines
(prefix-numeric-value nlines)
list-matching-lines-default-context-lines))
(first t)
(occur-num-matches 0)
(buffer (current-buffer))
(dir default-directory)
(linenum 1)
(prevpos (point-min))
(case-fold-search (and case-fold-search (isearch-no-upper-case-p regexp t)))
(final-context-start
(make-marker)))
(save-excursion
(goto-char (point-min))
(if (not (re-search-forward regexp nil t))
(message "No matches for `%s'" regexp)
(goto-char (match-beginning 0))
(with-output-to-temp-buffer "*Occur*"
(with-current-buffer standard-output
(save-excursion
(setq default-directory dir)
(insert " matching ")
(let ((print-escape-newlines t)) (prin1 regexp))
(insert " in buffer `" (buffer-name buffer) "'." ?\n)
(occur-mode)
(setq occur-buffer buffer
occur-nlines nlines
occur-command-arguments (list regexp nlines))))
(when (eq buffer standard-output) (goto-char (point-max)))
(save-excursion
(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)))
(match-beg
(- (match-beginning 0) start))
(match-len
(- (match-end 0) (match-beginning 0)))
(tag (format "%5d" linenum))
(empty (make-string (length tag) ?\ ))
tem
insertion-start
occur-marker
(text-beg
(make-marker))
(text-end
(make-marker)))
(save-excursion
(setq occur-marker (make-marker))
(set-marker occur-marker (point))
(set-buffer standard-output)
(setq occur-num-matches (1+ occur-num-matches))
(or first (zerop nlines) (insert "--------\n"))
(setq first nil)
(set-marker text-beg (point))
(setq insertion-start (point))
(insert-buffer-substring buffer start end)
(or (and (/= (+ start match-beg) end)
(with-current-buffer buffer (eq (char-before end) ?\n)))
(insert "\n"))
(set-marker final-context-start (+ (- (point) (- end (match-end 0)))
(if (with-current-buffer buffer
(save-excursion (goto-char (match-end 0))
(end-of-line)
(bolp)))
1 0)))
(set-marker text-end (point))
(when list-matching-lines-face
(put-text-property
(+ (marker-position text-beg) match-beg)
(+ (marker-position text-beg) match-beg match-len)
'face list-matching-lines-face))
(put-text-property
(+ (marker-position text-beg) match-beg match-len)
(+ (marker-position text-beg) match-beg match-len 1)
'occur-point t)
(goto-char insertion-start)
(setq tem (if (< linenum nlines) (- nlines linenum) nlines))
(while (> tem 0)
(insert empty ?:)
(forward-line 1)
(setq tem (1- tem)))
(let ((this-linenum linenum))
(while (< (point) final-context-start)
(when (null tag)
(setq tag (format "%5d" this-linenum)))
(insert tag ?:)
(forward-line 1)
(setq tag nil)
(incf this-linenum))
(while (and (not (eobp)) (<= (point) final-context-start))
(insert empty ?:)
(forward-line 1)
(setq this-linenum (1+ this-linenum))))
(while (and (< (point) (point-max)) (< tem nlines))
(insert empty ?:)
(forward-line 1)
(setq tem (1+ tem)))
(put-text-property (marker-position text-beg)
(- (marker-position text-end) 1)
'mouse-face 'underline)
(put-text-property (marker-position text-beg)
(marker-position text-end)
'occur occur-marker)
(goto-char (point-max)))
(forward-line 1)))
(set-buffer standard-output)
(goto-char (point-min))
(let ((message-string (if (= occur-num-matches 1)
"1 line"
(format "%d lines" occur-num-matches))))
(insert message-string)
(when (interactive-p)
(message "%s matched" message-string)))
(setq buffer-read-only t)))
(when (fboundp 'show-a-frame-on)
(show-a-frame-on "*Occur*"))
(let ((fr (and (fboundp 'get-a-frame)
(get-a-frame "*Occur*"))))
(when (and fr (fboundp 'fit-frame))
(fit-frame fr))))))))
(when (> emacs-major-version 20)
(defadvice occur (before occur-save-regexp activate compile)
(setq occur-regexp (ad-get-arg 0))))
(when (> emacs-major-version 20)
(defadvice multi-occur (before multi-occur-save-regexp activate compile)
(setq occur-regexp (ad-get-arg 1))))
(when (> emacs-major-version 20)
(defadvice multi-occur-in-matching-buffers (before multi-occur-in-matching-buffers-save-regexp
activate compile)
(setq occur-regexp (ad-get-arg 1))))
(when (> emacs-major-version 20)
(defun occur-read-primary-args ()
"Read arguments for `occur'.
See options `search/replace-region-as-default-flag',
`search/replace-2nd-sel-as-default-flag', and
`search/replace-default-fn' regarding the default regexp value."
(let* ((perform-collect (and (> emacs-major-version 23) (consp current-prefix-arg)))
(default (search/replace-default regexp-history))
(regexp (if (fboundp 'read-regexp)
(read-regexp (if perform-collect
"Collect strings matching regexp"
"List lines matching regexp")
default)
(when (consp default) (setq default (car default)))
(read-from-minibuffer
(if default
(format "List lines matching regexp (default `%s'): "
(query-replace-descr default))
"List lines matching regexp: ")
nil nil nil 'regexp-history default))))
(when (equal regexp "") (setq regexp default))
(list regexp
(if perform-collect
(if (zerop (regexp-opt-depth regexp))
"\\&"
(let ((coll-def (car occur-collect-regexp-history)))
(read-string (format "Regexp to collect (default %s): " coll-def)
nil 'occur-collect-regexp-history coll-def)))
(and current-prefix-arg (prefix-numeric-value current-prefix-arg)))))))
(defadvice occur-mode-mouse-goto (around occur-mode-mouse-goto-highlight activate compile)
"Go to the occurrence for the clicked line.
Highlight visited line number in the occur buffer.
Highlight the occur regexp in the source buffer."
(with-current-buffer (window-buffer (posn-window (event-end (ad-get-arg 0))))
(save-excursion
(goto-char (posn-point (event-end (ad-get-arg 0))))
(when (fboundp 'hlt-highlight-regexp-region)
(let ((bol (line-beginning-position)))
(hlt-highlight-regexp-region bol (save-excursion (beginning-of-line)
(search-forward ":" (+ bol 20) t)
(point))
"[0-9]+:" 'occur-highlight-linenum)))))
ad-do-it
(when (fboundp 'hlt-highlight-regexp-region)
(let ((inhibit-field-text-motion t))
(hlt-highlight-regexp-region (line-beginning-position) (line-end-position)
occur-regexp list-matching-lines-face))))
(defadvice occur-mode-goto-occurrence (around occur-mode-goto-occurrence-highlight activate compile)
"Go to the occurrence for the current line.
Highlight visited line number in the occur buffer.
Highlight the occur regexp in the source buffer."
(when (fboundp 'hlt-highlight-regexp-region)
(let ((bol (line-beginning-position)))
(hlt-highlight-regexp-region bol (save-excursion (beginning-of-line)
(search-forward ":" (+ bol 20) t)
(point))
"[0-9]+:" 'occur-highlight-linenum)))
ad-do-it
(when (fboundp 'hlt-highlight-regexp-region)
(let ((inhibit-field-text-motion t))
(hlt-highlight-regexp-region (line-beginning-position) (line-end-position)
occur-regexp list-matching-lines-face))))
(unless (> emacs-major-version 21)
(define-key occur-mode-map "o" 'occur-mode-goto-occurrence-other-window)
(define-key occur-mode-map "\C-o" 'occur-mode-display-occurrence))
(defun occur-mode-goto-occurrence-other-window ()
"Go to the occurrence for the current line, in another window.
Highlight the visited line number in the occur buffer.
Highlight the occur regexp in the source buffer."
(interactive)
(when (fboundp 'hlt-highlight-regexp-region)
(let ((bol (line-beginning-position)))
(hlt-highlight-regexp-region bol (save-excursion (beginning-of-line)
(search-forward ":" (+ bol 20) t)
(point))
"[0-9]+:" 'occur-highlight-linenum)))
(let ((pos (occur-mode-find-occurrence)))
(switch-to-buffer-other-window (marker-buffer pos))
(goto-char pos)
(when (boundp 'occur-mode-find-occurrence-hook) (run-hooks 'occur-mode-find-occurrence-hook))
(when (fboundp 'hlt-highlight-regexp-region)
(let ((inhibit-field-text-motion t))
(hlt-highlight-regexp-region (line-beginning-position) (line-end-position)
occur-regexp list-matching-lines-face)))))
(defun occur-mode-display-occurrence ()
"Display in another window the occurrence for the current line.
Highlight the visited line number in the occur buffer.
Highlight the occur regexp in the source buffer."
(interactive)
(when (fboundp 'hlt-highlight-regexp-region)
(let ((bol (line-beginning-position)))
(hlt-highlight-regexp-region bol (save-excursion (beginning-of-line)
(search-forward ":" (+ bol 20) t)
(point))
"[0-9]+:" 'occur-highlight-linenum)))
(let* ((pos (occur-mode-find-occurrence))
(window (display-buffer (marker-buffer pos) t)))
(save-selected-window
(select-window window)
(goto-char pos)
(when (fboundp 'hlt-highlight-regexp-region)
(let ((inhibit-field-text-motion t))
(hlt-highlight-regexp-region (line-beginning-position) (line-end-position)
occur-regexp list-matching-lines-face))))))
(defadvice occur-engine (after record-buffers activate)
(setq occur-searched-buffers (ad-get-arg 1)))
(defun occur-unhighlight-visited-hits (&optional msgp)
"Unhighlight visited search hits for the latest occur-mode buffer.
Non-interactively, this is a no-op without library `highlight.el'."
(interactive "p")
(when (and msgp (not (fboundp 'hlt-unhighlight-region)))
(error "`occur-unhighlight-visited-hits' requires library `highlight.el'"))
(when (and (fboundp 'hlt-unhighlight-region) (listp occur-searched-buffers))
(dolist (buf occur-searched-buffers) (with-current-buffer buf (hlt-unhighlight-region)))
(setq occur-searched-buffers ())))
(provide 'replace+)