diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index bc49ba6e45..8d7ecd83e1 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -78,6 +78,7 @@ frame% gauge% get-choices-from-user get-color-from-user +get-current-mouse-state get-default-shortcut-prefix get-directory get-display-count diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 6e26e1b20c..8f49d9fc2a 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -116,6 +116,7 @@ event-dispatch-handler eventspace? flush-display + get-current-mouse-state get-highlight-background-color get-highlight-text-color get-the-editor-data-class-list diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 6ec950eba9..1567a0c7d4 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -63,6 +63,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 1d1400d10b..63a656ec73 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -6,6 +6,7 @@ ffi/unsafe ffi/unsafe/objc "utils.rkt" + "const.rkt" "types.rkt" "frame.rkt" "window.rkt" @@ -63,9 +64,10 @@ file-creator-and-type file-selector key-symbol-to-menu-key - needs-grow-box-spacer?) + needs-grow-box-spacer? + get-current-mouse-state) -(import-class NSScreen NSCursor NSMenu) +(import-class NSScreen NSCursor NSMenu NSEvent) (define (find-graphical-system-path what) #f) @@ -192,3 +194,28 @@ (define (needs-grow-box-spacer?) (not (version-10.7-or-later?))) + +;; ------------------------------------------------------------ +;; Mouse and modifier-key state + +(define (get-current-mouse-state) + (define posn (tell #:type _NSPoint NSEvent mouseLocation)) + (define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons)) + (define mods (tell #:type _NSUInteger NSEvent modifierFlags)) + (define (maybe v mask sym) + (if (zero? (bitwise-and v mask)) + null + (list sym))) + (define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) + (NSSize-height (NSRect-size f)))) + (values (make-object point% + (->long (NSPoint-x posn)) + (->long (- (- h (NSPoint-y posn)) (get-menu-bar-height)))) + (append + (maybe buttons #x1 'left) + (maybe buttons #x2 'right) + (maybe mods NSShiftKeyMask 'shift) + (maybe mods NSCommandKeyMask 'meta) + (maybe mods NSAlternateKeyMask 'alt) + (maybe mods NSControlKeyMask 'control) + (maybe mods NSAlphaShiftKeyMask 'caps)))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index d46279c9a5..59fa99636c 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -22,7 +22,8 @@ display-origin display-size display-count - location->window)) + location->window + get-current-mouse-state)) ;; ---------------------------------------- @@ -57,6 +58,13 @@ (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) +(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow)) +(define-gdk gdk_window_get_pointer (_fun _GdkWindow + (x : (_ptr o _int)) + (y : (_ptr o _int)) + (mods : (_ptr o _uint)) + -> _GdkWindow + -> (values x y mods))) (define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) (define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) @@ -543,3 +551,24 @@ [fh (send f get-height)]) (<= fy y (+ fy fh))) f)))) + +;; ---------------------------------------- + +(define (get-current-mouse-state) + (define-values (x y mods) (gdk_window_get_pointer + (gdk_screen_get_root_window + (gdk_screen_get_default)))) + (define (maybe mask sym) + (if (zero? (bitwise-and mods mask)) + null + (list sym))) + (values (make-object point% x y) + (append + (maybe GDK_BUTTON1_MASK 'left) + (maybe GDK_BUTTON2_MASK 'middle) + (maybe GDK_BUTTON3_MASK 'right) + (maybe GDK_SHIFT_MASK 'shift) + (maybe GDK_LOCK_MASK 'caps) + (maybe GDK_CONTROL_MASK 'control) + (maybe GDK_MOD1_MASK 'alt) + (maybe GDK_META_MASK 'meta)))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index a54adf28b5..1194feef74 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 352f6366a9..5c2e0654e1 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -50,6 +50,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 0a70c3d3b2..e3d775ef3f 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 7c7f6d8752..81ef379e7a 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -43,6 +43,7 @@ get-highlight-text-color check-for-break) flush-display + get-current-mouse-state fill-private-color play-sound location->window @@ -116,3 +117,26 @@ (define (check-for-break) #f) (define (needs-grow-box-spacer?) #f) + +(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL) + -> (if r + p + (failed 'GetCursorPos)))) +(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT)) +(define-user32 GetSystemMetrics (_wfun _int -> _int)) +(define SM_SWAPBUTTON 23) +(define (get-current-mouse-state) + (define p (GetCursorPos)) + (define (maybe vk sym) + (if (negative? (GetAsyncKeyState vk)) + (list sym) + null)) + (define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON)))) + (values (make-object point% (POINT-x p) (POINT-y p)) + (append + (maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left) + (maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right) + (maybe VK_LSHIFT 'shift) + (maybe VK_CONTROL 'control) + (maybe VK_MENU 'alt) + (maybe VK_CAPITAL 'caps)))) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 441b46b541..a777274f4e 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's @tech{handler thread}.} +@defproc[(get-current-mouse-state) (values (is-a?/c point%) + (listof (or/c 'left 'middle 'right + 'shift 'control 'alt 'meta 'caps)))]{ + +Returns the current location of the mouse in screen coordinates, +and returns a list of symbols for mouse buttons and modifier keys +that are currently pressed.} + + @defproc[(hide-cursor-until-moved) void?]{ Hides the cursor until the user moves the mouse or clicks the mouse diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 8566a95198..dbc19149f6 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -2289,6 +2289,30 @@ '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se)) (send f show #t)) +;---------------------------------------------------------------------- + +(define (mouse) + (define f (new frame% + [label "Mouse"] + [width 300] + [height 200])) + (define m (new message% + [parent f] + [label ""] + [stretchable-width #t])) + (send f show #t) + (thread (lambda () + (let loop () + (when (send f is-shown?) + (sleep 0.1) + (define-values (pos keys) (get-current-mouse-state)) + (queue-callback + (lambda () (send m set-label + (format "~a,~a ~a" + (send pos get-x) + (send pos get-y) + keys)))) + (loop)))))) ;---------------------------------------------------------------------- @@ -2370,6 +2394,8 @@ (make-object vertical-pane% crp) ; filler (make-object button% "Cursors" crp (lambda (b e) (cursors))) (make-object vertical-pane% crp) ; filler +(make-object button% "Mouse" crp (lambda (b e) (mouse))) +(make-object vertical-pane% crp) ; filler (make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame))) (define cp (make-object horizontal-pane% ap)) (send cp stretchable-width #f) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 2faafc9d63..5cf717187d 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,6 @@ +Version 5.3.1.5 +racket/gui: added get-current-mouse-state + Version 5.3.1.2 compiler/zo-structs: added a constantness field to module-variable