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

Closes PR 11526
This commit is contained in:
Matthew Flatt 2010-12-10 20:35:45 -07:00
parent 6c75bda403
commit 965e8f96d1
4 changed files with 65 additions and 5 deletions

View File

@ -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%)

View File

@ -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))

View File

@ -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)

View File

@ -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?)