suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: misc repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-10 18:21:49 -06:00
parent 90a1c3f4e4
commit b9b627f294
8 changed files with 59 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/mrtop.rkt
View File

@ -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)])

3
collects/mred/private/wx/win32/canvas.rkt
View File

@ -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%)

7
collects/mred/private/wx/win32/frame.rkt
View File

@ -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)))

22
collects/mred/private/wx/win32/message.rkt
View File

@ -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);
;; icn = ExtractIconW(NULL, name, 0);
(LoadIconW #f IDI_APPLICATION))))
(let ([path
(let loop ([size 1024])
(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)))

11
collects/mred/private/wx/win32/panel.rkt
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require scheme/class
#lang racket/base
(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))

5
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -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

4
collects/mred/private/wx/win32/utils.rkt
View File

@ -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))

14
collects/mred/private/wx/win32/window.rkt
View File

@ -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)