[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp

[Matthieu Villeneuve]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv23067

Modified Files:
	base.lisp gui.lisp packages.lisp 
Log Message:
Made query-replace respect the case of replaced strings.
Date: Sun Jan 30 11:56:54 2005
Author: mvilleneuve

Index: climacs/base.lisp
diff -u climacs/base.lisp:1.29 climacs/base.lisp:1.30
--- climacs/base.lisp:1.29	Sat Jan 29 05:16:25 2005
+++ climacs/base.lisp	Sun Jan 30 11:56:53 2005
@@ -219,6 +219,29 @@
 ;;; 
 ;;; Character case
 
+(defun buffer-region-case (buffer offset1 offset2)
+  (let ((possibly-uppercase t)
+        (possibly-lowercase t)
+        (possibly-capitalized t))
+    (do-buffer-region (object offset buffer offset1 offset2)
+      (unless (characterp object)
+        (return-from buffer-region-case nil))
+      (when (lower-case-p object)
+        (setf possibly-uppercase nil))
+      (when (upper-case-p object)
+        (setf possibly-lowercase nil))
+      (when (plusp offset)
+        (let ((previous-object (buffer-object buffer (1- offset))))
+          (when (and (characterp previous-object)
+                     (if (constituentp previous-object)
+                         (upper-case-p object)
+                         (lower-case-p object)))
+            (setf possibly-capitalized nil)))))
+    (cond (possibly-uppercase :upper-case)
+          (possibly-lowercase :lower-case)
+          (possibly-capitalized :capitalized)
+          (t nil))))
+
 ;;; I'd rather have update-buffer-range methods spec. on buffer for this,
 ;;; for performance and history-size reasons --amb
 (defun downcase-buffer-region (buffer offset1 offset2)


Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.103 climacs/gui.lisp:1.104
--- climacs/gui.lisp:1.103	Fri Jan 28 23:05:42 2005
+++ climacs/gui.lisp	Sun Jan 30 11:56:53 2005
@@ -1120,9 +1120,13 @@
 ;;; Query replace
 
 (defun query-replace-find-next-match (mark string)
-  (let ((offset-before (offset mark)))
-    (search-forward mark string)
-    (/= (offset mark) offset-before)))
+  (flet ((object-equal (x y)
+           (and (characterp x)
+                (characterp y)
+                (char-equal x y))))
+    (let ((offset-before (offset mark)))
+      (search-forward mark string :test #'object-equal)
+      (/= (offset mark) offset-before))))
 
 (define-named-command com-query-replace ()
   (let* ((string1 (accept 'string :prompt "Query replace"))
@@ -1143,11 +1147,21 @@
 (define-named-command com-query-replace-replace ()
   (let* ((pane (current-window))
          (point (point pane))
+         (buffer (buffer pane))
          (state (query-replace-state pane))
          (string1-length (length (string1 state))))
     (backward-object point string1-length)
-    (delete-range point string1-length)
-    (insert-sequence point (string2 state))
+    (let* ((offset1 (offset point))
+           (offset2 (+ offset1 string1-length))
+           (region-case (buffer-region-case buffer offset1 offset2)))
+      (delete-range point string1-length)
+      (insert-sequence point (string2 state))
+      (setf offset2 (+ offset1 (length (string2 state))))
+      (finish-output *error-output*)
+      (case region-case
+        (:upper-case (upcase-buffer-region buffer offset1 offset2))
+        (:lower-case (downcase-buffer-region buffer offset1 offset2))
+        (:capitalized (capitalize-buffer-region buffer offset1 offset2))))
     (unless (query-replace-find-next-match point (string1 state))
       (setf (query-replace-mode pane) nil))))
 


Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.42 climacs/packages.lisp:1.43
--- climacs/packages.lisp:1.42	Wed Jan 26 14:49:47 2005
+++ climacs/packages.lisp	Sun Jan 30 11:56:53 2005
@@ -59,7 +59,10 @@
 	   #:constituentp #:whitespacep
 	   #:forward-word #:backward-word
 	   #:delete-word #:backward-delete-word
-           #:upcase-region #:downcase-region #:capitalize-region
+           #:buffer-region-case
+           #:upcase-buffer-region #:upcase-region
+           #:downcase-buffer-region #:downcase-region
+           #:capitalize-buffer-region #:capitalize-region
            #:upcase-word #:downcase-word #:capitalize-word
            #:tabify-region #:untabify-region
            #:indent-line