From 6defe0ea09368b38f6015cd27caed599fdcf875f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 11 Jan 2011 19:16:39 -0700
Subject: [PATCH] win32: fix screen-glyph reporting for label mode  because XP
 doesn't substitute fonts in control labels

---
 collects/mred/private/wx/win32/button.rkt |  7 +++----
 collects/racket/draw/private/font.rkt     | 15 +++++++++++++--
 collects/racket/draw/private/xp.rkt       | 17 +++++++++++++++++
 3 files changed, 33 insertions(+), 6 deletions(-)
 create mode 100644 collects/racket/draw/private/xp.rkt

diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt
index 1562500423..f83e86d3ac 100644
--- a/collects/mred/private/wx/win32/button.rkt
+++ b/collects/mred/private/wx/win32/button.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
          racket/draw
+	 racket/draw/private/xp
          ffi/unsafe
           "../../syntax.rkt"
           "../../lock.rkt"
@@ -19,10 +20,6 @@
 
 (define BM_SETSTYLE #x00F4)
 
-(define-kernel32 GetVersion (_wfun -> _DWORD))
-
-(define xp? (= 5 (bitwise-and #xFF (GetVersion))))
-
 (define base-button% 
   (class item%
     (inherit set-control-font auto-size get-hwnd
@@ -136,6 +133,8 @@
         (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
     (auto-size-button font label)
 
+    ;; XP doesn't show both bitmap and string labels,
+    ;; so we synthesize a bitmap label when we have both
     (define xp-label-bitmap (and xp? orientation (car label)))
     (define xp-label-string (and xp? orientation (string->immutable-string (cadr label))))
     (define xp-label-font (and xp? orientation font))
diff --git a/collects/racket/draw/private/font.rkt b/collects/racket/draw/private/font.rkt
index 514b336aa1..0789ed2771 100644
--- a/collects/racket/draw/private/font.rkt
+++ b/collects/racket/draw/private/font.rkt
@@ -7,7 +7,8 @@
          "../unsafe/cairo.ss"
          "font-syms.ss"
          "font-dir.ss"
-         "local.ss")
+         "local.ss"
+	 "xp.rkt")
 
 (provide font%
          font-list% the-font-list
@@ -25,6 +26,10 @@
                            (pango_attr_list_insert l (pango_attr_underline_new
                                                       PANGO_UNDERLINE_SINGLE))
                            l))
+(define fallback-attrs (and xp? 
+			    (let ([l (pango_attr_list_new)])
+			      (pango_attr_list_insert l (pango_attr_fallback_new #f))
+			      l)))
 
 (define (size? v) (and (exact-positive-integer? v)
                        (byte? v)))
@@ -83,13 +88,19 @@
   (let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 1 1)]
          [cr (cairo_create s)]
          [context (pango_cairo_create_context cr)]
-         [layout (pango_layout_new context)])
+         [layout (pango_layout_new context)]
+	 ;; Under Windows XP, there's no font 
+	 ;; fallback/substitution in control labels:
+	 [no-subs? (and xp? for-label?)])
     (pango_layout_set_font_description layout desc)
     (pango_layout_set_text layout (string c))
+    (when no-subs?
+      (pango_layout_set_attributes layout fallback-attrs))
     (pango_cairo_update_layout cr layout)
     (begin0
      (or (zero? (pango_layout_get_unknown_glyphs_count layout))
          (and substitute-fonts?
+	      (not no-subs?)
               (install-alternate-face c layout font desc #f context)
               (zero? (pango_layout_get_unknown_glyphs_count layout))))
      (g_object_unref layout)
diff --git a/collects/racket/draw/private/xp.rkt b/collects/racket/draw/private/xp.rkt
new file mode 100644
index 0000000000..1e11d87eae
--- /dev/null
+++ b/collects/racket/draw/private/xp.rkt
@@ -0,0 +1,17 @@
+#lang racket/base
+(require ffi/unsafe)
+
+;; Unfortunately, we sometimes need to do something different
+;;  under Windows XP
+
+(provide xp?)
+
+(define xp? 
+  (and (eq? 'windows (system-type))
+       (let* ([abi (and (equal? "win32\\i386" 
+				(path->string (system-library-subpath #f)))
+			'stdcall)]
+	      [GetVersion (get-ffi-obj 'GetVersion
+				       (ffi-lib "kernel32.dll")
+				       (_fun #:abi abi -> _int32))])
+	 (= 5 (bitwise-and #xFF (GetVersion))))))