[mcclim-cvs] CVS update: mcclim/text-selection.lisp

[Gilbert Baumann]

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv26311

Modified Files:
	text-selection.lisp 
Log Message:
FETCH-SELECTION:
    - We pad out selection we get from tables and similar things with
      spaces now.


Date: Mon Nov 28 14:04:55 2005
Author: gbaumann

Index: mcclim/text-selection.lisp
diff -u mcclim/text-selection.lisp:1.6 mcclim/text-selection.lisp:1.7
--- mcclim/text-selection.lisp:1.6	Tue Mar 22 13:31:18 2005
+++ mcclim/text-selection.lisp	Mon Nov 28 14:04:55 2005
@@ -403,18 +403,27 @@
 
 ;; FIXME: Non-text target conversions.. (?)
 (defun fetch-selection (pane)
-  (let (old-y2)
+  (let (old-y2 old-x2)
     (with-output-to-string (bag)
-;    (let ((bag *trace-output*))
       (map nil
            (lambda (m)
              (with-slots (record styled-string start end) m
-	       (with-standard-rectangle* (:y1 y1 :y2 y2) record
-                 (if (and old-y2 (>= y1 old-y2))
-                     (progn
-                       (setf old-y2 nil)
-                       (terpri bag))
-                   (setf old-y2 (max y2 (or old-y2 y2)))))
-               (princ (subseq (styled-string-string styled-string) start end) bag)))
+               (with-standard-rectangle*
+                   (:x1 x1 :x2 x2 :y1 y1 :y2 y2) record
+                   (cond ((and old-y2 (>= y1 old-y2))
+                          (setf old-y2 nil
+                                old-x2 0 ;<-- ### we should use the minimum of all x1 coordinates.
+                                )
+                          (terpri bag))
+                         (t
+                          (setf old-y2 (max y2 (or old-y2 y2)))))
+                   (when old-x2
+                     (loop repeat (round
+                                   (- x1 old-x2)
+                                   (text-style-width (slot-value styled-string 'text-style)
+                                                     pane))
+                       do
+                       (princ " " bag)))
+                   (setf old-x2 x2)
+                   (princ (subseq (styled-string-string styled-string) start end) bag))))
            (slot-value pane 'markings)))))
-