win32: mouse-leave events when mouse leaves the frame

original commit: 4c05bb48f128c1885c122835eb29755f2a9535b1
This commit is contained in:
Matthew Flatt 2011-01-10 11:26:51 -07:00
parent 8744d5c5b5
commit c54649bd9e

View File

@ -116,6 +116,20 @@
[cbData _DWORD] [cbData _DWORD]
[lpData _pointer])) [lpData _pointer]))
(define-cstruct _TRACKMOUSEEVENT
([cbSize _DWORD]
[dwFlags _DWORD]
[hwndTrack _HWND]
[dwHoverTime _DWORD]))
(define TME_LEAVE #x02)
(define TME_NONCLIENT #x10)
(define-user32 TrackMouseEvent (_wfun _TRACKMOUSEEVENT-pointer -> (r : _BOOL)
-> (unless r (failed 'TrackMouseEvent))))
(define-user32 GetCursorPos (_wfun _POINT-pointer -> (r : _BOOL)
-> (unless r (failed 'GetCursorPos))))
(defclass window% object% (defclass window% object%
(init-field parent hwnd) (init-field parent hwnd)
(init style (init style
@ -524,7 +538,11 @@
[(= msg WM_MOUSEMOVE) [(= msg WM_MOUSEMOVE)
(do-mouse w msg #f 'motion wParam lParam)] (do-mouse w msg #f 'motion wParam lParam)]
[(= msg WM_MOUSELEAVE) [(= msg WM_MOUSELEAVE)
(do-mouse w msg #f 'leave wParam lParam)] (let ([p (make-POINT 0 0)])
(GetCursorPos p)
(let ([f (location->window (POINT-x p) (POINT-y p))])
(unless (eq? f (get-top-frame))
(do-mouse w msg #f 'leave wParam lParam))))]
[else #f])) [else #f]))
(define/private (do-mouse control-hwnd msg nc? type wParam lParam) (define/private (do-mouse control-hwnd msg nc? type wParam lParam)
@ -556,6 +574,11 @@
[alt-down #f] [alt-down #f]
[time-stamp 0] [time-stamp 0]
[caps-down #f]))]) [caps-down #f]))])
(if (eq? type 'leave)
(let ([t (get-top-frame)])
(send t send-child-leaves make-e)
(send t send-leaves make-e))
(begin
(unless nc? (unless nc?
(when (wants-mouse-capture? control-hwnd) (when (wants-mouse-capture? control-hwnd)
(when (memq type '(left-down right-down middle-down)) (when (memq type '(left-down right-down middle-down))
@ -563,13 +586,18 @@
(when (memq type '(left-up right-up middle-up)) (when (memq type '(left-up right-up middle-up))
(ReleaseCapture)))) (ReleaseCapture))))
(if mouse-in? (if mouse-in?
(if (send-child-leaves (lambda (type) (make-e type))) (if (send-child-leaves make-e)
(cursor-updated-here) (cursor-updated-here)
(if (send (get-top-frame) is-wait-cursor-on?) (if (send (get-top-frame) is-wait-cursor-on?)
(void (SetCursor (get-wait-cursor))) (void (SetCursor (get-wait-cursor)))
(when effective-cursor-handle (when effective-cursor-handle
(void (SetCursor effective-cursor-handle))))) (void (SetCursor effective-cursor-handle)))))
(let ([c (generate-mouse-ins this (lambda (type) (make-e type)))]) (let ([c (generate-mouse-ins this (lambda (type) (make-e type)))])
(TrackMouseEvent (make-TRACKMOUSEEVENT
(ctype-sizeof _TRACKMOUSEEVENT)
(bitwise-ior TME_LEAVE)
control-hwnd
0))
(when c (when c
(set! effective-cursor-handle c) (set! effective-cursor-handle c)
(void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?) (void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?)
@ -577,7 +605,7 @@
c)))))) c))))))
(when (memq type '(left-down right-down middle-down)) (when (memq type '(left-down right-down middle-down))
(set-focus)) (set-focus))
(handle-mouse-event control-hwnd msg wParam (make-e type))))) (handle-mouse-event control-hwnd msg wParam (make-e type)))))))
(define/private (handle-mouse-event w msg wParam e) (define/private (handle-mouse-event w msg wParam e)
(if (definitely-wants-event? w msg wParam e) (if (definitely-wants-event? w msg wParam e)
@ -604,6 +632,7 @@
(send parent generate-mouse-ins this mk)) (send parent generate-mouse-ins this mk))
(define/public (send-leaves mk) (define/public (send-leaves mk)
(when mouse-in?
(set! mouse-in? #f) (set! mouse-in? #f)
(when mk (when mk
(let ([e (mk 'leave)]) (let ([e (mk 'leave)])
@ -611,7 +640,7 @@
(eventspace-handler-thread eventspace)) (eventspace-handler-thread eventspace))
(handle-mouse-event (get-client-hwnd) 0 0 e) (handle-mouse-event (get-client-hwnd) 0 0 e)
(queue-window-event this (queue-window-event this
(lambda () (dispatch-on-event/sync e))))))) (lambda () (dispatch-on-event/sync e))))))))
(define/public (send-child-leaves mk) (define/public (send-child-leaves mk)
#f) #f)