win32: misc repairs

collects/mred/private/mrtop.rkt

@@ -98,7 +98,7 @@
 		 (lambda (w h)
 		   (check-range-integer '(method top-level-window<%> resize) w)
 		   (check-range-integer '(method top-level-window<%> resize) h)
-		   (send wx set-size -1 -1 w h)))]
+		   (send wx set-size -11111 -11111 w h)))]
 
 	[get-focus-window (entry-point
 			   (lambda () (let ([w (send wx get-focus-window)])

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

@@ -380,6 +380,9 @@
                                   (let loop () (pre-event-sync #t) (when (yield) (loop))))
                                 (void))))))
 
+     (define/override (wants-mouse-capture? control-hwnd)
+       (ptr-equal? canvas-hwnd control-hwnd))
+
      (define/override (definitely-wants-event? w msg wParam e) 
        (cond
         [(e . is-a? . key-event%)

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

@@ -234,6 +234,13 @@
       (set! mouse-frame this))
     #f)
 
+  (define/override (send-child-leaves mk)
+    (if (eq? mouse-frame this)
+        (if saved-child
+            (send saved-child send-leaves mk)
+            #f)
+        #f))
+
   (define/override (reset-cursor default)
     (if wait-cursor-on?
         (void (SetCursor (get-wait-cursor)))

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

@@ -31,13 +31,29 @@
 (define IMAGE_ICON 1)
 
 (define-user32 LoadIconW (_wfun _HINSTANCE _LONG -> _HICON))
+(define-kernel32 GetModuleFileNameW (_wfun _pointer _pointer _DWORD -> _DWORD))
+
+(define-shell32 ExtractIconW (_wfun _HINSTANCE _string/utf-16 _UINT -> (r : _HICON)
+                                    -> (or r (failed 'ExtractIconW))))
+                                           
+(define ERROR_INSUFFICIENT_BUFFER 122)
 
 (define app-icon
   (delay
     (let ()
-      ;; GetModuleFileNameW(NULL, name, 1023);
+      (let ([path
-      ;; icn = ExtractIconW(NULL, name, 0);
+             (let loop ([size 1024])
-      (LoadIconW #f IDI_APPLICATION))))
+               (let ([p (make-bytes (* (ctype-sizeof _WCHAR) 1024))])
+                 (let ([r (GetModuleFileNameW #f p size)])
+                   (cond
+                    [(and (or (zero? r) (= r size))
+                          (= (GetLastError) ERROR_INSUFFICIENT_BUFFER))
+                     (loop (* size 2))]
+                    [(zero? r) (failed 'GetModuleFileNameW)]
+                    [else (cast p _gcpointer _string/utf-16)]))))])
+        (if path
+            (ExtractIconW hInstance path 0)
+            (LoadIconW #f IDI_APPLICATION))))))
 (define warning-icon
   (delay
     (LoadIconW #f IDI_WARNING)))

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

@@ -1,5 +1,6 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/class
+(require racket/class
+         ffi/unsafe
           "../../syntax.rkt"
          "window.rkt"
          "wndclass.rkt"
@@ -13,7 +14,8 @@
 (define (panel-mixin %)
   (class %
     (inherit is-enabled-to-root?
-             reset-cursor-in-child)
+             reset-cursor-in-child
+             get-client-hwnd)
 
     (super-new)
 
@@ -64,6 +66,9 @@
             #t)
           #f))
 
+    (define/override (wants-mouse-capture? control-hwnd)
+      (ptr-equal? (get-client-hwnd) control-hwnd))
+
     (define lbl-pos 'horizontal)
     (define/public (get-label-position) lbl-pos)
     (define/public (set-label-position pos) (set! lbl-pos pos))

collects/mred/private/wx/win32/tab-panel.rkt

@@ -97,7 +97,10 @@
     (define tab-height 0)
 
     (set-control-font #f)
-    (auto-size choices 0 0 0 0 #:combine-width +
+    (auto-size (if (null? choices)
+                   '("Choice")
+                   choices)
+               0 0 0 0 #:combine-width +
                (lambda (w h)
                  (set! tab-height (+ h 6))
                  (set-size -11111 -11111 

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

@@ -8,10 +8,12 @@
 	 define-user32
 	 define-kernel32
 	 define-comctl32
+	 define-shell32
 	 define-uxtheme
          define-mz
          failed
 
+         GetLastError
 	 CreateWindowExW
          GetWindowLongW
          SetWindowLongW
@@ -34,12 +36,14 @@
 (define user32-lib (ffi-lib "user32.dll"))
 (define kernel32-lib (ffi-lib "kernel32.dll"))
 (define comctl32-lib (ffi-lib "comctl32.dll"))
+(define shell32-lib (ffi-lib "shell32.dll"))
 (define uxtheme-lib (ffi-lib "uxtheme.dll"))
 
 (define-ffi-definer define-gdi32 gdi32-lib)
 (define-ffi-definer define-user32 user32-lib)
 (define-ffi-definer define-kernel32 kernel32-lib)
 (define-ffi-definer define-comctl32 comctl32-lib)
+(define-ffi-definer define-shell32 shell32-lib)
 (define-ffi-definer define-uxtheme uxtheme-lib)
 
 (define-kernel32 GetLastError (_wfun -> _DWORD))

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

@@ -54,6 +54,9 @@
 (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int)
                                -> (when (zero? r) (failed 'FillRect))))
 
+(define-user32 SetCapture (_wfun _HWND -> _HWND))
+(define-user32 ReleaseCapture (_wfun -> _BOOL))
+
 (define-cstruct _NMHDR
   ([hwndFrom _HWND]
    [idFrom _pointer]
@@ -248,7 +251,7 @@
         (let ([r (GetWindowRect hwnd)])
           (MoveWindow hwnd 
                       (if (= x -11111) (RECT-left r) x)
-                      (if (= y -11111) (RECT-right r) y)
+                      (if (= y -11111) (RECT-top r) y)
                       (if (= w -1) (- (RECT-right r) (RECT-left r)) w)
                       (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)
                       #t))
@@ -480,6 +483,12 @@
                     [alt-down #f]
                     [time-stamp 0]
                     [caps-down #f]))])
+        (unless nc?
+          (when (wants-mouse-capture? control-hwnd)
+            (when (memq type '(left-down right-down middle-down))
+              (SetCapture control-hwnd))
+            (when (memq type '(left-up right-up middle-up))
+              (ReleaseCapture))))
         (if mouse-in?
             (if (send-child-leaves (lambda (type) (make-e type)))
                 (cursor-updated-here)
@@ -532,6 +541,9 @@
   (define/public (send-child-leaves mk)
     #f)
 
+  (define/public (wants-mouse-capture? control-hwnd)
+    #f)
+
   (define/public (definitely-wants-event? w msg wParam e)
     #f)