fix get-char-height' and
get-char-width' in dc<%>
Closes PR 11526
This commit is contained in:
parent
6c75bda403
commit
965e8f96d1
|
@ -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%)
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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?)
|
||||
|
|
Loading…
Reference in New Issue
Block a user