[mcclim-cvs] CVS mcclim/Drei - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

14 Nov 2006

Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv10285
Modified Files:
    basic-commands.lisp core-commands.lisp editing.lisp 
    packages.lisp 
Log Message:
Create object deletion/killing functions.

--- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp	2006/11/08 01:15:33	1.1
+++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp	2006/11/14 10:31:37	1.2
@@ -371,13 +371,9 @@
   "Delete the object after point.
 With a numeric argument, kill that many objects 
 after (or before, if negative) point."
-  (let* ((point *current-point*)
-	 (mark (clone-mark point)))
-    (forward-object mark count)
-    (when killp
-      (kill-ring-standard-push *kill-ring*
-			       (region-to-sequence point mark)))
-    (delete-region point mark)))
+   (if killp
+      (forward-kill-object *current-point* count)
+      (forward-delete-object *current-point* count)))
(define-command (com-backward-delete-object :name t :command-table deletion-table)
     ((count 'integer :prompt "Number of Objects")
@@ -385,13 +381,9 @@
   "Delete the object before point.
 With a numeric argument, kills that many objects 
 before (or after, if negative) point."
-  (let* ((point *current-point*)
-	 (mark (clone-mark point)))
-    (backward-object mark count)
-    (when killp
-      (kill-ring-standard-push *kill-ring*
-			       (region-to-sequence mark point)))
-  (delete-region mark point)))
+  (if killp
+      (backward-kill-object *current-point* count)
+      (backward-delete-object *current-point* count)))
;; We require somewhat special behavior from Kill Line, so define a
 ;; new function and use that to implement the Kill Line command.
--- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp	2006/11/14 08:02:27	1.2
+++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp	2006/11/14 10:31:37	1.3
@@ -428,7 +428,7 @@
                                          'string))))
       (insert-sequence *current-point* line)
       (insert-object *current-point* #\Newline))
-    (com-backward-delete-object 1 nil)))
+    (backward-delete-object *current-point*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
--- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp	2006/11/08 01:15:33	1.1
+++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp	2006/11/14 10:31:37	1.2
@@ -196,7 +196,64 @@
 ;;; 
 ;;; Object editing
+(defun forward-delete-object (mark &optional (count 1) limit-action)
+  "Kill `count' objects beginning from `mark'."
+  (let ((offset (offset mark)))
+    (handler-case (progn (forward-object mark count)
+                         (delete-region offset mark))
+      (invalid-motion ()
+        (when limit-action
+          (funcall limit-action mark (offset mark)
+                   count "object" nil))))))
+
+(defun backward-delete-object (mark &optional (count 1) limit-action)
+  "Kill `count' objects backwards beginning from `mark'."
+  (let ((offset (offset mark)))
+    (handler-case (progn (backward-object mark count)
+                         (delete-region offset mark))
+      (invalid-motion ()
+        (when limit-action
+          (funcall limit-action mark (offset mark)
+                   (- count) "object" nil))))))
+
+(defun forward-kill-object (mark &optional (count 1) concatenate-p limit-action)
+  "Kill `count' objects beginning from `mark'."
+  (let ((start (offset mark)))
+    (handler-case (progn (forward-object mark count)
+                         (if concatenate-p
+                             (if (plusp count)
+                                 (kill-ring-concatenating-push
+                                  *kill-ring* (region-to-sequence start mark))
+                                 (kill-ring-reverse-concatenating-push
+                                  *kill-ring* (region-to-sequence start mark)))
+                             (kill-ring-standard-push
+                              *kill-ring* (region-to-sequence start mark)))
+                         (delete-region start mark))
+      (invalid-motion ()
+        (when limit-action
+          (funcall limit-action mark (offset mark)
+                   (- count) "object" nil))))))
+
+(defun backward-kill-object (mark &optional (count 1) concatenate-p limit-action)
+  "Kill `count' objects backwards beginning from `mark'."
+  (let ((start (offset mark)))
+    (handler-case (progn (forward-object mark count)
+                         (if concatenate-p
+                             (if (plusp count)
+                                 (kill-ring-concatenating-push
+                                  *kill-ring* (region-to-sequence start mark))
+                                 (kill-ring-reverse-concatenating-push
+                                  *kill-ring* (region-to-sequence start mark)))
+                             (kill-ring-standard-push
+                              *kill-ring* (region-to-sequence start mark)))
+                         (delete-region start mark))
+      (invalid-motion ()
+        (when limit-action
+          (funcall limit-action mark (offset mark)
+                   (- count) "object" nil))))))
+
 (defun transpose-objects (mark)
+  "Transpose two objects at `mark'."
   (unless (beginning-of-buffer-p mark)
     (when (end-of-line-p mark)
       (backward-object mark))
--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2006/11/14 07:59:05	1.4
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2006/11/14 10:31:37	1.5
@@ -329,7 +329,11 @@
 (defpackage :drei-editing
   (:use :clim-lisp :drei-base :drei-buffer
         :drei-syntax :drei-motion :drei :drei-kill-ring)
-  (:export #:transpose-objects
+  (:export #:forward-delete-object
+           #:backward-delete-object
+           #:forward-kill-object
+           #:backward-kill-object
+           #:transpose-objects
;; Lines
            #:forward-delete-line #:backward-delete-line

    