/[cmucl]/src/hemlock/searchcoms.lisp
ViewVC logotype

Contents of /src/hemlock/searchcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Feb 25 15:18:34 2003 UTC (11 years, 2 months ago) by emarsden
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +34 -1 lines
From Luke Gorrie:

   - add support for copy-word during isearch (bound to C-w as per GNU Emacs)
   - add dabbrev support (bound to M-/)
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/searchcoms.lisp,v 1.5 2003/02/25 15:18:34 emarsden Rel $")
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 (nil)
180 (let ((next-key-event (get-key-event *editor-input* t)))
181 (case (%i-search-char-eval next-key-event string point trailer
182 direction failure)
183 (:cancel
184 (%i-search-echo-refresh string direction failure)
185 (unless (zerop (length string))
186 (i-search-pattern string direction)))
187 (:return-cancel
188 (unless (zerop (length string)) (return :cancel))
189 (beep))
190 (:control-g
191 (when failure (return :control-g))
192 (%i-search-echo-refresh string direction nil)
193 (unless (zerop (length string))
194 (i-search-pattern string direction))))
195 (move-mark point curr-point)
196 (move-mark trailer curr-trailer))))
197
198 ;;; %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes
199 ;;; necessary actions.
200 ;;;
201 (defun %i-search-char-eval (key-event string point trailer direction failure)
202 (declare (simple-string string))
203 (cond ((let ((character (key-event-char key-event)))
204 (and character (standard-char-p character)))
205 (%i-search-printed-char key-event string point trailer
206 direction failure))
207 ((or (logical-key-event-p key-event :forward-search)
208 (logical-key-event-p key-event :backward-search))
209 (%i-search-control-s-or-r key-event string point trailer
210 direction failure))
211 ((logical-key-event-p key-event :cancel) :return-cancel)
212 ((logical-key-event-p key-event :abort)
213 (unless failure
214 (clear-echo-area)
215 (message "Search aborted.")
216 (throw 'exit-i-search :control-g))
217 :control-g)
218 ((logical-key-event-p key-event :quote)
219 (%i-search-printed-char (get-key-event *editor-input* t)
220 string point trailer direction failure))
221 ((equalp key-event #k"C-w")
222 (%i-search-copy-word key-event
223 string point trailer direction failure))
224 ((and (zerop (length string)) (logical-key-event-p key-event :exit))
225 (if (eq direction :forward)
226 (forward-search-command nil)
227 (reverse-search-command nil))
228 (throw 'exit-i-search nil))
229 (t
230 (unless (logical-key-event-p key-event :exit)
231 (unget-key-event key-event *editor-input*))
232 (unless (zerop (length string))
233 (setf *last-search-string* string))
234 (throw 'exit-i-search nil))))
235
236 ;;; %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search. Note
237 ;;; that there cannot be failure in the last COND branch: since the direction
238 ;;; has just been changed, there cannot be a failure before trying a new
239 ;;; direction.
240 ;;;
241 (defun %i-search-control-s-or-r (key-event string point trailer
242 direction failure)
243 (let ((forward-direction-p (eq direction :forward))
244 (forward-character-p (logical-key-event-p key-event :forward-search)))
245 (cond ((zerop (length string))
246 (%i-search-empty-string point trailer direction forward-direction-p
247 forward-character-p))
248 ((eq forward-direction-p forward-character-p)
249 (if failure
250 (%i-search string point trailer direction failure)
251 (%i-search-find-pattern string point (move-mark trailer point)
252 direction)))
253 (t
254 (let ((new-direction (if forward-character-p :forward :backward)))
255 (%i-search-echo-refresh string new-direction nil)
256 (i-search-pattern string new-direction)
257 (%i-search-find-pattern string point (move-mark trailer point)
258 new-direction))))))
259
260
261 ;;; %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S
262 ;;; or ^R is typed. If the direction and character typed do not agree,
263 ;;; then merely switch directions. If there was a previous string, search
264 ;;; for it, else flash at the guy.
265 ;;;
266 (defun %i-search-empty-string (point trailer direction forward-direction-p
267 forward-character-p)
268 (cond ((eq forward-direction-p (not forward-character-p))
269 (let ((direction (if forward-character-p :forward :backward)))
270 (%i-search-echo-refresh "" direction nil)
271 (%i-search "" point trailer direction nil)))
272 (*last-search-string*
273 (%i-search-echo-refresh *last-search-string* direction nil)
274 (i-search-pattern *last-search-string* direction)
275 (%i-search-find-pattern *last-search-string* point trailer direction))
276 (t (beep))))
277
278
279 ;;; %I-SEARCH-PRINTED-CHAR handles the case of standard character input.
280 ;;; If the direction is backwards, we have to be careful not to MARK-AFTER
281 ;;; the end of the buffer or to include the next character at the beginning
282 ;;; of the search.
283 ;;;
284 (defun %i-search-printed-char (key-event string point trailer direction failure)
285 (let ((tchar (ext:key-event-char key-event)))
286 (unless tchar (editor-error "Not a text character -- ~S" (key-event-char
287 key-event)))
288 (when (interactive)
289 (insert-character (buffer-point *echo-area-buffer*) tchar)
290 (force-output *echo-area-stream*))
291 (let ((new-string (concatenate 'simple-string string (string tchar))))
292 (i-search-pattern new-string direction)
293 (cond (failure (%i-search new-string point trailer direction failure))
294 ((and (eq direction :backward) (next-character trailer))
295 (%i-search-find-pattern new-string point (mark-after trailer)
296 direction))
297 (t
298 (%i-search-find-pattern new-string point trailer direction))))))
299
300 ;;; %I-SEARCH-COPY-WORD handles the "take the next word of the current
301 ;;; match" case, like C-w in GNU Emacs. By Luke Gorrie.
302
303 (defun %i-search-copy-word (key-event string point trailer direction failure)
304 ;; begin by finding the region starting at the end of the current
305 ;; search and ending after the next word.
306 (let ((start-mark (copy-mark point :temporary)))
307 ;; when going backwards, the point is at the beginning of the search string,
308 ;; so we have to move start-mark to the end
309 (when (eq direction :backward)
310 (character-offset start-mark (length string)))
311 (let* ((end-mark (copy-mark start-mark :temporary))
312 (word-region (region start-mark end-mark)))
313 ;; advance end-mark to the end of the word
314 (and (find-attribute end-mark :word-delimiter #'zerop)
315 (find-attribute (mark-after end-mark) :word-delimiter)
316 ;; the region is correct, now we can extract the text and
317 ;; update the search string
318 (let* ((new-fragment (region-to-string word-region))
319 (new-string (concatenate 'simple-string string new-fragment)))
320 ;; update the status message
321 (when (interactive)
322 (insert-string (buffer-point *echo-area-buffer*) new-fragment)
323 (force-output *echo-area-stream*))
324 (i-search-pattern new-string direction)
325 (cond (failure (%i-search new-string point trailer direction failure))
326 (t
327 (when (eq direction :backward)
328 (move-mark trailer end-mark))
329 (%i-search-find-pattern new-string point trailer direction))))))))
330
331 ;;; %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction
332 ;;; and finds it, updating necessary pointers for the next call to %I-SEARCH.
333 ;;; If the search failed, tell the user and do not move any pointers.
334 ;;;
335 (defun %i-search-find-pattern (string point trailer direction)
336 (let ((found-offset (find-pattern trailer *last-search-pattern*)))
337 (cond (found-offset
338 (cond ((eq direction :forward)
339 (character-offset (move-mark point trailer) found-offset))
340 (t
341 (move-mark point trailer)
342 (character-offset trailer found-offset)))
343 (%i-search string point trailer direction nil))
344 (t
345 (%i-search-echo-refresh string direction t)
346 (if (interactive)
347 (beep)
348 (editor-error "I-Search failed."))
349 (%i-search string point trailer direction t)))))
350
351
352
353 ;;;; Replacement commands:
354
355 (defcommand "Replace String" (p &optional
356 (target (prompt-for-string
357 :prompt "Replace String: "
358 :help "Target string"
359 :default *last-search-string*))
360 (replacement (prompt-for-string
361 :prompt "With: "
362 :help "Replacement string")))
363 "Replaces the specified Target string with the specified Replacement
364 string in the current buffer for all occurrences after the point or within
365 the active region, depending on whether it is active."
366 "Replaces the specified Target string with the specified Replacement
367 string in the current buffer for all occurrences after the point or within
368 the active region, depending on whether it is active. The prefix argument
369 may limit the number of replacements."
370 (multiple-value-bind (ignore count)
371 (query-replace-function p target replacement
372 "Replace String" t)
373 (declare (ignore ignore))
374 (message "~D Occurrences replaced." count)))
375
376 (defcommand "Query Replace" (p &optional
377 (target (prompt-for-string
378 :prompt "Query Replace: "
379 :help "Target string"
380 :default *last-search-string*))
381 (replacement (prompt-for-string
382 :prompt "With: "
383 :help "Replacement string")))
384 "Replaces the Target string with the Replacement string if confirmation
385 from the keyboard is given. If the region is active, limit queries to
386 occurrences that occur within it, otherwise use point to end of buffer."
387 "Replaces the Target string with the Replacement string if confirmation
388 from the keyboard is given. If the region is active, limit queries to
389 occurrences that occur within it, otherwise use point to end of buffer.
390 A prefix argument may limit the number of queries."
391 (let ((mark (copy-mark (current-point))))
392 (multiple-value-bind (ignore count)
393 (query-replace-function p target replacement
394 "Query Replace")
395 (declare (ignore ignore))
396 (message "~D Occurrences replaced." count))
397 (push-buffer-mark mark)))
398
399
400 (defhvar "Case Replace"
401 "If this is true then \"Query Replace\" will try to preserve case when
402 doing replacements."
403 :value t)
404
405 (defstruct (replace-undo (:constructor make-replace-undo (mark region)))
406 mark
407 region)
408
409 (setf (documentation 'replace-undo-mark 'function)
410 "Return the mark where a replacement was made.")
411 (setf (documentation 'replace-undo-region 'function)
412 "Return region deleted due to replacement.")
413
414 (defvar *query-replace-undo-data* nil)
415
416 ;;; REPLACE-THAT-CASE replaces a string case-sensitively. Lower, Cap and Upper
417 ;;; are the original, capitalized and uppercase replacement strings. Mark is a
418 ;;; :left-inserting mark after the text to be replaced. Length is the length
419 ;;; of the target string. If dumb, then do a simple replace. This pushes
420 ;;; an undo information structure into *query-replace-undo-data* which
421 ;;; QUERY-REPLACE-FUNCTION uses.
422 ;;;
423 (defun replace-that-case (lower cap upper mark length dumb)
424 (character-offset mark (- length))
425 (let ((insert (cond (dumb lower)
426 ((upper-case-p (next-character mark))
427 (mark-after mark)
428 (prog1 (if (upper-case-p (next-character mark)) upper cap)
429 (mark-before mark)))
430 (t lower))))
431 (with-mark ((undo-mark1 mark :left-inserting)
432 (undo-mark2 mark :left-inserting))
433 (character-offset undo-mark2 length)
434 (push (make-replace-undo
435 ;; Save :right-inserting, so the INSERT-STRING at mark below
436 ;; doesn't move the copied mark the past replacement.
437 (copy-mark mark :right-inserting)
438 (delete-and-save-region (region undo-mark1 undo-mark2)))
439 *query-replace-undo-data*))
440 (insert-string mark insert)))
441
442 ;;; QUERY-REPLACE-FUNCTION does the work for the main replacement commands:
443 ;;; "Query Replace", "Replace String", "Group Query Replace", "Group Replace".
444 ;;; Name is the name of the command for undoing purposes. If doing-all? is
445 ;;; true, this replaces all ocurrences for the non-querying commands. This
446 ;;; returns t if it completes successfully, and nil if it is aborted. As a
447 ;;; second value, it returns the number of replacements.
448 ;;;
449 ;;; The undo method, before undo'ing anything, makes all marks :left-inserting.
450 ;;; There's a problem when two replacements are immediately adjacent, such as
451 ;;; foofoo
452 ;;; replacing "foo" with "bar". If the marks were still :right-inserting as
453 ;;; REPLACE-THAT-CASE makes them, then undo'ing the first replacement would
454 ;;; bring the two marks together due to the DELETE-CHARACTERS. Then inserting
455 ;;; the region would move the second replacement's mark to be before the first
456 ;;; replacement.
457 ;;;
458 (defun query-replace-function (count target replacement name
459 &optional (doing-all? nil))
460 (declare (simple-string replacement))
461 (let ((replacement-len (length replacement))
462 (*query-replace-undo-data* nil))
463 (when (and count (minusp count))
464 (editor-error "Replacement count is negative."))
465 (get-search-pattern target :forward)
466 (unwind-protect
467 (query-replace-loop (get-count-region) (or count -1) target replacement
468 replacement-len (current-point) doing-all?)
469 (let ((undo-data (nreverse *query-replace-undo-data*)))
470 (save-for-undo name
471 #'(lambda ()
472 (dolist (ele undo-data)
473 (setf (mark-kind (replace-undo-mark ele)) :left-inserting))
474 (dolist (ele undo-data)
475 (let ((mark (replace-undo-mark ele)))
476 (delete-characters mark replacement-len)
477 (ninsert-region mark (replace-undo-region ele)))))
478 #'(lambda ()
479 (dolist (ele undo-data)
480 (delete-mark (replace-undo-mark ele)))))))))
481
482 ;;; QUERY-REPLACE-LOOP is the essence of QUERY-REPLACE-FUNCTION. The first
483 ;;; value is whether we completed all replacements, nil if we aborted. The
484 ;;; second value is how many replacements occurred.
485 ;;;
486 (defun query-replace-loop (region count target replacement replacement-len
487 point doing-all?)
488 (with-mark ((last-found point)
489 ;; Copy REGION-END before moving point to REGION-START in case
490 ;; the end is point. Also, make it permanent in case we make
491 ;; replacements on the last line containing the end.
492 (stop-mark (region-end region) :left-inserting))
493 (move-mark point (region-start region))
494 (let ((length (length target))
495 (cap (string-capitalize replacement))
496 (upper (string-upcase replacement))
497 (dumb (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
498 (lower-case-p ch)))
499 (the string replacement))
500 (value case-replace)))))
501 (values
502 (loop
503 (let ((won (find-pattern point *last-search-pattern*)))
504 (when (or (null won) (zerop count) (mark> point stop-mark))
505 (character-offset (move-mark point last-found) replacement-len)
506 (return t))
507 (decf count)
508 (move-mark last-found point)
509 (character-offset point length)
510 (if doing-all?
511 (replace-that-case replacement cap upper point length dumb)
512 (command-case
513 (:prompt
514 "Query replace: "
515 :help "Type one of the following single-character commands:"
516 :change-window nil :bind key-event)
517 (:yes "Replace this occurrence."
518 (replace-that-case replacement cap upper point length
519 dumb))
520 (:no "Don't replace this occurrence, but continue.")
521 (:do-all "Replace this and all remaining occurrences."
522 (replace-that-case replacement cap upper point length
523 dumb)
524 (setq doing-all? t))
525 (:do-once "Replace this occurrence, then exit."
526 (replace-that-case replacement cap upper point length
527 dumb)
528 (return nil))
529 (:recursive-edit
530 "Go into a recursive edit at the current position."
531 (do-recursive-edit)
532 (get-search-pattern target :forward))
533 (:exit "Exit immediately."
534 (return nil))
535 (t (unget-key-event key-event *editor-input*)
536 (return nil))))))
537 (length (the list *query-replace-undo-data*))))))
538
539
540
541 ;;;; Occurrence searching.
542
543 (defcommand "List Matching Lines" (p &optional string)
544 "Prompts for a search string and lists all matching lines after the point or
545 within the current-region, depending on whether it is active or not.
546 With an argument, lists p lines before and after each matching line."
547 "Prompts for a search string and lists all matching lines after the point or
548 within the current-region, depending on whether it is active or not.
549 With an argument, lists p lines before and after each matching line."
550 (unless string
551 (setf string (prompt-for-string :prompt "List Matching: "
552 :default *last-search-string*
553 :help "String to search for")))
554 (let ((pattern (get-search-pattern string :forward))
555 (matching-lines nil)
556 (region (get-count-region)))
557 (with-mark ((mark (region-start region))
558 (end-mark (region-end region)))
559 (loop
560 (when (or (null (find-pattern mark pattern)) (mark> mark end-mark))
561 (return))
562 (setf matching-lines
563 (nconc matching-lines (list-lines mark (or p 0))))
564 (unless (line-offset mark 1 0)
565 (return))))
566 (with-pop-up-display (s :height (length matching-lines))
567 (dolist (line matching-lines)
568 (write-line line s)))))
569
570 ;;; LIST-LINES creates a lists of strings containing (num) lines before the
571 ;;; line that the point is on, the line that the point is on, and (num)
572 ;;; lines after the line that the point is on. If (num) > 0, a string of
573 ;;; dashes will be added to make life easier for List Matching Lines.
574 ;;;
575 (defun list-lines (mark num)
576 (if (<= num 0)
577 (list (line-string (mark-line mark)))
578 (with-mark ((mark mark)
579 (beg-mark mark))
580 (unless (line-offset beg-mark (- num))
581 (buffer-start beg-mark))
582 (unless (line-offset mark num)
583 (buffer-end mark))
584 (let ((lines (list "--------")))
585 (loop
586 (push (line-string (mark-line mark)) lines)
587 (when (same-line-p mark beg-mark)
588 (return lines))
589 (line-offset mark -1))))))
590
591 (defcommand "Delete Matching Lines" (p &optional string)
592 "Deletes all lines that match the search pattern using delete-region. If
593 the current region is active, limit the search to it. The argument is
594 ignored."
595 "Deletes all lines that match the search pattern using delete-region. If
596 the current region is active, limit the search to it. The argument is
597 ignored."
598 (declare (ignore p))
599 (unless string
600 (setf string (prompt-for-string :prompt "Delete Matching: "
601 :default *last-search-string*
602 :help "String to search for")))
603 (let* ((region (get-count-region))
604 (pattern (get-search-pattern string :forward))
605 (start-mark (region-start region))
606 (end-mark (region-end region)))
607 (with-mark ((bol-mark start-mark :left-inserting)
608 (eol-mark start-mark :right-inserting))
609 (loop
610 (unless (and (find-pattern bol-mark pattern) (mark< bol-mark end-mark))
611 (return))
612 (move-mark eol-mark bol-mark)
613 (line-start bol-mark)
614 (unless (line-offset eol-mark 1 0)
615 (buffer-end eol-mark))
616 (delete-region (region bol-mark eol-mark))))))
617
618 (defcommand "Delete Non-Matching Lines" (p &optional string)
619 "Deletes all lines that do not match the search pattern using delete-region.
620 If the current-region is active, limit the search to it. The argument is
621 ignored."
622 "Deletes all lines that do not match the search pattern using delete-region.
623 If the current-region is active, limit the search to it. The argument is
624 ignored."
625 (declare (ignore p))
626 (unless string
627 (setf string (prompt-for-string :prompt "Delete Non-Matching:"
628 :default *last-search-string*
629 :help "String to search for")))
630 (let* ((region (get-count-region))
631 (start-mark (region-start region))
632 (stop-mark (region-end region))
633 (pattern (get-search-pattern string :forward)))
634 (with-mark ((beg-mark start-mark :left-inserting)
635 (end-mark start-mark :right-inserting))
636 (loop
637 (move-mark end-mark beg-mark)
638 (cond ((and (find-pattern end-mark pattern) (mark< end-mark stop-mark))
639 (line-start end-mark)
640 (delete-region (region beg-mark end-mark))
641 (unless (line-offset beg-mark 1 0)
642 (return)))
643 (t
644 (delete-region (region beg-mark stop-mark))
645 (return)))))))
646
647 (defcommand "Count Occurrences" (p &optional string)
648 "Prompts for a search string and counts occurrences of it after the point or
649 within the current-region, depending on whether it is active or not. The
650 argument is ignored."
651 "Prompts for a search string and counts occurrences of it after the point or
652 within the current-region, depending on whether it is active or not. The
653 argument is ignored."
654 (declare (ignore p))
655 (unless string
656 (setf string (prompt-for-string
657 :prompt "Count Occurrences: "
658 :default *last-search-string*
659 :help "String to search for")))
660 (message "~D occurrence~:P"
661 (count-occurrences-region (get-count-region) string)))
662
663 (defun count-occurrences-region (region string)
664 (let ((pattern (get-search-pattern string :forward))
665 (end-mark (region-end region)))
666 (let ((occurrences 0))
667 (with-mark ((mark (region-start region)))
668 (loop
669 (let ((won (find-pattern mark pattern)))
670 (when (or (null won) (mark> mark end-mark))
671 (return))
672 (incf occurrences)
673 (character-offset mark won))))
674 occurrences)))

  ViewVC Help
Powered by ViewVC 1.1.5