[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

14 Aug 2005

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv27374/Backends/CLX
Modified Files:
    medium.lisp 
Log Message:
Whoops.  Forgot to commit this one. (Thanks to Peter Mechlenborg)
Date: Sun Aug 14 14:47:42 2005
Author: crhodes
Index: mcclim/Backends/CLX/medium.lisp
diff -u mcclim/Backends/CLX/medium.lisp:1.66 mcclim/Backends/CLX/medium.lisp:1.67

--- mcclim/Backends/CLX/medium.lisp:1.66	Thu Feb 17 22:23:29 2005
+++ mcclim/Backends/CLX/medium.lisp	Sun Aug 14 14:47:42 2005
@@ -827,6 +827,47 @@
                                           direction first-not-done))
                       (values width (+ ascent descent) width 0 ascent)) )))))) )
+#-unicode
+(defmethod climi::text-bounding-rectangle*
+    ((medium clx-medium) string &key text-style (start 0) end)
+  (when (characterp string)
+    (setf string (make-string 1 :initial-element string)))
+  (unless end (setf end (length string)))
+  (unless text-style (setf text-style (medium-text-style medium)))
+  (let ((xfont (text-style-to-X-font (port medium) text-style)))
+    (cond ((= start end)
+           (values 0 0 0 0))
+          (t
+           (let ((position-newline (position #\newline string :start start)))
+             (cond ((not (null position-newline))
+                    (multiple-value-bind (width ascent descent left right
+                                                font-ascent font-descent direction
+                                                first-not-done)
+                        (xlib:text-extents xfont string
+                                           :start start :end position-newline
+                                           :translate #'translate)
+                      (declare (ignorable left right
+                                          font-ascent font-descent
+                                          direction first-not-done))
+                      (multiple-value-bind (minx miny maxx maxy)
+                          (text-bounding-rectangle*
+                           medium string :text-style text-style
+                           :start (1+ position-newline) :end end)
+                        (values (min minx left) (- ascent)
+                                (max maxx right) (+ descent maxy)))))
+                   (t
+                    (multiple-value-bind (width ascent descent left right
+                                                font-ascent font-descent direction
+                                                first-not-done)
+                        (xlib:text-extents xfont string
+                                   :start start :end end
+                                   :translate #'translate)
+                      (declare (ignore width direction first-not-done))
+                      ;; FIXME: Potential style points:
+                      ;; * (min 0 left), (max width right)
+                      ;; * font-ascent / ascent
+                      (values left (- font-ascent) right font-descent)))))))))
+
 #+unicode
 (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end)
   (when (characterp string)

    