win32: fix bitmap+string labels for XP

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

@@ -3,6 +3,7 @@
          racket/draw
          ffi/unsafe
           "../../syntax.rkt"
+          "../../lock.rkt"
           "../common/event.rkt"
          "item.rkt"
 	 "utils.rkt"
@@ -18,10 +19,14 @@
 
 (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
-             remember-label-bitmap)
+             remember-label-bitmap set-size)
 
     (init parent cb label x y w h style font)
 
@@ -46,7 +51,8 @@
 					  [else "<image>"])
                                          (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS
                                                       (if bitmap?
-							  (case orientation
+							  (case (and (not xp?) 
+								     orientation)
 							    [(#f) BS_BITMAP]
 							    [(left) BS_LEFT]
 							    [(right) BS_RIGHT]
@@ -61,23 +67,67 @@
                [style style])
 
     (when bitmap?
-      (let ([hbitmap (bitmap->hbitmap (if (pair? label) (car label) label)
+      (let ([hbitmap (bitmap->hbitmap (if (pair? label)
+					  (if xp?
+					      (collapse-to-bitmap label font)
+					      (car label))
+					  label)
 				      #:bg (get-button-background))])
         (remember-label-bitmap hbitmap)
         (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP 
                       (cast hbitmap _HBITMAP _LPARAM))))
 
+    (define/private (collapse-to-bitmap label font)
+      ;; XP doesn't handle a combination of string
+      ;; and bitmap labels
+      (let-values ([(w h) (auto-size-button font label
+					    #:resize (lambda (w h)
+						       (values w h)))])
+	 (let* ([bm (make-object bitmap% w h #f #f)]
+		[dc (make-object bitmap-dc% bm)]
+		[h? (memq (caddr label) '(left right))])
+	   (send dc draw-bitmap (car label)
+		 (if h?
+		     (if (eq? (caddr label) 'left)
+			 3
+			 (- w (send (car label) get-width) 3))
+		     (quotient (- w (send (car label) get-width)) 2))
+		 (if h?
+		     (quotient (- h (send (car label) get-height)) 2)
+		     (if (eq? (caddr label) 'top)
+			 3
+			 (- h (send (car label) get-height) 3))))
+	   (send dc set-font (or font (get-default-control-font)))
+	   (let-values ([(tw th ta td) (send dc get-text-extent (cadr label))])
+	     (send dc draw-text (cadr label)
+		   (if h?
+		       (if (eq? (caddr label) 'left)
+			   (- w tw 3)
+			   3)
+		       (quotient (- w tw) 2))
+		   (if h?
+		       (quotient (- h th) 2)
+		       (if (eq? (caddr label) 'top)
+			   (- h th 3)
+			   3))))
+	   (send dc set-bitmap #f)
+	   bm)))
+
     (set-control-font font)
 
     (define/public (get-button-background)
       #xFFFFFF)
 
-    (define/public (auto-size-button font label)
+    (define/public (auto-size-button 
+		    font 
+		    label
+		    #:resize [resize (lambda (w h) (set-size -11111 -11111 w h))])
       (cond
        [orientation
 	(let ([h? (memq orientation '(left right))])
 	  (auto-size font (list (car label) (cadr label))
 		     0 0 12 8
+		     resize
 		     #:combine-width (if h? + max)
 		     #:combine-height (if h? max +)))]
        [bitmap?
@@ -86,6 +136,25 @@
         (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
     (auto-size-button font label)
 
+    (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))
+
+    (define/override (set-label s)
+      (if (and orientation xp?)
+	  (atomically
+	   (begin
+	     (if (string? s) 
+		 (set! xp-label-string s)
+		 (set! xp-label-bitmap s))
+	     (super
+	      set-label
+	      (collapse-to-bitmap (list xp-label-bitmap
+					xp-label-string
+					orientation)
+				  xp-label-font))))
+	  (super set-label s)))
+
     (define/override (is-command? cmd)
       (= cmd BN_CLICKED))
 
@@ -104,5 +173,3 @@
 (define button% 
   (class base-button%
     (super-new)))
-
-

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

@@ -25,6 +25,7 @@
               queue-window-refresh-event
               location->window
               flush-display
+	      get-default-control-font
 
               GetWindowRect
               GetClientRect))