home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / prim / replace.el < prev    next >
Encoding:
Text File  |  1993-03-14  |  14.7 KB  |  429 lines
  1. ;; Replace commands for Emacs.
  2. ;; Copyright (C) 1985-1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20.  
  21. (defvar minibuffer-regexp-history nil)
  22.  
  23. (fset 'delete-non-matching-lines 'keep-lines)
  24. (defun keep-lines (regexp)
  25.   "Delete all lines except those containing matches for REGEXP.
  26. A match split across lines preserves all the lines it lies in.
  27. Applies to all lines after point."
  28. ;;  (interactive "sKeep lines (containing match for regexp): ")
  29.   (interactive (list (read-string "Keep lines (containing match for regexp): "
  30.                   nil 'minibuffer-regexp-history)))
  31.   (save-excursion
  32.     (or (bolp) (forward-line 1))
  33.     (let ((start (point)))
  34.       (while (not (eobp))
  35.     ;; Start is first char not preserved by previous match.
  36.     (if (not (re-search-forward regexp nil 'move))
  37.         (delete-region start (point-max))
  38.       (let ((end (save-excursion (goto-char (match-beginning 0))
  39.                      (beginning-of-line)
  40.                      (point))))
  41.         ;; Now end is first char preserved by the new match.
  42.         (if (< start end)
  43.         (delete-region start end))))
  44.     (setq start (save-excursion (forward-line 1)
  45.                     (point)))
  46.     ;; If the match was empty, avoid matching again at same place.
  47.     (and (not (eobp)) (= (match-beginning 0) (match-end 0))
  48.          (forward-char 1))))))
  49.  
  50. (fset 'delete-matching-lines 'flush-lines)
  51. (defun flush-lines (regexp)
  52.   "Delete lines containing matches for REGEXP.
  53. If a match is split across lines, all the lines it lies in are deleted.
  54. Applies to lines after point."
  55. ;;  (interactive "sFlush lines (containing match for regexp): ")
  56.   (interactive (list (read-string "Flush lines (containing match for regexp): "
  57.                   nil 'minibuffer-regexp-history)))
  58.   (save-excursion
  59.     (while (and (not (eobp))
  60.         (re-search-forward regexp nil t))
  61.       (delete-region (save-excursion (goto-char (match-beginning 0))
  62.                      (beginning-of-line)
  63.                      (point))
  64.              (progn (forward-line 1) (point))))))
  65.  
  66. (fset 'count-matches 'how-many)
  67. (defun how-many (regexp)
  68.   "Print number of matches for REGEXP following point."
  69. ;;  (interactive "sHow many matches for (regexp): ")
  70.   (interactive (list (read-string "How many matches for (regexp): "
  71.                 nil 'minibuffer-regexp-history)))
  72.   (let ((count 0) opoint)
  73.     (save-excursion
  74.      (while (and (not (eobp))
  75.          (progn (setq opoint (point))
  76.             (re-search-forward regexp nil t)))
  77.        (if (= opoint (point))
  78.        (forward-char 1)
  79.      (setq count (1+ count))))
  80.      (message "%d occurrences" count))))
  81.  
  82. (defvar occur-mode-map ())
  83. (if occur-mode-map
  84.     ()
  85.   (setq occur-mode-map (make-sparse-keymap))
  86.   (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence))
  87.  
  88. (defvar occur-buffer nil)
  89. (defvar occur-nlines nil)
  90. (defvar occur-pos-list nil)
  91. (defvar occur-last-string "")
  92.  
  93. (defun occur-mode ()
  94.   "Major mode for output from \\[occur].
  95. Move point to one of the occurrences in this buffer,
  96. then use \\[occur-mode-goto-occurrence] to go to the same occurrence
  97. in the buffer that the occurrences were found in.
  98. \\{occur-mode-map}"
  99.   (kill-all-local-variables)
  100.   (use-local-map occur-mode-map)
  101.   (setq major-mode 'occur-mode)
  102.   (setq mode-name "Occur")
  103.   (make-local-variable 'occur-buffer)
  104.   (make-local-variable 'occur-nlines)
  105.   (make-local-variable 'occur-pos-list))
  106.  
  107. (defun occur-mode-goto-occurrence ()
  108.   "Go to the line this occurrence was found in, in the buffer it was found in."
  109.   (interactive)
  110.   (if (or (null occur-buffer)
  111.       (null (buffer-name occur-buffer)))
  112.       (progn
  113.     (setq occur-buffer nil
  114.           occur-pos-list nil)
  115.     (error "Buffer in which occurrences were found is deleted")))
  116.   (let* ((occur-number (save-excursion
  117.              (beginning-of-line)
  118.              (/ (1- (count-lines (point-min)
  119.                          (save-excursion
  120.                            (beginning-of-line)
  121.                            (point))))
  122.                 (cond ((< occur-nlines 0)
  123.                    (- 2 occur-nlines))
  124.                   ((> occur-nlines 0)
  125.                    (+ 2 (* 2 occur-nlines)))
  126.                   (t 1)))))
  127.      (pos (nth occur-number occur-pos-list)))
  128.     (pop-to-buffer occur-buffer)
  129.     (goto-char (marker-position pos))))
  130.  
  131. (defvar list-matching-lines-default-context-lines 0
  132.   "*Default number of context lines to include around a list-matching-lines
  133. match.  A negative number means to include that many lines before the match.
  134. A positive number means to include that many lines both before and after.")
  135.  
  136. (defvar occur-whole-buffer nil
  137.   "If t, occur operates on whole buffer, otherwise occur starts from point.
  138. default is nil.")
  139.  
  140. (fset 'list-matching-lines 'occur)
  141.  
  142. (defun occur (regexp &optional nlines)
  143.   "Show lines containing a match for REGEXP.  If the global variable
  144. occur-whole-buffer is non-nil, the entire buffer is searched, otherwise
  145. search begins at point.  Interactively, REGEXP defaults to the last REGEXP
  146. used interactively.
  147.  
  148. Each line is displayed with NLINES lines before and after,
  149. or -NLINES before if NLINES is negative.
  150. NLINES defaults to list-matching-lines-default-context-lines.
  151. Interactively it is the prefix arg.
  152.  
  153. The lines are shown in a buffer named *Occur*.
  154. It serves as a menu to find any of the occurrences in this buffer.
  155. \\[describe-mode] in that buffer will explain how."
  156.   (interactive (list (setq occur-last-string
  157.                (read-string "List lines matching regexp: "
  158.                     occur-last-string
  159.                     'minibuffer-regexp-history))
  160.              current-prefix-arg))
  161.   (setq nlines (if nlines (prefix-numeric-value nlines)
  162.          list-matching-lines-default-context-lines))
  163.   (let ((first t)
  164.     (buffer (current-buffer))
  165.     (linenum 1)
  166.     (prevpos (point-min)))
  167.     (if (not occur-whole-buffer)
  168.     (save-excursion
  169.       (beginning-of-line)
  170.       (setq linenum (1+ (count-lines (point-min) (point))))
  171.       (setq prevpos (point))))
  172.     (with-output-to-temp-buffer "*Occur*"
  173.       (save-excursion
  174.     (set-buffer standard-output)
  175.     (insert "Lines matching ")
  176.     (prin1 regexp)
  177.     (insert " in buffer " (buffer-name buffer) ?. ?\n)
  178.     (occur-mode)
  179.     (setq occur-buffer buffer)
  180.     (setq occur-nlines nlines)
  181.     (setq occur-pos-list ()))
  182.       (if (eq buffer standard-output)
  183.       (goto-char (point-max)))
  184.       (save-excursion
  185.     (if occur-whole-buffer
  186.         (beginning-of-buffer))
  187.     ;; Find next match, but give up if prev match was at end of buffer.
  188.     (while (and (not (= prevpos (point-max)))
  189.             (re-search-forward regexp nil t))
  190.       (beginning-of-line)
  191.       (setq linenum (+ linenum (count-lines prevpos (point))))
  192.       (setq prevpos (point))
  193.       (let* ((start (save-excursion
  194.               (forward-line (if (< nlines 0) nlines (- nlines)))
  195.               (point)))
  196.          (end (save-excursion
  197.             (if (> nlines 0)
  198.                 (forward-line (1+ nlines))
  199.                 (forward-line 1))
  200.             (point)))
  201.          (tag (format "%3d" linenum))
  202.          (empty (make-string (length tag) ?\ ))
  203.          tem)
  204.         (save-excursion
  205.           (setq tem (make-marker))
  206.           (set-marker tem (point))
  207.           (set-buffer standard-output)
  208.           (setq occur-pos-list (cons tem occur-pos-list))
  209.           (or first (zerop nlines)
  210.           (insert "--------\n"))
  211.           (setq first nil)
  212.           (insert-buffer-substring buffer start end)
  213.           (backward-char (- end start))
  214.           (setq tem (if (< nlines 0) (- nlines) nlines))
  215.           (while (> tem 0)
  216.         (insert empty ?:)
  217.         (forward-line 1)
  218.         (setq tem (1- tem)))
  219.           (insert tag ?:)
  220.           (forward-line 1)
  221.           (while (< tem nlines)
  222.         (insert empty ?:)
  223.         (forward-line 1)
  224.         (setq tem (1+ tem))))                
  225.         (forward-line 1)))
  226.     (set-buffer standard-output)
  227.     ;; Put positions in increasing order to go with buffer.
  228.     (setq occur-pos-list (nreverse occur-pos-list))
  229.     (if (interactive-p)
  230.         (message "%d matching lines." (length occur-pos-list)))))))
  231.  
  232. (defconst query-replace-help
  233.   "Type Space or `y' to replace one match, Delete or `n' to skip to next,
  234. ESC or `q' to exit, Period to replace one match and exit,
  235. Comma to replace but not move point immediately,
  236. C-r to enter recursive edit (\\[exit-recursive-edit] to get out again),
  237. C-w to delete match and recursive edit,
  238. C-l to clear the screen, redisplay, and offer same replacement again,
  239. ! to replace all remaining matches with no more questions,
  240. ^ to move point back to previous match."
  241.   "Help message while in query-replace")
  242.  
  243. (autoload 'isearch-highlight "isearch")
  244.  
  245. (defun perform-replace-next-event (event)
  246.   (if isearch-highlight
  247.       (let ((aborted t))
  248.     (unwind-protect
  249.         (progn
  250.           (isearch-highlight (match-beginning 0) (match-end 0))
  251.           (next-command-event event)
  252.           (setq aborted nil))
  253.       (isearch-dehighlight aborted)))
  254.     (next-command-event event)))
  255.  
  256. (defun perform-replace (from-string replacements
  257.                 query-flag regexp-flag delimited-flag
  258.             &optional repeat-count)
  259.   "Subroutine of `query-replace'.  Its complexity handles interactive queries.
  260. Don't use this in your own program unless you want to query and set the mark
  261. just as `query-replace' does.  Instead, write a simple loop like this:
  262.   (while (re-search-forward \"foo[ \t]+bar\" nil t)
  263.     (replace-match \"foobar\" nil nil))
  264. which will run faster and do exactly what you probably want."
  265.   (let ((char nil)
  266.     (event (allocate-event))
  267.     (nocasify (not (and case-fold-search case-replace
  268.                 (string-equal from-string
  269.                       (downcase from-string)))))
  270.     (literal (not regexp-flag))
  271.     (search-function (if regexp-flag 're-search-forward 'search-forward))
  272.     (search-string from-string)
  273.     (next-replacement nil)
  274.     (replacement-index 0)
  275.     (keep-going t)
  276.     (stack nil)
  277.     (next-rotate-count 0)
  278.     (replace-count 0)
  279.     (lastrepl nil))            ;Position after last match considered.
  280.     (if (stringp replacements)
  281.     (setq next-replacement replacements)
  282.       (or repeat-count (setq repeat-count 1)))
  283.     (if delimited-flag
  284.     (setq search-function 're-search-forward
  285.           search-string (concat "\\b"
  286.                     (if regexp-flag from-string
  287.                       (regexp-quote from-string))
  288.                     "\\b")))
  289.     (push-mark)
  290.     (undo-boundary)
  291.     (while (and keep-going
  292.         (not (eobp))
  293.         (funcall search-function search-string nil t)
  294.         (if (eq lastrepl (point))
  295.             (progn 
  296.               ;; Don't replace the null string 
  297.               ;; right after end of previous replacement.
  298.               (forward-char 1)
  299.               (funcall search-function search-string nil t))
  300.           t))
  301.       ;; If time for a change, advance to next replacement string.
  302.       (if (and (listp replacements)
  303.            (= next-rotate-count replace-count))
  304.       (progn
  305.         (setq next-rotate-count
  306.           (+ next-rotate-count repeat-count))
  307.         (setq next-replacement (nth replacement-index replacements))
  308.         (setq replacement-index (% (1+ replacement-index) (length replacements)))))
  309.       (if (not query-flag)
  310.       (progn
  311.         (replace-match next-replacement nocasify literal)
  312.         (setq replace-count (1+ replace-count)))
  313.     (undo-boundary)
  314.     (let (done replaced)
  315.       (while (not done)
  316.         ;; Preserve the match data.  Process filters and sentinels
  317.         ;; could run inside read-char..
  318.         (let ((data (match-data))
  319.           (help-form
  320.            '(concat "Query replacing "
  321.                 (if regexp-flag "regexp " "")
  322.                 from-string " with " next-replacement ".\n\n"
  323.                 (substitute-command-keys query-replace-help))))
  324.           (setq char help-char)
  325.           (while (or (not (numberp char)) (= char help-char))
  326.         (message "Query replacing %s with %s: " from-string next-replacement)
  327.         (perform-replace-next-event event)
  328.         
  329.         (setq char (or (event-to-character event) event))
  330.         (if (and (numberp char) (= char ??))
  331.             (setq unread-command-event
  332.                (character-to-event help-char (allocate-event))
  333.               char help-char)))
  334.           (store-match-data data))
  335.         (cond ((or (= char ?\e)
  336.                (= char ?q))
  337.            (setq keep-going nil)
  338.            (setq done t))
  339.           ((= char ?^)
  340.            (let ((elt (car stack)))
  341.              (goto-char (car elt))
  342.              (setq replaced (eq t (cdr elt)))
  343.              (or replaced
  344.              (store-match-data (cdr elt)))
  345.              (setq stack (cdr stack))))             
  346.           ((or (= char ?\ )
  347.                (= char ?y))
  348.            (or replaced
  349.                (replace-match next-replacement nocasify literal))
  350.            (setq done t replaced t))
  351.           ((= char ?\.)
  352.            (or replaced
  353.                (replace-match next-replacement nocasify literal))
  354.            (setq keep-going nil)
  355.            (setq done t replaced t))
  356.           ((= char ?\,)
  357.            (if (not replaced)
  358.                (progn
  359.              (replace-match next-replacement nocasify literal)
  360.              (setq replaced t))))
  361.           ((= char ?!)
  362.            (or replaced
  363.                (replace-match next-replacement nocasify literal))
  364.            (setq done t query-flag nil replaced t))
  365.           ((or (= char ?\177)
  366.                (= char ?n))
  367.            (setq done t))
  368.           ((= char ?\C-l)
  369.            (recenter nil))
  370.           ((= char ?\C-r)
  371.            (store-match-data
  372.             (prog1 (match-data)
  373.               (save-excursion (recursive-edit)))))
  374.           ((= char ?\C-w)
  375.            (delete-region (match-beginning 0) (match-end 0))
  376.            (store-match-data
  377.             (prog1 (match-data)
  378.               (save-excursion (recursive-edit))))
  379.            (setq replaced t))
  380.           (t
  381.            (setq keep-going nil)
  382.            (setq unread-command-event event)
  383.            (setq done t))))
  384.       ;; Record previous position for ^ when we move on.
  385.       ;; Change markers to numbers in the match data
  386.       ;; since lots of markers slow down editing.
  387.       (setq stack
  388.         (cons (cons (point)
  389.                 (or replaced
  390.                 (mapcar
  391.                  (function (lambda (elt)
  392.                          (if (markerp elt)
  393.                          (marker-position elt)
  394.                            elt)))
  395.                  (match-data))))
  396.               stack))
  397.       (if replaced (setq replace-count (1+ replace-count)))))
  398.       (setq lastrepl (point)))
  399.     (and keep-going stack)))
  400.  
  401. (defun map-query-replace-regexp (regexp to-strings &optional arg)
  402.   "Replace some matches for REGEXP with various strings, in rotation.
  403. The second argument TO-STRINGS contains the replacement strings, separated
  404. by spaces.  This command works like `query-replace-regexp' except
  405. that each successive replacement uses the next successive replacement string,
  406. wrapping around from the last such string to the first.
  407.  
  408. Non-interactively, TO-STRINGS may be a list of replacement strings.
  409.  
  410. A prefix argument N says to use each replacement string N times
  411. before rotating to the next."
  412.   (interactive "sMap query replace (regexp): \nsQuery replace %s with (space-separated strings): \nP")
  413.   (let (replacements)
  414.     (if (listp to-strings)
  415.     (setq replacements to-strings)
  416.       (while (/= (length to-strings) 0)
  417.     (if (string-match " " to-strings)
  418.         (setq replacements
  419.           (append replacements
  420.               (list (substring to-strings 0
  421.                        (string-match " " to-strings))))
  422.           to-strings (substring to-strings
  423.                        (1+ (string-match " " to-strings))))
  424.       (setq replacements (append replacements (list to-strings))
  425.         to-strings ""))))
  426.     (perform-replace regexp replacements t t nil arg))
  427.   (message "Done"))
  428.  
  429.