diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 462e654cf7..379d9d8405 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -28,7 +28,7 @@ (interface (subwindow<%>) min-client-width min-client-height on-char on-event on-paint on-tab-in - warp-pointer get-dc + get-dc set-canvas-background get-canvas-background set-resize-corner)) @@ -44,9 +44,6 @@ (define min-client-height (param (lambda () wx) min-client-height)) (public min-client-width min-client-height) - (define warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))) - (public warp-pointer) - (define get-dc (entry-point (lambda () (send wx get-dc)))) (public get-dc) (define/public (make-bitmap w h) diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index fc5a703bf8..022cec3558 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -105,6 +105,7 @@ get-client-size get-size get-width get-height get-x get-y get-cursor set-cursor popup-menu show is-shown? on-superwindow-show refresh + warp-pointer get-handle get-client-handle)) (define subwindow<%> @@ -205,6 +206,10 @@ [get-cursor (lambda () cursor)] [set-cursor (entry-point (lambda (x) + (unless (or (not x) (x . is-a? . wx:cursor%)) + (raise-argument-error (who->name '(method window<%> set-cursor)) + "(or/c (is-a?/c cursor%) #f)" + x)) (send wx set-cursor x) (set! cursor x)))] @@ -221,7 +226,13 @@ [on-superwindow-show (lambda (visible?) (void))] [on-superwindow-enable (lambda (active?) (void))] - [refresh (entry-point (lambda () (send wx refresh)))]) + [refresh (entry-point (lambda () (send wx refresh)))] + + [warp-pointer (entry-point (lambda (x y) + (let ([who '(method window<%> warp-pointer)]) + (check-init-pos-integer who x) + (check-init-pos-integer who y)) + (send wx warp-pointer x y)))]) (define wx #f) (super-make-object (lambda () (set! wx (mk-wx)) wx) get-wx-panel get-outer-wx-panel mismatches parent) (unless enabled (enable #f))))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 46992b91d3..6a550291fd 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -790,8 +790,6 @@ (when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller))))) (refresh-for-autoscroll))) - (define/public (warp-pointer x y) (void)) - (define/override (get-virtual-h-pos) (scroll-pos h-scroller)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index ff0a22cdb9..852101118c 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -451,6 +451,9 @@ (define-cocoa NSFilenamesPboardType _id) +(define _CGError _int32) +(define-appserv CGWarpMouseCursorPosition (_fun _NSPoint -> _CGError)) + (define window% (class object% (init-field parent @@ -887,6 +890,12 @@ (define/public (get-saved-marked) saved-marked) (define/public (get-saved-selected) saved-sel) + (define/public (warp-pointer x y) + (define xb (box x)) + (define yb (box y)) + (client-to-screen xb yb) + (void (CGWarpMouseCursorPosition (make-NSPoint (unbox xb) (unbox yb))))) + (define/private (create-compose-window) (unless compose-cocoa (set! compose-cocoa (tell (tell InputMethodPanel alloc) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 1e6c5e12ca..7e950fe31e 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -757,8 +757,6 @@ (gtk_adjustment_get_page_size vscroll-adj)))))))) (refresh-for-autoscroll))) - (define/public (warp-pointer x y) (void)) - (define/override (get-virtual-h-pos) (inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj)))) (define/override (get-virtual-v-pos) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index ff6df8618d..a8394b7626 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -70,6 +70,10 @@ (define-gdk gdk_keyval_to_unicode (_fun _uint -> _uint32)) +(define-gtk gtk_widget_get_display (_fun _GtkWidget -> _GdkDisplay)) +(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen)) +(define-gdk gdk_display_warp_pointer (_fun _GdkDisplay _GdkScreen _int _int -> _void)) + (define-cstruct _GtkRequisition ([width _int] [height _int])) (define-cstruct _GtkAllocation ([x _int] @@ -733,6 +737,15 @@ (define/public (get-client-delta) (values 0 0)) + (define/public (warp-pointer x y) + (define xb (box x)) + (define yb (box y)) + (client-to-screen xb yb) + (gdk_display_warp_pointer (gtk_widget_get_display gtk) + (gtk_widget_get_screen gtk) + (unbox xb) + (unbox yb))) + (define/public (gets-focus?) #t))) (define (queue-window-event win thunk) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index e1c0f655d0..8816f3c677 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -569,8 +569,6 @@ (->long (* y (get-real-scroll-range 'vertical))))) (refresh-for-autoscroll))) - (define/public (warp-pointer x y) (void)) - (define/public (set-resize-corner on?) (void)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 6e3979a578..e3c90a2888 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -70,10 +70,12 @@ (define-user32 SetCapture (_wfun _HWND -> _HWND)) (define-user32 ReleaseCapture (_wfun -> _BOOL)) -(define-user32 WindowFromPoint (_fun _POINT -> _HWND)) -(define-user32 GetParent (_fun _HWND -> _HWND)) -(define-user32 SetParent (_fun _HWND _HWND -> (r : _HWND) - -> (unless r (failed 'SetParent)))) +(define-user32 WindowFromPoint (_wfun _POINT -> _HWND)) +(define-user32 GetParent (_wfun _HWND -> _HWND)) +(define-user32 SetParent (_wfun _HWND _HWND -> (r : _HWND) + -> (unless r (failed 'SetParent)))) + +(define-user32 SetCursorPos (_wfun _int _int -> _BOOL)) (define-cstruct _NMHDR ([hwndFrom _HWND] @@ -440,6 +442,12 @@ (set-box! x (POINT-x p)) (set-box! y (POINT-y p)))) + (define/public (warp-pointer x y) + (define xb (box x)) + (define yb (box y)) + (client-to-screen xb yb) + (void (SetCursorPos (unbox xb) (unbox yb)))) + (define/public (in-content? p) (ScreenToClient (get-client-hwnd) p) (let ([r (GetClientRect (get-client-hwnd))]) diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index 866d027211..1b7c1ffdf8 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -292,12 +292,5 @@ See @racket[canvas<%>] for information on canvas flushing. Beware that suspending flushing for a canvas can discourage refreshes for other windows in the same frame on some platforms.} - -@defmethod[(warp-pointer [x (integer-in 0 10000)] - [y (integer-in 0 10000)]) - void?]{ -Moves the cursor to the given location on the canvas. - -} } diff --git a/collects/scribblings/gui/window-intf.scrbl b/collects/scribblings/gui/window-intf.scrbl index f363a5d4ca..3905fc22b1 100644 --- a/collects/scribblings/gui/window-intf.scrbl +++ b/collects/scribblings/gui/window-intf.scrbl @@ -576,5 +576,12 @@ window is shown. } +@defmethod[(warp-pointer [x (integer-in -10000 10000)] + [y (integer-in -10000 10000)]) + void?]{ +Moves the cursor to the given location in the window's local coordinates. + +} + } diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index a5ccbc8eb5..567263a86c 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -9,6 +9,8 @@ scribble/srcdoc: added begin-for-doc syntax-color: added special support for dont-stop values; this change is backwards incompatible for code that calls lexers and may call unknown lexers +racket/gui/base: moved warp-pointer from canvas<%> to + window<%> and restored its functionality Version 5.3.3.6 Added "phase-collapse" module inference and instantiation