racket/gui win32: fix East Asian font problem

When the theme-specified default font has a localized name,
using it as a Pango faily name doesn't work, with the result that
text on controls could be truncated. Get a Pango-friendly
name by converting a LOGFONT to a Pango font description and
getting the name from the font description.

original commit: 7a9c8e5d404cbbb246ed0ebdc0cf80ed2368be54

collects/mred/private/wx/win32/font.rkt

@@ -1,11 +1,17 @@
 #lang racket/base
 (require racket/class
 	 racket/draw
+         ffi/unsafe
          racket/draw/private/local
-         racket/draw/unsafe/pango)
+         racket/draw/unsafe/pango
+         "types.rkt"
+         "utils.rkt")
 
 (provide 
- (protect-out font->hfont))
+ (protect-out font->hfont
+              logfont->pango-family
+              (struct-out LOGFONTW) _LOGFONTW _LOGFONTW-pointer))
+
 
 (define display-font-map
   (pango_win32_font_map_for_display))
@@ -35,3 +41,35 @@
 	 (begin0
 	  (pango_win32_font_cache_load font-cache logfont)
 	  (g_free logfont)))))
+
+;; ----------------------------------------
+
+(define-cstruct _LOGFONTW
+  ([lfHeight  _LONG]
+   [lfWidth  _LONG]
+   [lfEscapement  _LONG]
+   [lfOrientation  _LONG]
+   [lfWeight  _LONG]
+   [lfItalic  _BYTE]
+   [lfUnderline  _BYTE]
+   [lfStrikeOut  _BYTE]
+   [lfCharSet  _BYTE]
+   [lfOutPrecision  _BYTE]
+   [lfClipPrecision  _BYTE]
+   [lfQuality  _BYTE]
+   [lfPitchAndFamily  _BYTE]
+   [lfFaceName (_array _uint16 32)]))
+
+(define (logfont->pango-family logfontw)
+  (define logfont (malloc _LOGFONTW))
+  (memcpy logfont logfontw (ctype-sizeof _LOGFONTW)) ; bit enough for _LOGFONTA, too
+  (WideCharToMultiByte 0 0 
+                       (array-ptr (LOGFONTW-lfFaceName logfontw)) 0
+                       (array-ptr (LOGFONTW-lfFaceName logfontw)) 32
+                       #f #f)
+  (define desc
+    (pango_win32_font_description_from_logfont logfont))
+  (if desc
+      (pango_font_description_get_family desc)
+      ;; random fallback:
+      "Arial"))

collects/mred/private/wx/win32/theme.rkt

@@ -3,13 +3,13 @@
          ffi/unsafe/alloc
          "utils.rkt"
          "const.rkt"
-         "types.rkt")
+         "types.rkt"
+         "font.rkt")
 
 (provide
  (protect-out get-theme-logfont
               get-theme-font-face
               get-theme-font-size
-              _LOGFONT-pointer
               OpenThemeData
               CloseThemeData
               DrawThemeParentBackground
@@ -19,38 +19,6 @@
 
 (define _HTHEME (_cpointer 'HTHEME))
 
-(define-cstruct _FaceName1
-  ([c1 _uint16]
-   [c2 _uint16]
-   [c3 _uint16]
-   [c4 _uint16]
-   [c5 _uint16]
-   [c6 _uint16]
-   [c7 _uint16]
-   [c8 _uint16]))
-
-(define-cstruct _FaceName
-  ([f1 _FaceName1]
-   [f2 _FaceName1]
-   [f3 _FaceName1]
-   [f4 _FaceName1]))
-
-(define-cstruct _LOGFONT
-  ([lfHeight  _LONG]
-   [lfWidth  _LONG]
-   [lfEscapement  _LONG]
-   [lfOrientation  _LONG]
-   [lfWeight  _LONG]
-   [lfItalic  _BYTE]
-   [lfUnderline  _BYTE]
-   [lfStrikeOut  _BYTE]
-   [lfCharSet  _BYTE]
-   [lfOutPrecision  _BYTE]
-   [lfClipPrecision  _BYTE]
-   [lfQuality  _BYTE]
-   [lfPitchAndFamily  _BYTE]
-   [lfFaceName _FaceName])) ; 32 of them
-
 (define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT)
 				      -> (when (negative? r)
 					   (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))
@@ -59,13 +27,13 @@
 (define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> (_or-null _HTHEME))
   #:wrap (allocator maybe-CloseThemeData))
 
-(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT))
+(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONTW))
 				    -> (r : _HRESULT)
 				    -> (if (negative? r) 
 					   (error 'GetThemeFont "failed: ~s" (bitwise-and #xFFFF r))
 					   f)))
 
-(define-uxtheme GetThemeSysFont(_wfun (_or-null _HTHEME) _int (f : (_ptr o _LOGFONT))
+(define-uxtheme GetThemeSysFont(_wfun (_or-null _HTHEME) _int (f : (_ptr o _LOGFONTW))
 				      -> (r : _HRESULT)
 				      -> (if (negative? r) 
 					     (error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r))
@@ -98,7 +66,7 @@
   theme-logfont)
 
 (define (get-theme-font-face)
-  (cast (LOGFONT-lfFaceName theme-logfont) _pointer _string/utf-16))
+  (cast (array-ptr (LOGFONTW-lfFaceName theme-logfont)) _pointer _string/utf-16))
 
 (define (get-theme-font-size)
-  (abs (LOGFONT-lfHeight theme-logfont)))
+  (abs (LOGFONTW-lfHeight theme-logfont)))

collects/mred/private/wx/win32/utils.rkt

@@ -42,7 +42,8 @@
               CheckMenuItem
               ModifyMenuW
               RemoveMenu
-              SelectObject))
+              SelectObject
+              WideCharToMultiByte))
 
 (define gdi32-lib (ffi-lib "gdi32.dll"))
 (define user32-lib (ffi-lib "user32.dll"))
@@ -151,3 +152,7 @@
                                  -> (unless r (failed 'RemoveMenu))))
 
 (define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer))
+
+(define-kernel32 WideCharToMultiByte (_wfun _UINT _DWORD _pointer _int
+                                            _pointer _int _pointer _pointer
+                                            -> _int))

collects/mred/private/wx/win32/window.rkt

@@ -59,7 +59,7 @@
 (define-user32 ScreenToClient (_wfun _HWND _POINT-pointer -> (r : _BOOL)
                                      -> (unless r (failed 'ClientToScreen))))
 
-(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
+(define-gdi32 CreateFontIndirectW (_wfun _LOGFONTW-pointer -> _HFONT))
 
 (define-shell32 DragAcceptFiles (_wfun _HWND _BOOL -> _void))
 
@@ -797,7 +797,8 @@
     (set! default-control-font
 	  (make-object font%
 		       (get-theme-font-size)
-		       (get-theme-font-face)
+                       (logfont->pango-family
+                         (get-theme-logfont))
 		       'system
 		       'normal 'normal #f 'default
 		       #t)))