fix get-char-height' and get-char-width' in dc<%>

Closes PR 11526

collects/racket/draw/private/bitmap-dc.rkt

@@ -85,7 +85,8 @@
              get-size
              get-transformation
              set-transformation
-             scale)
+             scale
+             get-font)
     
     (super-new)
 
@@ -149,6 +150,25 @@
           (scale sx sy)
           (begin0
            (draw-bitmap-section src (/ dest-x sx) (/ dest-y sy) src-x src-y src-w src-h style color mask)
-           (set-transformation t)))))))
+           (set-transformation t)))))
+
+    (def/override (get-char-width)
+      (if (internal-get-bitmap)
+          (super get-char-width)
+          (send (get-temp-bitmap-dc) get-char-width)))
+
+    (def/override (get-char-height)
+      (if (internal-get-bitmap)
+          (super get-char-height)
+          (send (get-temp-bitmap-dc) get-char-height)))
+
+    (define temp-dc #f)
+    (define/private (get-temp-bitmap-dc)
+      (let ([dc (or (and temp-dc (weak-box-value temp-dc))
+                    (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))])
+                      (set! temp-dc (make-weak-box dc))
+                      dc))])
+        (send dc set-font (get-font))
+        dc))))
 
 (install-bitmap-dc-class! bitmap-dc%)

collects/racket/draw/private/dc.rkt

@@ -1385,9 +1385,6 @@
               (vector-set! vec 3 #f)
               (vector-set! vec 4 #f)))))
     
-    (def/public (get-char-width)
-      10.0)
-
     (def/public (start-doc [string? desc])
       (check-ok 'start-doc))
     (def/public (end-doc)
@@ -1617,6 +1614,37 @@
                      (install-alternate-face c layout font desc attrs context)
                      (zero? (pango_layout_get_unknown_glyphs_count layout))))
             (g_object_unref layout))))))
+    
+    (def/public (get-char-width)
+      (with-cr
+       10.0
+       cr
+       (get-font-metric cr pango_font_metrics_get_approximate_char_width)))
+
+    (def/public (get-char-height)
+      (with-cr
+       12.0
+       cr
+       (get-font-metric cr (lambda (m)
+                             (+ (pango_font_metrics_get_ascent m)
+                                (pango_font_metrics_get_descent m))))))
+
+    (define/private (get-font-metric cr sel)
+      (let ([desc (get-pango font)]
+            [attrs (send font get-pango-attrs)]
+            [context+fontmap (or (for/or ([c (in-vector contexts)]
+                                          [fm (in-vector font-maps)])
+                                   (and c (cons c fm)))
+                                 (cons
+                                  (pango_cairo_create_context cr)
+                                  (pango_cairo_font_map_new)))])
+        (let ([font (pango_font_map_load_font (cdr context+fontmap)
+                                              (car context+fontmap)
+                                              desc)])
+          (let ([metrics (pango_font_get_metrics font (pango_language_get_default))])
+            (let ([v (sel metrics)])
+              (pango_font_metrics_unref metrics)
+              (/ v (exact->inexact PANGO_SCALE)))))))
 
     (void))
 

collects/racket/draw/unsafe/pango.rkt

@@ -53,6 +53,7 @@
 (define PangoFontFamily (_cpointer 'PangoFontFamily))
 (define PangoFont (_cpointer 'PangoFont))
 (define PangoFontMap (_cpointer 'PangoFontMap))
+(define PangoFontMetrics (_cpointer 'PangoFontMetrics))
 (define PangoAttrList (_cpointer 'PangoAttrList))
 (define PangoAttribute (_cpointer 'PangoAttribute))
 (define PangoLanguage (_cpointer 'PangoLanguage))
@@ -190,6 +191,14 @@
   #:wrap (allocator pango_coverage_unref))
 (define-pango pango_coverage_get (_fun PangoCoverage _int -> _int))
 
+(define-pango pango_font_metrics_unref (_fun PangoFontMetrics -> _void)
+  #:wrap (deallocator))
+(define-pango pango_font_get_metrics (_fun PangoFont PangoLanguage -> PangoFontMetrics)
+  #:wrap (allocator pango_font_metrics_unref))
+(define-pango pango_font_metrics_get_approximate_char_width (_fun PangoFontMetrics -> _int))
+(define-pango pango_font_metrics_get_ascent (_fun PangoFontMetrics -> _int))
+(define-pango pango_font_metrics_get_descent (_fun PangoFontMetrics -> _int))
+
 (define-pango pango_layout_get_unknown_glyphs_count (_fun PangoLayout -> _int))
 
 (define-pango pango_attr_list_unref (_fun PangoAttrList -> _void)

collects/tests/gracket/dc.rktl

@@ -72,6 +72,9 @@
   (try-ok 'set-text-foreground (make-object color% "Yellow"))
   (try-ok 'set-text-mode 'transparent)
 
+  (try-ok 'get-char-height)
+  (try-ok 'get-char-width)
+
   (try 'try-color (make-object color% "Yellow") (make-object color%)))
 
 (st #f mdc ok?)