source: trunk/ccl/hemlock/src/searchcoms.lisp @ 2100

Last change on this file since 2100 was 2100, checked in by gb, 14 years ago

Allow redisplay when getting key events during search commands.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.6 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; This file contains searching and replacing commands.
13;;;
14
15(in-package :hemlock)
16
17
18
19;;;; Some global state.
20
21(defvar *last-search-string* () "Last string searched for.")
22(defvar *last-search-pattern*
23  (new-search-pattern :string-insensitive :forward "Foo")
24  "Search pattern we keep around so we don't cons them all the time.")
25
26(defhvar "String Search Ignore Case"
27  "When set, string searching commands use case insensitive."
28  :value t)
29
30(defun get-search-pattern (string direction)
31  (declare (simple-string string))
32  (when (zerop (length string)) (editor-error))
33  (setq *last-search-string* string)
34  (setq *last-search-pattern*
35        (new-search-pattern (if (value string-search-ignore-case)
36                                :string-insensitive
37                                :string-sensitive)
38                            direction string *last-search-pattern*)))
39
40
41
42;;;; Vanilla searching.
43
44(defcommand "Forward Search" (p &optional string)
45  "Do a forward search for a string.
46  Prompt for the string and leave the point after where it is found."
47  "Searches for the specified String in the current buffer."
48  (declare (ignore p))
49  (if (not string)
50      (setq string (prompt-for-string :prompt "Search: "
51                                      :default *last-search-string*
52                                      :help "String to search for")))
53  (let* ((pattern (get-search-pattern string :forward))
54         (point (current-point))
55         (mark (copy-mark point))
56         (won (find-pattern point pattern)))
57    (cond (won (character-offset point won)
58               (if (region-active-p)
59                   (delete-mark mark)
60                   (push-buffer-mark mark)))
61          (t (delete-mark mark)
62             (editor-error)))))
63
64(defcommand "Reverse Search" (p &optional string)
65  "Do a backward search for a string.
66  Prompt for the string and leave the point before where it is found."
67  "Searches backwards for the specified String in the current buffer."
68  (declare (ignore p))
69  (if (not string)
70      (setq string (prompt-for-string :prompt "Reverse Search: "
71                                      :default *last-search-string* 
72                                      :help "String to search for")))
73  (let* ((pattern (get-search-pattern string :backward))
74         (point (current-point))
75         (mark (copy-mark point))
76         (won (find-pattern point pattern)))
77    (cond (won (if (region-active-p)
78                   (delete-mark mark)
79                   (push-buffer-mark mark)))
80          (t (delete-mark mark)
81             (editor-error)))))
82
83
84
85;;;; Incremental searching.
86
87(defun i-search-pattern (string direction)
88  (setq *last-search-pattern*
89        (new-search-pattern (if (value string-search-ignore-case)
90                                :string-insensitive
91                                :string-sensitive)
92                            direction string *last-search-pattern*)))
93
94;;;      %I-SEARCH-ECHO-REFRESH refreshes the echo buffer for incremental
95;;; search.
96;;;
97(defun %i-search-echo-refresh (string direction failure)
98  (when (interactive)
99    (clear-echo-area)
100    (format *echo-area-stream* 
101            "~:[~;Failing ~]~:[Reverse I-Search~;I-Search~]: ~A"
102            failure (eq direction :forward) string)))
103
104(defcommand "Incremental Search" (p)
105  "Searches for input string as characters are provided.
106  These are the default I-Search command characters:  ^Q quotes the
107  next character typed.  Backspace cancels the last character typed.  ^S
108  repeats forward, and ^R repeats backward.  ^R or ^S with empty string
109  either changes the direction or yanks the previous search string.
110  Altmode exits the search unless the string is empty.  Altmode with
111  an empty search string calls the non-incremental search command. 
112  Other control characters cause exit and execution of the appropriate
113  command.  If the search fails at some point, ^G and backspace may be
114  used to backup to a non-failing point; also, ^S and ^R may be used to
115  look the other way.  ^G during a successful search aborts and returns
116  point to where it started."
117  "Search for input string as characters are typed in.
118  It sets up for the recursive searching and checks return values."
119  (declare (ignore p))
120  (setf (last-command-type) nil)
121  (%i-search-echo-refresh "" :forward nil)
122  (let* ((point (current-point))
123         (save-start (copy-mark point :temporary)))
124    (with-mark ((here point))
125      (when (eq (catch 'exit-i-search
126                  (%i-search "" point here :forward nil))
127                :control-g)
128        (move-mark point save-start)
129        (invoke-hook abort-hook)
130        (editor-error))
131      (if (region-active-p)
132          (delete-mark save-start)
133          (push-buffer-mark save-start)))))
134
135
136(defcommand "Reverse Incremental Search" (p)
137  "Searches for input string as characters are provided.
138  These are the default I-Search command characters:  ^Q quotes the
139  next character typed.  Backspace cancels the last character typed.  ^S
140  repeats forward, and ^R repeats backward.  ^R or ^S with empty string
141  either changes the direction or yanks the previous search string.
142  Altmode exits the search unless the string is empty.  Altmode with
143  an empty search string calls the non-incremental search command. 
144  Other control characters cause exit and execution of the appropriate
145  command.  If the search fails at some point, ^G and backspace may be
146  used to backup to a non-failing point; also, ^S and ^R may be used to
147  look the other way.  ^G during a successful search aborts and returns
148  point to where it started."
149  "Search for input string as characters are typed in.
150  It sets up for the recursive searching and checks return values."
151  (declare (ignore p))
152  (setf (last-command-type) nil)
153  (%i-search-echo-refresh "" :backward nil)
154  (let* ((point (current-point))
155         (save-start (copy-mark point :temporary)))
156    (with-mark ((here point))
157      (when (eq (catch 'exit-i-search
158                  (%i-search "" point here :backward nil))
159                :control-g)
160        (move-mark point save-start)
161        (invoke-hook abort-hook)
162        (editor-error))
163      (if (region-active-p)
164          (delete-mark save-start)
165          (push-buffer-mark save-start)))))
166
167;;;      %I-SEARCH recursively (with support functions) searches to provide
168;;; incremental searching.  There is a loop in case the recursion is ever
169;;; unwound to some call.  curr-point must be saved since point is clobbered
170;;; with each recursive call, and the point must be moved back before a
171;;; different letter may be typed at a given call.  In the CASE at :cancel
172;;; and :control-g, if the string is not null, an accurate pattern for this
173;;; call must be provided when %I-SEARCH-CHAR-EVAL is called a second time
174;;; since it is possible for ^S or ^R to be typed.
175;;;
176(defun %i-search (string point trailer direction failure)
177  (do* ((curr-point (copy-mark point :temporary))
178        (curr-trailer (copy-mark trailer :temporary))
179        (doc (hi::buffer-document
180              (hi::line-%buffer (hi::mark-line point)))))
181       (nil)
182    (let ((next-key-event
183           (unwind-protect
184                (progn
185                  (hi::document-end-editing doc)
186                  (get-key-event *editor-input* t))
187             (hi::document-begin-editing doc))))
188      (case (%i-search-char-eval next-key-event string point trailer
189                                 direction failure)
190        (:cancel
191         (%i-search-echo-refresh string direction failure)
192         (unless (zerop (length string))
193           (i-search-pattern string direction)))
194        (:return-cancel
195         (unless (zerop (length string)) (return :cancel))
196         (beep))
197        (:control-g
198         (when failure (return :control-g))
199         (%i-search-echo-refresh string direction nil)
200         (unless (zerop (length string))
201           (i-search-pattern string direction))))
202      (move-mark point curr-point)
203      (move-mark trailer curr-trailer))))
204
205;;;      %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes
206;;; necessary actions.
207;;;
208(defun %i-search-char-eval (key-event string point trailer direction failure)
209  (declare (simple-string string))
210  (cond ((let ((character (key-event-char key-event)))
211           (and character (standard-char-p character)))
212         (%i-search-printed-char key-event string point trailer
213                                 direction failure))
214        ((or (logical-key-event-p key-event :forward-search)
215             (logical-key-event-p key-event :backward-search))
216         (%i-search-control-s-or-r key-event string point trailer
217                                   direction failure))
218        ((logical-key-event-p key-event :cancel) :return-cancel)
219        ((logical-key-event-p key-event :abort)
220         (unless failure
221           (clear-echo-area)
222           (message "Search aborted.")
223           (throw 'exit-i-search :control-g))
224         :control-g)
225        ((logical-key-event-p key-event :quote)
226         (%i-search-printed-char (get-key-event *editor-input* t)
227                                 string point trailer direction failure))
228        ((and (zerop (length string)) (logical-key-event-p key-event :exit))
229         (if (eq direction :forward)
230             (forward-search-command nil)
231             (reverse-search-command nil))
232         (throw 'exit-i-search nil))
233        (t
234         (unless (logical-key-event-p key-event :exit)
235           (unget-key-event key-event *editor-input*))
236         (unless (zerop (length string))
237           (setf *last-search-string* string))
238         (throw 'exit-i-search nil))))
239
240;;;      %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search.  Note
241;;; that there cannot be failure in the last COND branch: since the direction
242;;; has just been changed, there cannot be a failure before trying a new
243;;; direction.
244;;;
245(defun %i-search-control-s-or-r (key-event string point trailer
246                                           direction failure)
247  (let ((forward-direction-p (eq direction :forward))
248        (forward-character-p (logical-key-event-p key-event :forward-search)))
249    (cond ((zerop (length string))
250           (%i-search-empty-string point trailer direction forward-direction-p
251                                   forward-character-p))
252          ((eq forward-direction-p forward-character-p)
253           (if failure
254               (%i-search string point trailer direction failure)
255               (%i-search-find-pattern string point (move-mark trailer point)
256                                       direction)))
257          (t
258           (let ((new-direction (if forward-character-p :forward :backward)))
259             (%i-search-echo-refresh string new-direction nil)
260             (i-search-pattern string new-direction)
261             (%i-search-find-pattern string point (move-mark trailer point)
262                                     new-direction))))))
263
264
265;;;      %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S
266;;; or ^R is typed.  If the direction and character typed do not agree,
267;;; then merely switch directions.  If there was a previous string, search
268;;; for it, else flash at the guy.
269;;;
270(defun %i-search-empty-string (point trailer direction forward-direction-p
271                                     forward-character-p)
272  (cond ((eq forward-direction-p (not forward-character-p))
273         (let ((direction (if forward-character-p :forward :backward)))
274           (%i-search-echo-refresh "" direction nil)
275           (%i-search "" point trailer direction nil)))
276        (*last-search-string*
277         (%i-search-echo-refresh *last-search-string* direction nil)
278         (i-search-pattern *last-search-string* direction)
279         (%i-search-find-pattern *last-search-string* point trailer direction))
280        (t (beep))))
281
282
283;;;      %I-SEARCH-PRINTED-CHAR handles the case of standard character input.
284;;; If the direction is backwards, we have to be careful not to MARK-AFTER
285;;; the end of the buffer or to include the next character at the beginning
286;;; of the search.
287;;;
288(defun %i-search-printed-char (key-event string point trailer direction failure)
289  (let ((tchar (hemlock-ext:key-event-char key-event)))
290    (unless tchar (editor-error "Not a text character -- ~S" (key-event-char
291                                                              key-event)))
292    (when (interactive)
293      (insert-character (buffer-point *echo-area-buffer*) tchar)
294      (force-output *echo-area-stream*))
295    (let ((new-string (concatenate 'simple-string string (string tchar))))
296      (i-search-pattern new-string direction)
297      (cond (failure (%i-search new-string point trailer direction failure))
298            ((and (eq direction :backward) (next-character trailer))
299             (%i-search-find-pattern new-string point (mark-after trailer)
300                                     direction))
301            (t
302             (%i-search-find-pattern new-string point trailer direction))))))
303
304
305;;;      %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction
306;;; and finds it, updating necessary pointers for the next call to %I-SEARCH.
307;;; If the search failed, tell the user and do not move any pointers.
308;;;
309(defun %i-search-find-pattern (string point trailer direction)
310  (let ((found-offset (find-pattern trailer *last-search-pattern*)))
311    (cond (found-offset
312            (cond ((eq direction :forward)
313                   (character-offset (move-mark point trailer) found-offset))
314                  (t
315                   (move-mark point trailer)
316                   (character-offset trailer found-offset)))
317            (%i-search string point trailer direction nil))
318          (t
319           (%i-search-echo-refresh string direction t)
320           (if (interactive)
321               (beep)
322               (editor-error "I-Search failed."))
323           (%i-search string point trailer direction t)))))
324
325
326
327;;;; Replacement commands:
328
329(defcommand "Replace String" (p &optional
330                                (target (prompt-for-string
331                                         :prompt "Replace String: "
332                                         :help "Target string"
333                                         :default *last-search-string*))
334                                (replacement (prompt-for-string
335                                              :prompt "With: "
336                                              :help "Replacement string")))
337  "Replaces the specified Target string with the specified Replacement
338   string in the current buffer for all occurrences after the point or within
339   the active region, depending on whether it is active."
340  "Replaces the specified Target string with the specified Replacement
341   string in the current buffer for all occurrences after the point or within
342   the active region, depending on whether it is active.  The prefix argument
343   may limit the number of replacements."
344  (multiple-value-bind (ignore count)
345                       (query-replace-function p target replacement
346                                               "Replace String" t)
347    (declare (ignore ignore))
348    (message "~D Occurrences replaced." count)))
349
350(defcommand "Query Replace" (p &optional
351                               (target (prompt-for-string
352                                        :prompt "Query Replace: "
353                                        :help "Target string"
354                                        :default *last-search-string*))
355                               (replacement (prompt-for-string
356                                             :prompt "With: "
357                                             :help "Replacement string")))
358  "Replaces the Target string with the Replacement string if confirmation
359   from the keyboard is given.  If the region is active, limit queries to
360   occurrences that occur within it, otherwise use point to end of buffer."
361  "Replaces the Target string with the Replacement string if confirmation
362   from the keyboard is given.  If the region is active, limit queries to
363   occurrences that occur within it, otherwise use point to end of buffer.
364   A prefix argument may limit the number of queries."
365  (let ((mark (copy-mark (current-point))))
366    (multiple-value-bind (ignore count)
367                         (query-replace-function p target replacement
368                                                 "Query Replace")
369      (declare (ignore ignore))
370      (message "~D Occurrences replaced." count))
371    (push-buffer-mark mark)))
372
373
374(defhvar "Case Replace"
375  "If this is true then \"Query Replace\" will try to preserve case when
376  doing replacements."
377  :value t)
378
379(defstruct (replace-undo (:constructor make-replace-undo (mark region)))
380  mark
381  region)
382
383(setf (documentation 'replace-undo-mark 'function)
384      "Return the mark where a replacement was made.")
385(setf (documentation 'replace-undo-region 'function)
386      "Return region deleted due to replacement.")
387
388(defvar *query-replace-undo-data* nil)
389
390;;; REPLACE-THAT-CASE replaces a string case-sensitively.  Lower, Cap and Upper
391;;; are the original, capitalized and uppercase replacement strings.  Mark is a
392;;; :left-inserting mark after the text to be replaced.  Length is the length
393;;; of the target string.  If dumb, then do a simple replace.  This pushes
394;;; an undo information structure into *query-replace-undo-data* which
395;;; QUERY-REPLACE-FUNCTION uses.
396;;;
397(defun replace-that-case (lower cap upper mark length dumb)
398  (character-offset mark (- length))
399  (let ((insert (cond (dumb lower)
400                      ((upper-case-p (next-character mark))
401                       (mark-after mark)
402                       (prog1 (if (upper-case-p (next-character mark)) upper cap)
403                              (mark-before mark)))
404                      (t lower))))
405    (with-mark ((undo-mark1 mark :left-inserting)
406                (undo-mark2 mark :left-inserting))
407      (character-offset undo-mark2 length)
408      (push (make-replace-undo
409             ;; Save :right-inserting, so the INSERT-STRING at mark below
410             ;; doesn't move the copied mark the past replacement.
411             (copy-mark mark :right-inserting)
412             (delete-and-save-region (region undo-mark1 undo-mark2)))
413            *query-replace-undo-data*))
414    (insert-string mark insert)))
415
416;;; QUERY-REPLACE-FUNCTION does the work for the main replacement commands:
417;;; "Query Replace", "Replace String", "Group Query Replace", "Group Replace".
418;;; Name is the name of the command for undoing purposes.  If doing-all? is
419;;; true, this replaces all ocurrences for the non-querying commands.  This
420;;; returns t if it completes successfully, and nil if it is aborted.  As a
421;;; second value, it returns the number of replacements.
422;;;
423;;; The undo method, before undo'ing anything, makes all marks :left-inserting.
424;;; There's a problem when two replacements are immediately adjacent, such as
425;;;    foofoo
426;;; replacing "foo" with "bar".  If the marks were still :right-inserting as
427;;; REPLACE-THAT-CASE makes them, then undo'ing the first replacement would
428;;; bring the two marks together due to the DELETE-CHARACTERS.  Then inserting
429;;; the region would move the second replacement's mark to be before the first
430;;; replacement.
431;;;
432(defun query-replace-function (count target replacement name
433                               &optional (doing-all? nil))
434  (declare (simple-string replacement))
435  (let ((replacement-len (length replacement))
436        (*query-replace-undo-data* nil))
437    (when (and count (minusp count))
438      (editor-error "Replacement count is negative."))
439    (get-search-pattern target :forward)
440    (unwind-protect
441        (query-replace-loop (get-count-region) (or count -1) target replacement
442                            replacement-len (current-point) doing-all?)
443      (let ((undo-data (nreverse *query-replace-undo-data*)))
444        (save-for-undo name
445          #'(lambda ()
446              (dolist (ele undo-data)
447                (setf (mark-kind (replace-undo-mark ele)) :left-inserting))
448              (dolist (ele undo-data)
449                (let ((mark (replace-undo-mark ele)))
450                  (delete-characters mark replacement-len)
451                  (ninsert-region mark (replace-undo-region ele)))))
452          #'(lambda ()
453              (dolist (ele undo-data)
454                (delete-mark (replace-undo-mark ele)))))))))
455
456;;; QUERY-REPLACE-LOOP is the essence of QUERY-REPLACE-FUNCTION.  The first
457;;; value is whether we completed all replacements, nil if we aborted.  The
458;;; second value is how many replacements occurred.
459;;;
460(defun query-replace-loop (region count target replacement replacement-len
461                           point doing-all?)
462  (with-mark ((last-found point)
463              ;; Copy REGION-END before moving point to REGION-START in case
464              ;; the end is point.  Also, make it permanent in case we make
465              ;; replacements on the last line containing the end.
466              (stop-mark (region-end region) :left-inserting))
467    (move-mark point (region-start region))
468    (let ((length (length target))
469          (cap (string-capitalize replacement))
470          (upper (string-upcase replacement))
471          (dumb (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
472                                                    (lower-case-p ch)))
473                                 (the string replacement))
474                          (value case-replace)))))
475      (values
476       (loop
477         (let ((won (find-pattern point *last-search-pattern*)))
478           (when (or (null won) (zerop count) (mark> point stop-mark))
479             (character-offset (move-mark point last-found) replacement-len)
480             (return t))
481           (decf count)
482           (move-mark last-found point)
483           (character-offset point length)
484           (if doing-all?
485               (replace-that-case replacement cap upper point length dumb)
486               (command-case
487                   (:prompt
488                    "Query replace: "
489                    :help "Type one of the following single-character commands:"
490                    :change-window nil :bind key-event)
491                 (:yes "Replace this occurrence."
492                       (replace-that-case replacement cap upper point length
493                                          dumb))
494                 (:no "Don't replace this occurrence, but continue.")
495                 (:do-all "Replace this and all remaining occurrences."
496                          (replace-that-case replacement cap upper point length
497                                             dumb)
498                          (setq doing-all? t))
499                 (:do-once "Replace this occurrence, then exit."
500                           (replace-that-case replacement cap upper point length
501                                              dumb)
502                           (return nil))
503                 (:recursive-edit
504                  "Go into a recursive edit at the current position."
505                  (do-recursive-edit)
506                  (get-search-pattern target :forward))
507                 (:exit "Exit immediately."
508                        (return nil))
509                 (t (unget-key-event key-event *editor-input*)
510                    (return nil))))))
511       (length (the list *query-replace-undo-data*))))))
512
513
514
515;;;; Occurrence searching.
516
517(defcommand "List Matching Lines" (p &optional string)
518  "Prompts for a search string and lists all matching lines after the point or
519   within the current-region, depending on whether it is active or not.
520   With an argument, lists p lines before and after each matching line."
521  "Prompts for a search string and lists all matching lines after the point or
522   within the current-region, depending on whether it is active or not.
523   With an argument, lists p lines before and after each matching line."
524  (unless string
525    (setf string (prompt-for-string :prompt "List Matching: "
526                                    :default *last-search-string*
527                                    :help "String to search for")))
528  (let ((pattern (get-search-pattern string :forward))
529        (matching-lines nil)
530        (region (get-count-region)))
531    (with-mark ((mark (region-start region))
532                (end-mark (region-end region)))
533      (loop
534        (when (or (null (find-pattern mark pattern)) (mark> mark end-mark))
535          (return))
536        (setf matching-lines
537              (nconc matching-lines (list-lines mark (or p 0))))
538        (unless (line-offset mark 1 0)
539          (return))))
540    (with-pop-up-display (s :height (length matching-lines))
541      (dolist (line matching-lines)
542        (write-line line s)))))
543
544;;; LIST-LINES creates a lists of strings containing (num) lines before the
545;;; line that the point is on, the line that the point is on, and (num)
546;;; lines after the line that the point is on. If (num) > 0, a string of
547;;; dashes will be added to make life easier for List Matching Lines.
548;;;
549(defun list-lines (mark num)
550  (if (<= num 0)
551      (list (line-string (mark-line mark)))
552      (with-mark ((mark mark)
553                  (beg-mark mark))
554        (unless (line-offset beg-mark (- num))
555          (buffer-start beg-mark))
556        (unless (line-offset mark num)
557          (buffer-end mark))
558        (let ((lines (list "--------")))
559          (loop
560            (push (line-string (mark-line mark)) lines)
561            (when (same-line-p mark beg-mark)
562              (return lines))
563            (line-offset mark -1))))))
564
565(defcommand "Delete Matching Lines" (p &optional string)
566  "Deletes all lines that match the search pattern using delete-region. If
567   the current region is active, limit the search to it. The argument is
568   ignored."
569  "Deletes all lines that match the search pattern using delete-region. If
570   the current region is active, limit the search to it. The argument is
571   ignored."
572  (declare (ignore p))
573  (unless string
574    (setf string (prompt-for-string :prompt "Delete Matching: "
575                                    :default *last-search-string*
576                                    :help "String to search for")))
577  (let* ((region (get-count-region))
578         (pattern (get-search-pattern string :forward))
579         (start-mark (region-start region))
580         (end-mark (region-end region)))
581    (with-mark ((bol-mark start-mark :left-inserting)
582                (eol-mark start-mark :right-inserting))
583      (loop
584        (unless (and (find-pattern bol-mark pattern) (mark< bol-mark end-mark))
585          (return))
586        (move-mark eol-mark bol-mark)
587        (line-start bol-mark)
588        (unless (line-offset eol-mark 1 0)
589          (buffer-end eol-mark))
590        (delete-region (region bol-mark eol-mark))))))
591
592(defcommand "Delete Non-Matching Lines" (p &optional string)
593  "Deletes all lines that do not match the search pattern using delete-region.
594   If the current-region is active, limit the search to it. The argument is
595   ignored."
596  "Deletes all lines that do not match the search pattern using delete-region.
597   If the current-region is active, limit the search to it. The argument is
598   ignored."
599  (declare (ignore p))
600  (unless string
601    (setf string (prompt-for-string :prompt "Delete Non-Matching:"
602                                    :default *last-search-string*
603                                    :help "String to search for")))
604  (let* ((region (get-count-region))
605         (start-mark (region-start region))
606         (stop-mark (region-end region))
607         (pattern (get-search-pattern string :forward)))
608    (with-mark ((beg-mark start-mark :left-inserting)
609                (end-mark start-mark :right-inserting))
610      (loop
611        (move-mark end-mark beg-mark)
612        (cond ((and (find-pattern end-mark pattern) (mark< end-mark stop-mark))
613               (line-start end-mark)
614               (delete-region (region beg-mark end-mark))
615               (unless (line-offset beg-mark 1 0)
616                 (return)))
617              (t
618               (delete-region (region beg-mark stop-mark))
619               (return)))))))
620
621(defcommand "Count Occurrences" (p &optional string)
622  "Prompts for a search string and counts occurrences of it after the point or
623   within the current-region, depending on whether it is active or not. The
624   argument is ignored."
625  "Prompts for a search string and counts occurrences of it after the point or
626   within the current-region, depending on whether it is active or not. The
627   argument is ignored."
628  (declare (ignore p))
629  (unless string
630    (setf string (prompt-for-string
631                  :prompt "Count Occurrences: "
632                  :default *last-search-string*
633                  :help "String to search for")))
634  (message "~D occurrence~:P"
635           (count-occurrences-region (get-count-region) string)))
636
637(defun count-occurrences-region (region string)
638  (let ((pattern (get-search-pattern string :forward))
639        (end-mark (region-end region)))
640    (let ((occurrences 0))
641      (with-mark ((mark (region-start region)))
642        (loop
643          (let ((won (find-pattern mark pattern)))
644            (when (or (null won) (mark> mark end-mark))
645              (return))
646            (incf occurrences)
647            (character-offset mark won))))
648      occurrences)))
Note: See TracBrowser for help on using the repository browser.