Mercurial > hg > xemacs-beta

comparison lisp/prim/replace.el @ 72:b9518feda344 r20-0b31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b31
author cvs
date Mon, 13 Aug 2007 09:03:46 +0200
parents 131b0175ea99
children 54cc21c15cbb
comparison
equal deleted inserted replaced
71:bae944334fa4 72:b9518feda344
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;; General Public License for more details. 15 ;; General Public License for more details.
16 16
17 ;; You should have received a copy of the GNU General Public License 17 ;; You should have received a copy of the GNU General Public License
18 ;; along with XEmacs; see the file COPYING. If not, write to the 18 ;; along with XEmacs; see the file COPYING. If not, write to the Free
19 ;; Free Software Foundation, 59 Temple Place - Suite 330, 19 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
20 ;; Boston, MA 02111-1307, USA. 20 ;; 02111-1307, USA.
21 21
22 ;;; Synched up with: FSF 19.30. 22 ;;; Synched up with: FSF 19.34 [Partially].
23 23
24 ;;; Commentary: 24 ;;; Commentary:
25 25
26 ;; This package supplies the string and regular-expression replace functions 26 ;; This package supplies the string and regular-expression replace functions
27 ;; documented in the XEmacs Reference Manual. 27 ;; documented in the XEmacs Reference Manual.
28 28
29 ;; All the gettext calls are for XEmacs I18N3 message catalog support.
30
29 ;;; Code: 31 ;;; Code:
30 32
31 (defvar case-replace t "\ 33 (defconst case-replace t "\
32 *Non-nil means `query-replace' should preserve case in replacements. 34 *Non-nil means `query-replace' should preserve case in replacements.
33 What this means is that `query-replace' will change the case of the 35 What this means is that `query-replace' will change the case of the
34 replacement text so that it matches the text that was replaced. 36 replacement text so that it matches the text that was replaced.
35 If this variable is nil, the replacement text will be inserted 37 If this variable is nil, the replacement text will be inserted
36 exactly as it was specified by the user, irrespective of the case 38 exactly as it was specified by the user, irrespective of the case
143 145
144 (defun replace-string (from-string to-string &optional delimited) 146 (defun replace-string (from-string to-string &optional delimited)
145 "Replace occurrences of FROM-STRING with TO-STRING. 147 "Replace occurrences of FROM-STRING with TO-STRING.
146 Preserve case in each match if `case-replace' and `case-fold-search' 148 Preserve case in each match if `case-replace' and `case-fold-search'
147 are non-nil and FROM-STRING has no uppercase letters. 149 are non-nil and FROM-STRING has no uppercase letters.
150 \(Preserving case means that if the string matched is all caps, or capitalized,
151 then its replacement is upcased or capitalized.)
152
148 Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace 153 Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace
149 only matches surrounded by word boundaries. 154 only matches surrounded by word boundaries.
150 155
151 If `query-replace-interactive' is non-nil, the last incremental search 156 If `query-replace-interactive' is non-nil, the last incremental search
152 string is used as FROM-STRING--you don't have to specify it with the 157 string is used as FROM-STRING--you don't have to specify it with the
250 255
251 (defvar occur-mode-map ()) 256 (defvar occur-mode-map ())
252 (if occur-mode-map 257 (if occur-mode-map
253 () 258 ()
254 (setq occur-mode-map (make-sparse-keymap)) 259 (setq occur-mode-map (make-sparse-keymap))
255 (set-keymap-name occur-mode-map 'occur-mode-map) 260 (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs
256 (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) 261 (define-key occur-mode-map [mouse-2] 'occur-mode-mouse-goto)
257 (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) 262 (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence)
258 (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence)) 263 (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence))
259 264
260 (defvar occur-buffer nil) 265 (defvar occur-buffer nil)
261 (defvar occur-nlines nil) 266 (defvar occur-nlines nil)
269 274
270 \\{occur-mode-map}" 275 \\{occur-mode-map}"
271 (kill-all-local-variables) 276 (kill-all-local-variables)
272 (use-local-map occur-mode-map) 277 (use-local-map occur-mode-map)
273 (setq major-mode 'occur-mode) 278 (setq major-mode 'occur-mode)
274 (setq mode-name (gettext "Occur")) 279 (setq mode-name (gettext "Occur")) ; XEmacs
275 (make-local-variable 'occur-buffer) 280 (make-local-variable 'occur-buffer)
276 (make-local-variable 'occur-nlines) 281 (make-local-variable 'occur-nlines)
277 (make-local-variable 'occur-pos-list) 282 (make-local-variable 'occur-pos-list)
278 (require 'mode-motion) 283 (require 'mode-motion) ; XEmacs
279 (setq mode-motion-hook 'mode-motion-highlight-line) 284 (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs
280 (run-hooks 'occur-mode-hook)) 285 (run-hooks 'occur-mode-hook))
281 286
282 (defun occur-mode-mouse-goto (e) 287 ;; FSF Version of next function:
288 ; (let (buffer pos)
289 ; (save-excursion
290 ; (set-buffer (window-buffer (posn-window (event-end event))))
291 ; (save-excursion
292 ; (goto-char (posn-point (event-end event)))
293 ; (setq pos (occur-mode-find-occurrence))
294 ; (setq buffer occur-buffer)))
295 ; (pop-to-buffer buffer)
296 ; (goto-char (marker-position pos))))
297
298 (defun occur-mode-mouse-goto (event)
283 "Go to the occurrence highlighted by mouse. 299 "Go to the occurrence highlighted by mouse.
284 This function is only reasonable when bound to a mouse key in the occur buffer" 300 This function is only reasonable when bound to a mouse key in the occur buffer"
285 (interactive "e") 301 (interactive "e")
286 (let ((window-save (selected-window)) 302 (let ((window-save (selected-window))
287 (frame-save (selected-frame))) 303 (frame-save (selected-frame)))
291 (mouse-set-point e) 307 (mouse-set-point e)
292 (occur-mode-goto-occurrence)) 308 (occur-mode-goto-occurrence))
293 (select-frame frame-save) 309 (select-frame frame-save)
294 (select-window window-save)))) 310 (select-window window-save))))
295 311
312 ;; Called occur-mode-find-occurrence in FSF
296 (defun occur-mode-goto-occurrence () 313 (defun occur-mode-goto-occurrence ()
297 "Go to the occurrence the current line describes." 314 "Go to the occurrence the current line describes."
298 (interactive) 315 (interactive)
299 (if (or (null occur-buffer) 316 (if (or (null occur-buffer)
300 (null (buffer-name occur-buffer))) 317 (null (buffer-name occur-buffer)))
321 (occur-source-buffer occur-buffer)) 338 (occur-source-buffer occur-buffer))
322 (if (< line-count 1) 339 (if (< line-count 1)
323 (error "No occurrence on this line")) 340 (error "No occurrence on this line"))
324 (or pos 341 (or pos
325 (error "No occurrence on this line")) 342 (error "No occurrence on this line"))
326 ;; don't raise window unless it isn't visible 343 ;; XEmacs: don't raise window unless it isn't visible
327 ;; allow for the possibility that the occur buffer is on another frame 344 ;; allow for the possibility that the occur buffer is on another frame
328 (or (and window 345 (or (and window
329 (window-live-p window) 346 (window-live-p window)
330 (frame-visible-p (window-frame window)) 347 (frame-visible-p (window-frame window))
331 (set-buffer occur-source-buffer)) 348 (set-buffer occur-source-buffer))
342 359
343 ;; XEmacs addition 360 ;; XEmacs addition
344 ;;; Damn you Jamie, this is utter trash. 361 ;;; Damn you Jamie, this is utter trash.
345 (defvar list-matching-lines-whole-buffer t 362 (defvar list-matching-lines-whole-buffer t
346 "If t, occur operates on whole buffer, otherwise occur starts from point. 363 "If t, occur operates on whole buffer, otherwise occur starts from point.
347 default is nil.") 364 default is t.")
348 365
349 (define-function 'occur 'list-matching-lines) 366 (define-function 'occur 'list-matching-lines)
350 (defun list-matching-lines (regexp &optional nlines) 367 (defun list-matching-lines (regexp &optional nlines)
351 "Show all lines in the current buffer containing a match for REGEXP. 368 "Show all lines in the current buffer containing a match for REGEXP.
352 369
353 If a match spreads across multiple lines, all those lines are shown. 370 If a match spreads across multiple lines, all those lines are shown.
354 371
355 If variable `list-matching-lines-whole-buffer' is non-nil, the entire buffer is 372 If variable `list-matching-lines-whole-buffer' is non-nil, the entire buffer is
356 searched, otherwise search begins at point. 373 searched, otherwise search begins at point.
357 374
358 Each line is displayed with NLINES lines before and after, 375 Each line is displayed with NLINES lines before and after, or -NLINES
359 or -NLINES before if NLINES is negative. 376 before if NLINES is negative.
360 NLINES defaults to `list-matching-lines-default-context-lines'. 377 NLINES defaults to `list-matching-lines-default-context-lines'.
361 Interactively it is the prefix arg. 378 Interactively it is the prefix arg.
362 379
363 The lines are shown in a buffer named `*Occur*'. 380 The lines are shown in a buffer named `*Occur*'.
364 It serves as a menu to find any of the occurrences in this buffer. 381 It serves as a menu to find any of the occurrences in this buffer.
365 \\[describe-mode] in that buffer will explain how." 382 \\[describe-mode] in that buffer will explain how."
366 (interactive 383 (interactive
384 ;; XEmacs change
367 (list (let* ((default (or (symbol-near-point) 385 (list (let* ((default (or (symbol-near-point)
368 (and regexp-history 386 (and regexp-history
369 (car regexp-history)))) 387 (car regexp-history))))
370 (minibuffer-history-minimum-string-length 0) 388 (minibuffer-history-minimum-string-length 0)
371 (input 389 (input
394 (let ((first t) 412 (let ((first t)
395 (dir default-directory) 413 (dir default-directory)
396 (buffer (current-buffer)) 414 (buffer (current-buffer))
397 (linenum 1) 415 (linenum 1)
398 (prevpos (point-min)) 416 (prevpos (point-min))
417 ;; The rest of this function is very different from FSF.
418 ;; Presumably that's due to Jamie's misfeature
399 (final-context-start (make-marker))) 419 (final-context-start (make-marker)))
400 (if (not list-matching-lines-whole-buffer) 420 (if (not list-matching-lines-whole-buffer)
401 (save-excursion 421 (save-excursion
402 (beginning-of-line) 422 (beginning-of-line)
403 (setq linenum (1+ (count-lines (point-min) (point)))) 423 (setq linenum (1+ (count-lines (point-min) (point))))
418 (if (eq buffer standard-output) 438 (if (eq buffer standard-output)
419 (goto-char (point-max))) 439 (goto-char (point-max)))
420 (save-excursion 440 (save-excursion
421 (if list-matching-lines-whole-buffer 441 (if list-matching-lines-whole-buffer
422 (beginning-of-buffer)) 442 (beginning-of-buffer))
423 (message "Searching for %s ..." regexp) 443 (message (format "Searching for %s ..." regexp))
424 ;; Find next match, but give up if prev match was at end of buffer. 444 ;; Find next match, but give up if prev match was at end of buffer.
425 (while (and (not (= prevpos (point-max))) 445 (while (and (not (= prevpos (point-max)))
426 (re-search-forward regexp nil t)) 446 (re-search-forward regexp nil t))
427 (goto-char (match-beginning 0)) 447 (goto-char (match-beginning 0))
428 (beginning-of-line) 448 (beginning-of-line)
496 (if (interactive-p) 516 (if (interactive-p)
497 (message "%d matching lines." (length occur-pos-list))))))) 517 (message "%d matching lines." (length occur-pos-list)))))))
498 518
499 ;; It would be nice to use \\[...], but there is no reasonable way 519 ;; It would be nice to use \\[...], but there is no reasonable way
500 ;; to make that display both SPC and Y. 520 ;; to make that display both SPC and Y.
501 (defvar query-replace-help (purecopy 521 (defconst query-replace-help
502 "Type Space or `y' to replace one match, Delete or `n' to skip to next, 522 (purecopy
523 "Type Space or `y' to replace one match, Delete or `n' to skip to next,
503 RET or `q' to exit, Period to replace one match and exit, 524 RET or `q' to exit, Period to replace one match and exit,
504 Comma to replace but not move point immediately, 525 Comma to replace but not move point immediately,
505 C-r to enter recursive edit (\\[exit-recursive-edit] to get out again), 526 C-r to enter recursive edit (\\[exit-recursive-edit] to get out again),
506 C-w to delete match and recursive edit, 527 C-w to delete match and recursive edit,
507 C-l to clear the frame, redisplay, and offer same replacement again, 528 C-l to clear the frame, redisplay, and offer same replacement again,
508 ! to replace all remaining matches with no more questions, 529 ! to replace all remaining matches with no more questions,
509 ^ to move point back to previous match.") 530 ^ to move point back to previous match."
531 )
510 "Help message while in query-replace") 532 "Help message while in query-replace")
511 533
512 (defvar query-replace-map nil 534 (defvar query-replace-map nil
513 "Keymap that defines the responses to questions in `query-replace'. 535 "Keymap that defines the responses to questions in `query-replace'.
514 The \"bindings\" in this map are not commands; they are answers. 536 The \"bindings\" in this map are not commands; they are answers.
515 The valid answers include `act', `skip', `act-and-show', 537 The valid answers include `act', `skip', `act-and-show',
516 `exit', `act-and-exit', `edit', `delete-and-edit', `recenter', 538 `exit', `act-and-exit', `edit', `delete-and-edit', `recenter',
517 `automatic', `backup', `exit-prefix', and `help'.") 539 `automatic', `backup', `exit-prefix', and `help'.")
518 540
541 ;; Why does it seem that ever file has a different method of doing this?
519 (if query-replace-map 542 (if query-replace-map
520 nil 543 nil
521 (let ((map (make-sparse-keymap))) 544 (let ((map (make-sparse-keymap)))
522 (set-keymap-name map 'query-replace-map) 545 (set-keymap-name map 'query-replace-map)
523 (define-key map " " 'act) 546 (define-key map " " 'act)
550 (setq query-replace-map map))) 573 (setq query-replace-map map)))
551 574
552 575
553 (autoload 'isearch-highlight "isearch") 576 (autoload 'isearch-highlight "isearch")
554 577
578 ;; XEmacs
555 (defun perform-replace-next-event (event) 579 (defun perform-replace-next-event (event)
556 (if isearch-highlight 580 (if isearch-highlight
557 (let ((aborted t)) 581 (let ((aborted t))
558 (unwind-protect 582 (unwind-protect
559 (progn 583 (progn
573 (replace-match \"foobar\" nil nil)) 597 (replace-match \"foobar\" nil nil))
574 which will run faster and probably do exactly what you want." 598 which will run faster and probably do exactly what you want."
575 (or map (setq map query-replace-map)) 599 (or map (setq map query-replace-map))
576 (let* ((event (make-event)) 600 (let* ((event (make-event))
577 (nocasify (not (and case-fold-search case-replace 601 (nocasify (not (and case-fold-search case-replace
578 (string-equal from-string 602 (string-equal from-string
579 (downcase from-string))))) 603 (downcase from-string)))))
580 (literal (not regexp-flag)) 604 (literal (not regexp-flag))
581 (search-function (if regexp-flag 're-search-forward 'search-forward)) 605 (search-function (if regexp-flag 're-search-forward 'search-forward))
582 (search-string from-string) 606 (search-string from-string)
583 (real-match-data nil) ; the match data for the current match 607 (real-match-data nil) ; the match data for the current match
584 (next-replacement nil) 608 (next-replacement nil)
607 (if regexp-flag from-string 631 (if regexp-flag from-string
608 (regexp-quote from-string)) 632 (regexp-quote from-string))
609 "\\b"))) 633 "\\b")))
610 (push-mark) 634 (push-mark)
611 (undo-boundary) 635 (undo-boundary)
612 ;; Loop finding occurrences that perhaps should be replaced. 636 (unwind-protect
613 (while (and keep-going 637 ;; Loop finding occurrences that perhaps should be replaced.
614 (not (eobp)) 638 (while (and keep-going
615 (let ((case-fold-search qr-case-fold-search)) 639 (not (eobp))
616 (funcall search-function search-string nil t)) 640 (let ((case-fold-search qr-case-fold-search))
617 ;; If the search string matches immediately after 641 (funcall search-function search-string nil t))
618 ;; the previous match, but it did not match there 642 ;; If the search string matches immediately after
619 ;; before the replacement was done, ignore the match. 643 ;; the previous match, but it did not match there
620 (if (or (eq lastrepl (point)) 644 ;; before the replacement was done, ignore the match.
621 (and regexp-flag 645 (if (or (eq lastrepl (point))
622 (eq lastrepl (match-beginning 0)) 646 (and regexp-flag
623 (not match-again))) 647 (eq lastrepl (match-beginning 0))
624 648 (not match-again)))
625 (if (eobp) 649 (if (eobp)
626 nil 650 nil
627 ;; Don't replace the null string 651 ;; Don't replace the null string
628 ;; right after end of previous replacement. 652 ;; right after end of previous replacement.
629 (forward-char 1) 653 (forward-char 1)
630 (let ((case-fold-search qr-case-fold-search)) 654 (let ((case-fold-search qr-case-fold-search))
631 (funcall search-function search-string nil t))) 655 (funcall search-function search-string nil t)))
632 t)) 656 t))
633 ;; Save the data associated with the real match. 657
634 (setq real-match-data (match-data)) 658 ;; Save the data associated with the real match.
635 659 (setq real-match-data (match-data))
636 ;; Before we make the replacement, decide whether the search string 660
637 ;; can match again just after this match. 661 ;; Before we make the replacement, decide whether the search string
638 (if regexp-flag 662 ;; can match again just after this match.
639 (progn 663 (if regexp-flag
640 (setq match-again (looking-at search-string)) 664 (progn
641 (store-match-data real-match-data))) 665 (setq match-again (looking-at search-string))
642 666 ;; XEmacs addition
643 ;; If time for a change, advance to next replacement string. 667 (store-match-data real-match-data)))
644 (if (and (listp replacements) 668 ;; If time for a change, advance to next replacement string.
645 (= next-rotate-count replace-count)) 669 (if (and (listp replacements)
646 (progn 670 (= next-rotate-count replace-count))
647 (setq next-rotate-count 671 (progn
648 (+ next-rotate-count repeat-count)) 672 (setq next-rotate-count
649 (setq next-replacement (nth replacement-index replacements)) 673 (+ next-rotate-count repeat-count))
650 (setq replacement-index (% (1+ replacement-index) (length replacements))))) 674 (setq next-replacement (nth replacement-index replacements))
651 (if (not query-flag) 675 (setq replacement-index (% (1+ replacement-index) (length replacements)))))
652 (progn 676 (if (not query-flag)
653 (store-match-data real-match-data) 677 (progn
654 (replace-match next-replacement nocasify literal) 678 (store-match-data real-match-data)
655 (setq replace-count (1+ replace-count))) 679 (replace-match next-replacement nocasify literal)
656 (undo-boundary) 680 (setq replace-count (1+ replace-count)))
657 (let ((help-form 681 (undo-boundary)
658 '(concat (format "Query replacing %s%s with %s.\n\n" 682 (let ((help-form
659 (if regexp-flag (gettext "regexp ") "") 683 '(concat (format "Query replacing %s%s with %s.\n\n"
660 from-string next-replacement) 684 (if regexp-flag (gettext "regexp ") "")
661 (substitute-command-keys query-replace-help))) 685 from-string next-replacement)
662 (done nil) 686 (substitute-command-keys query-replace-help)))
663 (replaced nil) 687 done replaced def)
664 def) 688 ;; Loop reading commands until one of them sets done,
665 ;; Loop reading commands until one of them sets done, 689 ;; which means it has finished handling this occurrence.
666 ;; which means it has finished handling this occurrence. 690 (while (not done)
667 (while (not done) 691 ;; Don't fill up the message log
668 ;; Don't fill up the message log 692 ;; with a bunch of identical messages.
669 ;; with a bunch of identical messages. 693 ;; XEmacs change
670 (display-message 'prompt 694 (display-message 'prompt
671 (format message from-string next-replacement)) 695 (format message from-string next-replacement))
672 (perform-replace-next-event event) 696 (perform-replace-next-event event)
673 (setq def (lookup-key map (vector event))) 697 (setq def (lookup-key map (vector event)))
674 ;; Restore the match data while we process the command. 698 ;; Restore the match data while we process the command.
675 (store-match-data real-match-data) 699 (store-match-data real-match-data)
676 (cond ((eq def 'help) 700 (cond ((eq def 'help)
677 (with-output-to-temp-buffer (gettext "*Help*") 701 (with-output-to-temp-buffer (gettext "*Help*")
678 (princ (concat 702 (princ (concat
679 (format "Query replacing %s%s with %s.\n\n" 703 (format "Query replacing %s%s with %s.\n\n"
680 (if regexp-flag "regexp " "") 704 (if regexp-flag "regexp " "")
681 from-string next-replacement) 705 from-string next-replacement)
682 (substitute-command-keys 706 (substitute-command-keys
683 query-replace-help))) 707 query-replace-help)))
684 (save-excursion 708 (save-excursion
685 (set-buffer standard-output) 709 (set-buffer standard-output)
686 (help-mode)))) 710 (help-mode))))
687 ((eq def 'exit) 711 ((eq def 'exit)
688 (setq keep-going nil) 712 (setq keep-going nil)
689 (setq done t)) 713 (setq done t))
690 ((eq def 'backup) 714 ((eq def 'backup)
691 (if stack 715 (if stack
692 (let ((elt (car stack))) 716 (let ((elt (car stack)))
693 (goto-char (car elt)) 717 (goto-char (car elt))
694 (setq replaced (eq t (cdr elt))) 718 (setq replaced (eq t (cdr elt)))
695 (or replaced 719 (or replaced
696 (store-match-data (cdr elt))) 720 (store-match-data (cdr elt)))
697 (setq stack (cdr stack))) 721 (setq stack (cdr stack)))
698 (progn
699 (message "No previous match") 722 (message "No previous match")
700 (ding 'no-terminate) 723 (ding 'no-terminate)
701 (sit-for 1)))) 724 (sit-for 1)))
702 ((eq def 'act) 725 ((eq def 'act)
703 (or replaced 726 (or replaced
704 (replace-match next-replacement nocasify literal)) 727 (replace-match next-replacement nocasify literal))
705 (setq done t replaced t)) 728 (setq done t replaced t))
706 ((eq def 'act-and-exit) 729 ((eq def 'act-and-exit)
707 (or replaced 730 (or replaced
708 (replace-match next-replacement nocasify literal)) 731 (replace-match next-replacement nocasify literal))
709 (setq keep-going nil) 732 (setq keep-going nil)
710 (setq done t replaced t)) 733 (setq done t replaced t))
711 ((eq def 'act-and-show) 734 ((eq def 'act-and-show)
712 (if (not replaced) 735 (if (not replaced)
713 (progn 736 (progn
714 (replace-match next-replacement nocasify literal) 737 (replace-match next-replacement nocasify literal)
715 (setq replaced t)))) 738 (setq replaced t))))
716 ((eq def 'automatic) 739 ((eq def 'automatic)
717 (or replaced 740 (or replaced
718 (replace-match next-replacement nocasify literal)) 741 (replace-match next-replacement nocasify literal))
719 (setq done t query-flag nil replaced t)) 742 (setq done t query-flag nil replaced t))
720 ((eq def 'skip) 743 ((eq def 'skip)
721 (setq done t)) 744 (setq done t))
722 ((eq def 'recenter) 745 ((eq def 'recenter)
723 (recenter nil)) 746 (recenter nil))
724 ((eq def 'edit) 747 ((eq def 'edit)
725 (store-match-data 748 (store-match-data
726 (prog1 (match-data) 749 (prog1 (match-data)
727 (save-excursion (recursive-edit)))) 750 (save-excursion (recursive-edit))))
728 ;; Before we make the replacement, 751 ;; Before we make the replacement,
729 ;; decide whether the search string 752 ;; decide whether the search string
730 ;; can match again just after this match. 753 ;; can match again just after this match.
731 (if regexp-flag 754 (if regexp-flag
732 (setq match-again (looking-at search-string)))) 755 (setq match-again (looking-at search-string))))
733 ((eq def 'delete-and-edit) 756 ((eq def 'delete-and-edit)
734 (delete-region (match-beginning 0) (match-end 0)) 757 (delete-region (match-beginning 0) (match-end 0))
735 (store-match-data (prog1 (match-data) 758 (store-match-data (prog1 (match-data)
736 (save-excursion (recursive-edit)))) 759 (save-excursion (recursive-edit))))
737 (setq replaced t)) 760 (setq replaced t))
738 ;; Note: we do not need to treat `exit-prefix' 761 ;; Note: we do not need to treat `exit-prefix'
739 ;; specially here, since we reread 762 ;; specially here, since we reread
740 ;; any unrecognized character. 763 ;; any unrecognized character.
741 (t 764 (t
742 (setq this-command 'mode-exited) 765 (setq this-command 'mode-exited)
743 (setq keep-going nil) 766 (setq keep-going nil)
744 (setq unread-command-events 767 (setq unread-command-events
745 (cons event unread-command-events)) 768 (cons event unread-command-events))
746 (setq done t)))) 769 (setq done t))))
747 ;; Record previous position for ^ when we move on. 770 ;; Record previous position for ^ when we move on.
748 ;; Change markers to numbers in the match data 771 ;; Change markers to numbers in the match data
749 ;; since lots of markers slow down editing. 772 ;; since lots of markers slow down editing.
750 (setq stack 773 (setq stack
751 (cons (cons (point) 774 (cons (cons (point)
752 (or replaced 775 (or replaced
753 (mapcar 776 (mapcar
754 #'(lambda (elt) 777 #'(lambda (elt)
755 (if (markerp elt) 778 (if (markerp elt)
756 (prog1 (marker-position elt) 779 (prog1 (marker-position elt)
757 (set-marker elt nil)) 780 (set-marker elt nil))
758 elt)) 781 elt))
759 (match-data)))) 782 (match-data))))
760 stack)) 783 stack))
761 (if replaced (setq replace-count (1+ replace-count))))) 784 (if replaced (setq replace-count (1+ replace-count)))))
762 (setq lastrepl (point))) 785 (setq lastrepl (point)))
786 (replace-dehighlight))
763 (or unread-command-events 787 (or unread-command-events
764 (message "Replaced %d occurrence%s" 788 (message "Replaced %d occurrence%s"
765 replace-count 789 replace-count
766 (if (= replace-count 1) "" "s"))) 790 (if (= replace-count 1) "" "s")))
767 (and keep-going stack))) 791 (and keep-going stack)))
768 792
769 ; FSF 19.30 original: 793 (defvar query-replace-highlight nil
770 ; (defun match-string (num &optional string) 794 "*Non-nil means to highlight words during query replacement.")
771 ; "Return string of text matched by last search. 795
772 ; NUM specifies which parenthesized expression in the last regexp. 796 (defvar replace-overlay nil)
773 ; Value is nil if NUMth pair didn't match, or there were less than NUM pairs. 797
774 ; Zero means the entire text matched by the whole regexp or whole string. 798 (defun replace-dehighlight ()
775 ; STRING should be given if the last search was by `string-match' on STRING." 799 (and replace-overlay
776 ; (if (match-beginning num) 800 (progn
777 ; (if string 801 (delete-overlay replace-overlay)
778 ; (substring string (match-beginning num) (match-end num)) 802 (setq replace-overlay nil))))
779 ; (buffer-substring (match-beginning num) (match-end num))))) 803
780 804 (defun replace-highlight (start end)
781 ;; #### - this could stand to be in C... 805 (and query-replace-highlight
782 (defmacro match-string (n &optional string) 806 (progn
783 "Returns the Nth subexpression matched by the last regular expression 807 (or replace-overlay
784 search. The second argument, STRING, must be specified if the last 808 (progn
785 regular expression search was done with `string-match'." 809 (setq replace-overlay (make-overlay start end))
786 ;; #### - note that match-beginning is byte coded, so it's more efficient 810 (overlay-put replace-overlay 'face
787 ;; to just call it twice than it is to let-bind its return value... --Stig 811 (if (internal-find-face 'query-replace)
788 `(and (match-beginning ,n) 812 'query-replace 'region))))
789 ,(if string 813 (move-overlay replace-overlay start end (current-buffer)))))
790 `(substring ,string (match-beginning ,n) (match-end ,n)) 814
791 `(buffer-substring (match-beginning ,n) (match-end ,n))))) 815 (defun match-string (num &optional string)
816 "Return string of text matched by last search.
817 NUM specifies which parenthesized expression in the last regexp.
818 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
819 Zero means the entire text matched by the whole regexp or whole string.
820 STRING should be given if the last search was by `string-match' on STRING."
821 (if (match-beginning num)
822 (if string
823 (substring string (match-beginning num) (match-end num))
824 (buffer-substring (match-beginning num) (match-end num)))))
792 825
793 (defmacro save-match-data (&rest body) 826 (defmacro save-match-data (&rest body)
794 "Execute BODY forms, restoring the global value of the match data." 827 "Execute BODY forms, restoring the global value of the match data."
795 (let ((original (make-symbol "match-data"))) 828 (let ((original (make-symbol "match-data")))
796 (list 'let (list (list original '(match-data))) 829 (list 'let (list (list original '(match-data)))