diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index ea8b52476f7..d389f6ec0a2 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -666,6 +666,22 @@ If command is repeated at same position, delete the rectangle." (setq rect (cons row rect)))))) (nreverse rect))) +(defun cua--extract-rectangle-bounds () + (let (rect) + (if (not (cua--rectangle-virtual-edges)) + (cua--rectangle-operation nil nil nil nil nil ; do not tabify + (lambda (s e _l _r) + (setq rect (cons (cons s e) rect)))) + (cua--rectangle-operation nil 1 nil nil nil ; do not tabify + (lambda (s e l r _v) + (goto-char s) + (move-to-column l) + (setq s (point)) + (move-to-column r) + (setq e (point)) + (setq rect (cons (cons s e) rect))))) + (nreverse rect))) + (defun cua--insert-rectangle (rect &optional below paste-column line-count) ;; Insert rectangle as insert-rectangle, but don't set mark and exit with ;; point at either next to top right or below bottom left corner @@ -1394,6 +1410,8 @@ With prefix arg, indent to that column." (add-function :around region-extract-function #'cua--rectangle-region-extract) +(add-function :around region-insert-function + #'cua--insert-rectangle) (add-function :around redisplay-highlight-region-function #'cua--rectangle-highlight-for-redisplay) @@ -1405,8 +1423,12 @@ With prefix arg, indent to that column." (defun cua--rectangle-region-extract (orig &optional delete) (cond - ((not cua--rectangle) (funcall orig delete)) - ((eq delete 'delete-only) (cua--delete-rectangle)) + ((not cua--rectangle) + (funcall orig delete)) + ((eq delete 'bounds) + (cua--extract-rectangle-bounds)) + ((eq delete 'delete-only) + (cua--delete-rectangle)) (t (let* ((strs (cua--extract-rectangle)) (str (mapconcat #'identity strs "\n"))) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index af2ea56dcee..2c22483e86f 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -228,8 +228,7 @@ Blank lines separate paragraphs. Semicolons start comments. \\{emacs-lisp-mode-map}" :group 'lisp - (defvar xref-find-function) - (defvar xref-identifier-completion-table-function) + (defvar xref-backend-functions) (defvar project-library-roots-function) (lisp-mode-variables nil nil 'elisp) (add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers) @@ -239,9 +238,7 @@ Blank lines separate paragraphs. Semicolons start comments. (setq imenu-case-fold-search nil) (add-function :before-until (local 'eldoc-documentation-function) #'elisp-eldoc-documentation-function) - (setq-local xref-find-function #'elisp-xref-find) - (setq-local xref-identifier-completion-table-function - #'elisp--xref-identifier-completion-table) + (add-hook 'xref-backend-functions #'elisp--xref-backend nil t) (setq-local project-library-roots-function #'elisp-library-roots) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil 'local)) @@ -588,21 +585,7 @@ It can be quoted, or be inside a quoted form." (declare-function xref-make "xref" (summary location)) (declare-function xref-collect-references "xref" (symbol dir)) -(defun elisp-xref-find (action id) - (require 'find-func) - ;; FIXME: use information in source near point to filter results: - ;; (dvc-log-edit ...) - exclude 'feature - ;; (require 'dvc-log-edit) - only 'feature - ;; Semantic may provide additional information - (pcase action - (`definitions - (let ((sym (intern-soft id))) - (when sym - (elisp--xref-find-definitions sym)))) - (`references - (elisp--xref-find-references id)) - (`apropos - (elisp--xref-find-apropos id)))) +(defun elisp--xref-backend () 'elisp) ;; WORKAROUND: This is nominally a constant, but the text properties ;; are not preserved thru dump if use defconst. See bug#21237. @@ -638,7 +621,17 @@ Each function should return a list of xrefs, or nil; the first non-nil result supercedes the xrefs produced by `elisp--xref-find-definitions'.") -;; FIXME: name should be singular; match xref-find-definition +(cl-defmethod xref-backend-definitions ((_backend (eql elisp)) identifier) + (require 'find-func) + ;; FIXME: use information in source near point to filter results: + ;; (dvc-log-edit ...) - exclude 'feature + ;; (require 'dvc-log-edit) - only 'feature + ;; Semantic may provide additional information + ;; + (let ((sym (intern-soft identifier))) + (when sym + (elisp--xref-find-definitions sym)))) + (defun elisp--xref-find-definitions (symbol) ;; The file name is not known when `symbol' is defined via interactive eval. (let (xrefs) @@ -805,7 +798,7 @@ non-nil result supercedes the xrefs produced by (declare-function project-roots "project") (declare-function project-current "project") -(defun elisp--xref-find-references (symbol) +(cl-defmethod xref-backend-references ((_backend (eql elisp)) symbol) "Find all references to SYMBOL (a string) in the current project." (cl-mapcan (lambda (dir) @@ -815,7 +808,7 @@ non-nil result supercedes the xrefs produced by (project-roots pr) (project-library-roots pr))))) -(defun elisp--xref-find-apropos (regexp) +(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) regexp) (apply #'nconc (let (lst) (dolist (sym (apropos-internal regexp)) @@ -832,7 +825,7 @@ non-nil result supercedes the xrefs produced by (facep sym))) 'strict)) -(defun elisp--xref-identifier-completion-table () +(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql elisp))) elisp--xref-identifier-completion-table) (cl-defstruct (xref-elisp-location diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 38c5cc2bdb6..ae1aa11fbc2 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2084,17 +2084,12 @@ for \\[find-tag] (which see)." (defvar etags-xref-find-definitions-tag-order '(tag-exact-match-p tag-implicit-name-match-p) - "Tag order used in `etags-xref-find' to look for definitions.") + "Tag order used in `xref-backend-definitions' to look for definitions.") -;;;###autoload -(defun etags-xref-find (action id) - (pcase action - (`definitions (etags--xref-find-definitions id)) - (`references (etags--xref-find-references id)) - (`apropos (etags--xref-find-definitions id t)))) +(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql etags))) + (tags-lazy-completion-table)) -(defun etags--xref-find-references (symbol) - ;; TODO: Merge together with the Elisp impl. +(cl-defmethod xref-backend-references ((_backend (eql etags)) symbol) (cl-mapcan (lambda (dir) (xref-collect-references symbol dir)) @@ -2103,6 +2098,12 @@ for \\[find-tag] (which see)." (project-roots pr) (project-library-roots pr))))) +(cl-defmethod xref-backend-definitions ((_backend (eql etags)) symbol) + (etags--xref-find-definitions symbol)) + +(cl-defmethod xref-backend-apropos ((_backend (eql etags)) symbol) + (etags--xref-find-definitions symbol t)) + (defun etags--xref-find-definitions (pattern &optional regexp?) ;; This emulates the behaviour of `find-tag-in-order' but instead of ;; returning one match at a time all matches are returned as list. diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 89a06046ca2..6a3b42ff646 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -23,14 +23,21 @@ ;; referencing commands, in particular "find-definition". ;; ;; Some part of the functionality must be implemented in a language -;; dependent way and that's done by defining `xref-find-function', -;; `xref-identifier-at-point-function' and -;; `xref-identifier-completion-table-function', which see. +;; dependent way and that's done by defining an xref backend. ;; -;; A major mode should make these variables buffer-local first. +;; That consists of a constructor function, which should return a +;; backend value, and a set of implementations for the generic +;; functions: ;; -;; `xref-find-function' can be called in several ways, see its -;; description. It has to operate with "xref" and "location" values. +;; `xref-backend-identifier-at-point', +;; `xref-backend-identifier-completion-table', +;; `xref-backend-definitions', `xref-backend-references', +;; `xref-backend-apropos', which see. +;; +;; A major mode would normally use `add-hook' to add the backend +;; constructor to `xref-backend-functions'. +;; +;; The last three methods operate with "xref" and "location" values. ;; ;; One would usually call `make-xref' and `xref-make-file-location', ;; `xref-make-buffer-location' or `xref-make-bogus-location' to create @@ -38,15 +45,19 @@ ;; class inheriting from `xref-location' and implementing ;; `xref-location-group' and `xref-location-marker'. ;; +;; There's a special kind of xrefs we call "match xrefs", which +;; correspond to search results. For these values, +;; `xref-match-length' must be defined, and `xref-location-marker' +;; must return the beginning of the match. +;; ;; Each identifier must be represented as a string. Implementers can ;; use string properties to store additional information about the ;; identifier, but they should keep in mind that values returned from -;; `xref-identifier-completion-table-function' should still be +;; `xref-backend-identifier-completion-table' should still be ;; distinct, because the user can't see the properties when making the ;; choice. ;; -;; See the functions `etags-xref-find' and `elisp-xref-find' for full -;; examples. +;; See the etags and elisp-mode implementations for full examples. ;;; Code: @@ -79,8 +90,8 @@ This is typically the filename.") "Return the line number corresponding to the location." nil) -(cl-defgeneric xref-match-bounds (_item) - "Return a cons with columns of the beginning and end of the match." +(cl-defgeneric xref-match-length (_item) + "Return the length of the match." nil) ;;;; Commonly needed location classes are defined here: @@ -109,7 +120,7 @@ Line numbers start from 1 and columns from 0.") (save-excursion (goto-char (point-min)) (beginning-of-line line) - (move-to-column column) + (forward-char column) (point-marker)))))) (cl-defmethod xref-location-group ((l xref-file-location)) @@ -176,55 +187,60 @@ LOCATION is an `xref-location'." (location :initarg :location :type xref-file-location :reader xref-item-location) - (end-column :initarg :end-column)) - :comment "An xref item describes a reference to a location -somewhere.") + (length :initarg :length :reader xref-match-length)) + :comment "A match xref item describes a search result.") -(cl-defmethod xref-match-bounds ((i xref-match-item)) - (with-slots (end-column location) i - (cons (xref-file-location-column location) - end-column))) - -(defun xref-make-match (summary end-column location) +(defun xref-make-match (summary location length) "Create and return a new `xref-match-item'. SUMMARY is a short string to describe the xref. -END-COLUMN is the match end column number inside SUMMARY. -LOCATION is an `xref-location'." - (make-instance 'xref-match-item :summary summary :location location - :end-column end-column)) +LOCATION is an `xref-location'. +LENGTH is the match length, in characters." + (make-instance 'xref-match-item :summary summary + :location location :length length)) ;;; API -(declare-function etags-xref-find "etags" (action id)) -(declare-function tags-lazy-completion-table "etags" ()) +;; We make the etags backend the default for now, until something +;; better comes along. +(defvar xref-backend-functions (list #'xref--etags-backend) + "Special hook to find the xref backend for the current context. +Each functions on this hook is called in turn with no arguments +and should return either nil to mean that it is not applicable, +or an xref backend, which is a value to be used to dispatch the +generic functions.") -;; For now, make the etags backend the default. -(defvar xref-find-function #'etags-xref-find - "Function to look for cross-references. -It can be called in several ways: +(defun xref-find-backend () + (run-hook-with-args-until-success 'xref-backend-functions)) - (definitions IDENTIFIER): Find definitions of IDENTIFIER. The -result must be a list of xref objects. If IDENTIFIER contains -sufficient information to determine a unique definition, returns -only that definition. If there are multiple possible definitions, -return all of them. If no definitions can be found, return nil. +(defun xref--etags-backend () 'etags) - (references IDENTIFIER): Find references of IDENTIFIER. The -result must be a list of xref objects. If no references can be -found, return nil. +(cl-defgeneric xref-backend-definitions (backend identifier) + "Find definitions of IDENTIFIER. - (apropos PATTERN): Find all symbols that match PATTERN. PATTERN -is a regexp. +The result must be a list of xref objects. If IDENTIFIER +contains sufficient information to determine a unique definition, +return only that definition. If there are multiple possible +definitions, return all of them. If no definitions can be found, +return nil. IDENTIFIER can be any string returned by -`xref-identifier-at-point-function', or from the table returned -by `xref-identifier-completion-table-function'. +`xref-backend-identifier-at-point', or from the table returned by +`xref-backend-identifier-completion-table'. To create an xref object, call `xref-make'.") -(defvar xref-identifier-at-point-function #'xref-default-identifier-at-point - "Function to get the relevant identifier at point. +(cl-defgeneric xref-backend-references (backend identifier) + "Find references of IDENTIFIER. +The result must be a list of xref objects. If no references can +be found, return nil.") + +(cl-defgeneric xref-backend-apropos (backend pattern) + "Find all symbols that match PATTERN. +PATTERN is a regexp") + +(cl-defgeneric xref-backend-identifier-at-point (_backend) + "Return the relevant identifier at point. The return value must be a string or nil. nil means no identifier at point found. @@ -232,16 +248,14 @@ identifier at point found. If it's hard to determine the identifier precisely (e.g., because it's a method call on unknown type), the implementation can return a simple string (such as symbol at point) marked with a -special text property which `xref-find-function' would recognize -and then delegate the work to an external process.") - -(defvar xref-identifier-completion-table-function #'tags-lazy-completion-table - "Function that returns the completion table for identifiers.") - -(defun xref-default-identifier-at-point () +special text property which e.g. `xref-backend-definitions' would +recognize and then delegate the work to an external process." (let ((thing (thing-at-point 'symbol))) (and thing (substring-no-properties thing)))) +(cl-defgeneric xref-backend-identifier-completion-table (backend) + "Returns the completion table for identifiers.") + ;;; misc utilities (defun xref--alistify (list key test) @@ -345,22 +359,14 @@ elements is negated." (pcase-let ((`(,beg . ,end) (save-excursion (or - (xref--match-buffer-bounds xref--current-item) + (let ((length (xref-match-length xref--current-item))) + (and length (cons (point) (+ (point) length)))) (back-to-indentation) (if (eolp) (cons (line-beginning-position) (1+ (point))) (cons (point) (line-end-position))))))) (pulse-momentary-highlight-region beg end 'next-error))) -(defun xref--match-buffer-bounds (item) - (save-excursion - (let ((bounds (xref-match-bounds item))) - (when bounds - (cons (progn (move-to-column (car bounds)) - (point)) - (progn (move-to-column (cdr bounds)) - (point))))))) - ;; etags.el needs this (defun xref-clear-marker-stack () "Discard all markers from the marker stack." @@ -487,50 +493,54 @@ WINDOW controls how the buffer is displayed: (progn (save-excursion (goto-char (point-min)) - ;; TODO: Check that none of the matches are out of date; - ;; offer to re-scan otherwise. Note that saving the last - ;; modification tick won't work, as long as not all of the - ;; buffers are kept open. (while (setq item (xref--search-property 'xref-item)) - (when (xref-match-bounds item) + (when (xref-match-length item) (save-excursion - ;; FIXME: Get rid of xref--goto-location, by making - ;; xref-match-bounds return markers already. - (xref--goto-location (xref-item-location item)) - (let ((bounds (xref--match-buffer-bounds item)) - (beg (make-marker)) - (end (make-marker))) - (move-marker beg (car bounds)) - (move-marker end (cdr bounds)) - (push (cons beg end) pairs))))) + (let* ((loc (xref-item-location item)) + (beg (xref-location-marker loc)) + (len (xref-match-length item))) + ;; Perform sanity check first. + (xref--goto-location loc) + ;; FIXME: The check should probably be a generic + ;; function, instead of the assumption that all + ;; matches contain the full line as summary. + ;; TODO: Offer to re-scan otherwise. + (unless (equal (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + (xref-item-summary item)) + (user-error "Search results out of date")) + (push (cons beg len) pairs))))) (setq pairs (nreverse pairs))) (unless pairs (user-error "No suitable matches here")) (xref--query-replace-1 from to pairs)) (dolist (pair pairs) - (move-marker (car pair) nil) - (move-marker (cdr pair) nil))))) + (move-marker (car pair) nil))))) +;; FIXME: Write a nicer UI. (defun xref--query-replace-1 (from to pairs) (let* ((query-replace-lazy-highlight nil) - current-pair current-buf + current-beg current-len current-buf ;; Counteract the "do the next match now" hack in ;; `perform-replace'. And still, it'll report that those ;; matches were "filtered out" at the end. (isearch-filter-predicate (lambda (beg end) - (and current-pair + (and current-beg (eq (current-buffer) current-buf) - (>= beg (car current-pair)) - (<= end (cdr current-pair))))) + (>= beg current-beg) + (<= end (+ current-beg current-len))))) (replace-re-search-function (lambda (from &optional _bound noerror) - (let (found) + (let (found pair) (while (and (not found) pairs) - (setq current-pair (pop pairs) - current-buf (marker-buffer (car current-pair))) + (setq pair (pop pairs) + current-beg (car pair) + current-len (cdr pair) + current-buf (marker-buffer current-beg)) (pop-to-buffer current-buf) - (goto-char (car current-pair)) - (when (re-search-forward from (cdr current-pair) noerror) + (goto-char current-beg) + (when (re-search-forward from (+ current-beg current-len) noerror) (setq found t))) found)))) ;; FIXME: Despite this being a multi-buffer replacement, `N' @@ -695,7 +705,8 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (defun xref--read-identifier (prompt) "Return the identifier at point or read it from the minibuffer." - (let ((id (funcall xref-identifier-at-point-function))) + (let* ((backend (xref-find-backend)) + (id (xref-backend-identifier-at-point backend))) (cond ((or current-prefix-arg (not id) (xref--prompt-p this-command)) @@ -705,7 +716,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." "[ :]+\\'" prompt)) id) prompt) - (funcall xref-identifier-completion-table-function) + (xref-backend-identifier-completion-table backend) nil nil nil 'xref--read-identifier-history id)) (t id)))) @@ -714,7 +725,9 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." ;;; Commands (defun xref--find-xrefs (input kind arg window) - (let ((xrefs (funcall xref-find-function kind arg))) + (let ((xrefs (funcall (intern (format "xref-backend-%s" kind)) + (xref-find-backend) + arg))) (unless xrefs (user-error "No %s found for: %s" (symbol-name kind) input)) (xref--show-xrefs xrefs window))) @@ -799,14 +812,9 @@ and just use etags." :lighter "" (if xref-etags-mode (progn - (setq xref-etags-mode--saved - (cons xref-find-function - xref-identifier-completion-table-function)) - (kill-local-variable 'xref-find-function) - (kill-local-variable 'xref-identifier-completion-table-function)) - (setq-local xref-find-function (car xref-etags-mode--saved)) - (setq-local xref-identifier-completion-table-function - (cdr xref-etags-mode--saved)))) + (setq xref-etags-mode--saved xref-backend-functions) + (kill-local-variable 'xref-backend-functions)) + (setq-local xref-backend-functions xref-etags-mode--saved))) (declare-function semantic-symref-find-references-by-name "semantic/symref") (declare-function semantic-find-file-noselect "semantic/fw") @@ -826,10 +834,11 @@ tools are used, and when." (hits (and res (oref res hit-lines))) (orig-buffers (buffer-list))) (unwind-protect - (delq nil - (mapcar (lambda (hit) (xref--collect-match - hit (format "\\_<%s\\_>" (regexp-quote symbol)))) - hits)) + (cl-mapcan (lambda (hit) (xref--collect-matches + hit (format "\\_<%s\\_>" (regexp-quote symbol)))) + hits) + ;; TODO: Implement "lightweight" buffer visiting, so that we + ;; don't have to kill them. (mapc #'kill-buffer (cl-set-difference (buffer-list) orig-buffers))))) @@ -860,9 +869,9 @@ IGNORES is a list of glob patterns." (match-string 1)) hits))) (unwind-protect - (delq nil - (mapcar (lambda (hit) (xref--collect-match hit regexp)) - (nreverse hits))) + (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp)) + (nreverse hits)) + ;; TODO: Same as above. (mapc #'kill-buffer (cl-set-difference (buffer-list) orig-buffers))))) @@ -918,7 +927,7 @@ IGNORES is a list of glob patterns." (match-string 1 str))))) str t t)) -(defun xref--collect-match (hit regexp) +(defun xref--collect-matches (hit regexp) (pcase-let* ((`(,line . ,file) hit) (buf (or (find-buffer-visiting file) (semantic-find-file-noselect file)))) @@ -926,18 +935,22 @@ IGNORES is a list of glob patterns." (save-excursion (goto-char (point-min)) (forward-line (1- line)) - (syntax-propertize (line-end-position)) - ;; TODO: Handle multiple matches per line. - (when (re-search-forward regexp (line-end-position) t) - (goto-char (match-beginning 0)) - (let ((loc (xref-make-file-location file line - (current-column)))) - (goto-char (match-end 0)) - (xref-make-match (buffer-substring - (line-beginning-position) - (line-end-position)) - (current-column) - loc))))))) + (let ((line-end (line-end-position)) + (line-beg (line-beginning-position)) + matches) + (syntax-propertize line-end) + ;; FIXME: This results in several lines with the same + ;; summary. Solve with composite pattern? + (while (re-search-forward regexp line-end t) + (let* ((beg-column (- (match-beginning 0) line-beg)) + (end-column (- (match-end 0) line-beg)) + (loc (xref-make-file-location file line beg-column)) + (summary (buffer-substring line-beg line-end))) + (add-face-text-property beg-column end-column 'highlight + t summary) + (push (xref-make-match summary loc (- end-column beg-column)) + matches))) + (nreverse matches)))))) (provide 'xref) diff --git a/lisp/rect.el b/lisp/rect.el index acd3a48f2da..46ebbf259cf 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -257,6 +257,19 @@ Return it as a list of strings, one for each line of the rectangle." (apply-on-rectangle 'extract-rectangle-line start end lines) (nreverse (cdr lines)))) +(defun extract-rectangle-bounds (start end) + "Return the bounds of the rectangle with corners at START and END. +Return it as a list of (START . END) positions, one for each line of +the rectangle." + (let (bounds) + (apply-on-rectangle + (lambda (startcol endcol) + (move-to-column startcol) + (push (cons (prog1 (point) (move-to-column endcol)) (point)) + bounds)) + start end) + (nreverse bounds))) + (defvar killed-rectangle nil "Rectangle for `yank-rectangle' to insert.") @@ -563,6 +576,8 @@ with a prefix argument, prompt for START-AT and FORMAT." #'rectangle--unhighlight-for-redisplay) (add-function :around region-extract-function #'rectangle--extract-region) +(add-function :around region-insert-function + #'rectangle--insert-region) (defvar rectangle-mark-mode-map (let ((map (make-sparse-keymap))) @@ -681,8 +696,12 @@ Ignores `line-move-visual'." (defun rectangle--extract-region (orig &optional delete) - (if (not rectangle-mark-mode) - (funcall orig delete) + (cond + ((not rectangle-mark-mode) + (funcall orig delete)) + ((eq delete 'bounds) + (extract-rectangle-bounds (region-beginning) (region-end))) + (t (let* ((strs (funcall (if delete #'delete-extract-rectangle #'extract-rectangle) @@ -696,7 +715,14 @@ Ignores `line-move-visual'." (put-text-property 0 (length str) 'yank-handler `(rectangle--insert-for-yank ,strs t) str) - str)))) + str))))) + +(defun rectangle--insert-region (orig strings) + (cond + ((not rectangle-mark-mode) + (funcall orig strings)) + (t + (funcall #'insert-rectangle strings)))) (defun rectangle--insert-for-yank (strs) (push (point) buffer-undo-list) diff --git a/lisp/replace.el b/lisp/replace.el index d6590c5516a..b6802aeaf57 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -284,7 +284,7 @@ the original string if not." (and current-prefix-arg (not (eq current-prefix-arg '-))) (and current-prefix-arg (eq current-prefix-arg '-))))) -(defun query-replace (from-string to-string &optional delimited start end backward) +(defun query-replace (from-string to-string &optional delimited start end backward region-noncontiguous-p) "Replace some occurrences of FROM-STRING with TO-STRING. As each match is found, the user must type a character saying what to do with it. For directions, type \\[help-command] at that time. @@ -328,22 +328,21 @@ To customize possible responses, change the bindings in `query-replace-map'." (if current-prefix-arg (if (eq current-prefix-arg '-) " backward" " word") "") - (if (and transient-mark-mode mark-active) " in region" "")) + (if (use-region-p) " in region" "")) nil))) (list (nth 0 common) (nth 1 common) (nth 2 common) ;; These are done separately here ;; so that command-history will record these expressions ;; rather than the values they had this time. - (if (and transient-mark-mode mark-active) - (region-beginning)) - (if (and transient-mark-mode mark-active) - (region-end)) - (nth 3 common)))) - (perform-replace from-string to-string t nil delimited nil nil start end backward)) + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)) + (nth 3 common) + (if (use-region-p) (region-noncontiguous-p))))) + (perform-replace from-string to-string t nil delimited nil nil start end backward region-noncontiguous-p)) (define-key esc-map "%" 'query-replace) -(defun query-replace-regexp (regexp to-string &optional delimited start end backward) +(defun query-replace-regexp (regexp to-string &optional delimited start end backward region-noncontiguous-p) "Replace some things after point matching REGEXP with TO-STRING. As each match is found, the user must type a character saying what to do with it. For directions, type \\[help-command] at that time. @@ -408,18 +407,17 @@ Use \\[repeat-complex-command] after this command for details." (if (eq current-prefix-arg '-) " backward" " word") "") " regexp" - (if (and transient-mark-mode mark-active) " in region" "")) + (if (use-region-p) " in region" "")) t))) (list (nth 0 common) (nth 1 common) (nth 2 common) ;; These are done separately here ;; so that command-history will record these expressions ;; rather than the values they had this time. - (if (and transient-mark-mode mark-active) - (region-beginning)) - (if (and transient-mark-mode mark-active) - (region-end)) - (nth 3 common)))) - (perform-replace regexp to-string t t delimited nil nil start end backward)) + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)) + (nth 3 common) + (if (use-region-p) (region-noncontiguous-p))))) + (perform-replace regexp to-string t t delimited nil nil start end backward region-noncontiguous-p)) (define-key esc-map [?\C-%] 'query-replace-regexp) @@ -485,10 +483,8 @@ for Lisp calls." "22.1")) ;; and the user might enter a single token. (replace-match-string-symbols to) (list from (car to) current-prefix-arg - (if (and transient-mark-mode mark-active) - (region-beginning)) - (if (and transient-mark-mode mark-active) - (region-end)))))) + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)))))) (perform-replace regexp (cons 'replace-eval-replacement to-expr) t 'literal delimited nil nil start end)) @@ -523,10 +519,8 @@ Fourth and fifth arg START and END specify the region to operate on." (list from to (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) - (if (and transient-mark-mode mark-active) - (region-beginning)) - (if (and transient-mark-mode mark-active) - (region-end))))) + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end))))) (let (replacements) (if (listp to-strings) (setq replacements to-strings) @@ -587,13 +581,11 @@ and TO-STRING is also null.)" (if (eq current-prefix-arg '-) " backward" " word") "") " string" - (if (and transient-mark-mode mark-active) " in region" "")) + (if (use-region-p) " in region" "")) nil))) (list (nth 0 common) (nth 1 common) (nth 2 common) - (if (and transient-mark-mode mark-active) - (region-beginning)) - (if (and transient-mark-mode mark-active) - (region-end)) + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)) (nth 3 common)))) (perform-replace from-string to-string nil nil delimited nil nil start end backward)) @@ -661,13 +653,11 @@ which will run faster and will not set the mark or print anything." (if (eq current-prefix-arg '-) " backward" " word") "") " regexp" - (if (and transient-mark-mode mark-active) " in region" "")) + (if (use-region-p) " in region" "")) t))) (list (nth 0 common) (nth 1 common) (nth 2 common) - (if (and transient-mark-mode mark-active) - (region-beginning)) - (if (and transient-mark-mode mark-active) - (region-end)) + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)) (nth 3 common)))) (perform-replace regexp to-string nil t delimited nil nil start end backward)) @@ -832,7 +822,7 @@ a previously found match." (unless (or (bolp) (eobp)) (forward-line 0)) (point-marker))))) - (if (and interactive transient-mark-mode mark-active) + (if (and interactive (use-region-p)) (setq rstart (region-beginning) rend (progn (goto-char (region-end)) @@ -901,7 +891,7 @@ starting on the same line at which another match ended is ignored." (progn (goto-char (min rstart rend)) (setq rend (copy-marker (max rstart rend)))) - (if (and interactive transient-mark-mode mark-active) + (if (and interactive (use-region-p)) (setq rstart (region-beginning) rend (copy-marker (region-end))) (setq rstart (point) @@ -951,7 +941,7 @@ a previously found match." (setq rend (max rstart rend))) (goto-char rstart) (setq rend (point-max))) - (if (and interactive transient-mark-mode mark-active) + (if (and interactive (use-region-p)) (setq rstart (region-beginning) rend (region-end)) (setq rstart (point) @@ -2068,7 +2058,7 @@ It is called with three arguments, as if it were (defun perform-replace (from-string replacements query-flag regexp-flag delimited-flag - &optional repeat-count map start end backward) + &optional repeat-count map start end backward region-noncontiguous-p) "Subroutine of `query-replace'. Its complexity handles interactive queries. Don't use this in your own program unless you want to query and set the mark just as `query-replace' does. Instead, write a simple loop like this: @@ -2115,6 +2105,9 @@ It must return a string." ;; If non-nil, it is marker saying where in the buffer to stop. (limit nil) + ;; Use local binding in add-function below. + (isearch-filter-predicate isearch-filter-predicate) + (region-bounds nil) ;; Data for the next match. If a cons, it has the same format as ;; (match-data); otherwise it is t if a match is possible at point. @@ -2127,6 +2120,24 @@ It must return a string." "Query replacing %s with %s: (\\\\[help] for help) ") minibuffer-prompt-properties)))) + ;; Unless a single contiguous chunk is selected, operate on multiple chunks. + (when region-noncontiguous-p + (setq region-bounds + (mapcar (lambda (position) + (cons (copy-marker (car position)) + (copy-marker (cdr position)))) + (funcall region-extract-function 'bounds))) + (add-function :after-while isearch-filter-predicate + (lambda (start end) + (delq nil (mapcar + (lambda (bounds) + (and + (>= start (car bounds)) + (<= start (cdr bounds)) + (>= end (car bounds)) + (<= end (cdr bounds)))) + region-bounds))))) + ;; If region is active, in Transient Mark mode, operate on region. (if backward (when end diff --git a/lisp/simple.el b/lisp/simple.el index b115a2a0cbb..deb5c888c92 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -970,15 +970,34 @@ instead of deleted." (defvar region-extract-function (lambda (delete) (when (region-beginning) - (if (eq delete 'delete-only) - (delete-region (region-beginning) (region-end)) - (filter-buffer-substring (region-beginning) (region-end) delete)))) + (cond + ((eq delete 'bounds) + (list (cons (region-beginning) (region-end)))) + ((eq delete 'delete-only) + (delete-region (region-beginning) (region-end))) + (t + (filter-buffer-substring (region-beginning) (region-end) delete))))) "Function to get the region's content. Called with one argument DELETE. If DELETE is `delete-only', then only delete the region and the return value is undefined. If DELETE is nil, just return the content as a string. +If DELETE is `bounds', then don't delete, but just return the +boundaries of the region as a list of (START . END) positions. If anything else, delete the region and return its content as a string.") +(defvar region-insert-function + (lambda (lines) + (let ((first t)) + (while lines + (or first + (insert ?\n)) + (insert-for-yank (car lines)) + (setq lines (cdr lines) + first nil)))) + "Function to insert the region's content. +Called with one argument LINES. +Insert the region as a list of lines.") + (defun delete-backward-char (n &optional killflag) "Delete the previous N characters (following if N is negative). If Transient Mark mode is enabled, the mark is active, and N is 1, @@ -3419,7 +3438,8 @@ and only used if a buffer is displayed." (defun shell-command-on-region (start end command &optional output-buffer replace - error-buffer display-error-buffer) + error-buffer display-error-buffer + region-noncontiguous-p) "Execute string COMMAND in inferior shell with region as input. Normally display output (if any) in temp buffer `*Shell Command Output*'; Prefix arg means replace the region with it. Return the exit code of @@ -3482,7 +3502,8 @@ interactively, this is t." current-prefix-arg current-prefix-arg shell-command-default-error-buffer - t))) + t + (region-noncontiguous-p)))) (let ((error-file (if error-buffer (make-temp-file @@ -3491,96 +3512,109 @@ interactively, this is t." temporary-file-directory))) nil)) exit-status) - (if (or replace - (and output-buffer - (not (or (bufferp output-buffer) (stringp output-buffer))))) - ;; Replace specified region with output from command. - (let ((swap (and replace (< start end)))) - ;; Don't muck with mark unless REPLACE says we should. - (goto-char start) - (and replace (push-mark (point) 'nomsg)) - (setq exit-status - (call-process-region start end shell-file-name replace - (if error-file - (list t error-file) - t) - nil shell-command-switch command)) - ;; It is rude to delete a buffer which the command is not using. - ;; (let ((shell-buffer (get-buffer "*Shell Command Output*"))) - ;; (and shell-buffer (not (eq shell-buffer (current-buffer))) - ;; (kill-buffer shell-buffer))) - ;; Don't muck with mark unless REPLACE says we should. - (and replace swap (exchange-point-and-mark))) - ;; No prefix argument: put the output in a temp buffer, - ;; replacing its entire contents. - (let ((buffer (get-buffer-create - (or output-buffer "*Shell Command Output*")))) - (unwind-protect - (if (eq buffer (current-buffer)) - ;; If the input is the same buffer as the output, - ;; delete everything but the specified region, - ;; then replace that region with the output. - (progn (setq buffer-read-only nil) - (delete-region (max start end) (point-max)) - (delete-region (point-min) (min start end)) - (setq exit-status - (call-process-region (point-min) (point-max) - shell-file-name t - (if error-file - (list t error-file) - t) - nil shell-command-switch - command))) - ;; Clear the output buffer, then run the command with - ;; output there. - (let ((directory default-directory)) - (with-current-buffer buffer - (setq buffer-read-only nil) - (if (not output-buffer) - (setq default-directory directory)) - (erase-buffer))) - (setq exit-status - (call-process-region start end shell-file-name nil - (if error-file - (list buffer error-file) - buffer) - nil shell-command-switch command))) - ;; Report the output. - (with-current-buffer buffer - (setq mode-line-process - (cond ((null exit-status) - " - Error") - ((stringp exit-status) - (format " - Signal [%s]" exit-status)) - ((not (equal 0 exit-status)) - (format " - Exit [%d]" exit-status))))) - (if (with-current-buffer buffer (> (point-max) (point-min))) - ;; There's some output, display it - (display-message-or-buffer buffer) - ;; No output; error? - (let ((output - (if (and error-file - (< 0 (nth 7 (file-attributes error-file)))) - (format "some error output%s" - (if shell-command-default-error-buffer - (format " to the \"%s\" buffer" - shell-command-default-error-buffer) - "")) - "no output"))) - (cond ((null exit-status) - (message "(Shell command failed with error)")) - ((equal 0 exit-status) - (message "(Shell command succeeded with %s)" - output)) - ((stringp exit-status) - (message "(Shell command killed by signal %s)" - exit-status)) - (t - (message "(Shell command failed with code %d and %s)" - exit-status output)))) - ;; Don't kill: there might be useful info in the undo-log. - ;; (kill-buffer buffer) - )))) + ;; Unless a single contiguous chunk is selected, operate on multiple chunks. + (if region-noncontiguous-p + (let ((input (concat (funcall region-extract-function 'delete) "\n")) + output) + (with-temp-buffer + (insert input) + (call-process-region (point-min) (point-max) + shell-file-name t t + nil shell-command-switch + command) + (setq output (split-string (buffer-string) "\n"))) + (goto-char start) + (funcall region-insert-function output)) + (if (or replace + (and output-buffer + (not (or (bufferp output-buffer) (stringp output-buffer))))) + ;; Replace specified region with output from command. + (let ((swap (and replace (< start end)))) + ;; Don't muck with mark unless REPLACE says we should. + (goto-char start) + (and replace (push-mark (point) 'nomsg)) + (setq exit-status + (call-process-region start end shell-file-name replace + (if error-file + (list t error-file) + t) + nil shell-command-switch command)) + ;; It is rude to delete a buffer which the command is not using. + ;; (let ((shell-buffer (get-buffer "*Shell Command Output*"))) + ;; (and shell-buffer (not (eq shell-buffer (current-buffer))) + ;; (kill-buffer shell-buffer))) + ;; Don't muck with mark unless REPLACE says we should. + (and replace swap (exchange-point-and-mark))) + ;; No prefix argument: put the output in a temp buffer, + ;; replacing its entire contents. + (let ((buffer (get-buffer-create + (or output-buffer "*Shell Command Output*")))) + (unwind-protect + (if (eq buffer (current-buffer)) + ;; If the input is the same buffer as the output, + ;; delete everything but the specified region, + ;; then replace that region with the output. + (progn (setq buffer-read-only nil) + (delete-region (max start end) (point-max)) + (delete-region (point-min) (min start end)) + (setq exit-status + (call-process-region (point-min) (point-max) + shell-file-name t + (if error-file + (list t error-file) + t) + nil shell-command-switch + command))) + ;; Clear the output buffer, then run the command with + ;; output there. + (let ((directory default-directory)) + (with-current-buffer buffer + (setq buffer-read-only nil) + (if (not output-buffer) + (setq default-directory directory)) + (erase-buffer))) + (setq exit-status + (call-process-region start end shell-file-name nil + (if error-file + (list buffer error-file) + buffer) + nil shell-command-switch command))) + ;; Report the output. + (with-current-buffer buffer + (setq mode-line-process + (cond ((null exit-status) + " - Error") + ((stringp exit-status) + (format " - Signal [%s]" exit-status)) + ((not (equal 0 exit-status)) + (format " - Exit [%d]" exit-status))))) + (if (with-current-buffer buffer (> (point-max) (point-min))) + ;; There's some output, display it + (display-message-or-buffer buffer) + ;; No output; error? + (let ((output + (if (and error-file + (< 0 (nth 7 (file-attributes error-file)))) + (format "some error output%s" + (if shell-command-default-error-buffer + (format " to the \"%s\" buffer" + shell-command-default-error-buffer) + "")) + "no output"))) + (cond ((null exit-status) + (message "(Shell command failed with error)")) + ((equal 0 exit-status) + (message "(Shell command succeeded with %s)" + output)) + ((stringp exit-status) + (message "(Shell command killed by signal %s)" + exit-status)) + (t + (message "(Shell command failed with code %d and %s)" + exit-status output)))) + ;; Don't kill: there might be useful info in the undo-log. + ;; (kill-buffer buffer) + ))))) (when (and error-file (file-exists-p error-file)) (if (< 0 (nth 7 (file-attributes error-file))) @@ -5175,6 +5209,11 @@ also checks the value of `use-empty-active-region'." ;; region is active when there's no mark. (progn (cl-assert (mark)) t))) +(defun region-noncontiguous-p () + "Return non-nil if the region contains several pieces. +An example is a rectangular region handled as a list of +separate contiguous regions for each line." + (> (length (funcall region-extract-function 'bounds)) 1)) (defvar redisplay-unhighlight-region-function (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 464e3754eb9..f4d7fe7d9aa 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -1821,7 +1821,7 @@ With a prefix argument, try to REVERSE the hunk." "Kill all hunks that have already been applied starting at point." (interactive) (while (not (eobp)) - (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) + (pcase-let ((`(,_buf ,line-offset ,_pos ,_src ,_dst ,switched) (diff-find-source-location nil nil))) (if (and line-offset switched) (diff-hunk-kill) diff --git a/src/casefiddle.c b/src/casefiddle.c index b94ea8e212e..6a2983ef018 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -306,14 +306,30 @@ See also `capitalize-region'. */) return Qnil; } -DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r", +DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 3, + "(list (region-beginning) (region-end) (region-noncontiguous-p))", doc: /* Convert the region to lower case. In programs, wants two arguments. These arguments specify the starting and ending character numbers of the region to operate on. When used as a command, the text between point and the mark is operated on. */) - (Lisp_Object beg, Lisp_Object end) + (Lisp_Object beg, Lisp_Object end, Lisp_Object region_noncontiguous_p) { - casify_region (CASE_DOWN, beg, end); + Lisp_Object bounds = Qnil; + + if (!NILP (region_noncontiguous_p)) + { + bounds = call1 (Fsymbol_value (intern ("region-extract-function")), + intern ("bounds")); + + while (CONSP (bounds)) + { + casify_region (CASE_DOWN, XCAR (XCAR (bounds)), XCDR (XCAR (bounds))); + bounds = XCDR (bounds); + } + } + else + casify_region (CASE_DOWN, beg, end); + return Qnil; }