From 90a1c3f4e40c54d5db5145f5805c683b8446002f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 15:57:41 -0600 Subject: [PATCH] win32: clipboard and popup menu --- collects/mred/private/wx/win32/clipboard.rkt | 150 ++++++++++++++++++- collects/mred/private/wx/win32/frame.rkt | 2 + collects/mred/private/wx/win32/menu.rkt | 27 +++- collects/mred/private/wx/win32/panel.rkt | 1 + collects/mred/private/wx/win32/types.rkt | 4 + collects/mred/private/wx/win32/utils.rkt | 8 + collects/mred/private/wx/win32/window.rkt | 17 +-- collects/mred/private/wx/win32/wndclass.rkt | 4 +- 8 files changed, 198 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt index 76a531e5f5..355cbc530b 100644 --- a/collects/mred/private/wx/win32/clipboard.rkt +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -1,12 +1,156 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/alloc + racket/draw/bstr + "../common/queue.rkt" + "../../lock.rkt" + "types.rkt" + "utils.rkt" + "const.rkt" + "../../syntax.rkt" + "wndclass.rkt") (provide clipboard-driver% has-x-selection?) (define (has-x-selection?) #f) +;; Dummy window to own the clipboard: +(define clipboard-owner-hwnd + (CreateWindowExW 0 "PLTFrame" "" + WS_POPUP + 0 0 10 10 + #f + #f + hInstance + #f)) + +(define CF_UNICODETEXT 13) + +(define-user32 GetClipboardOwner (_wfun -> _HWND)) +(define-user32 OpenClipboard (_wfun _HWND -> _BOOL)) +(define-user32 CloseClipboard (_wfun -> _BOOL)) +(define-user32 EmptyClipboard (_wfun -> (r : _BOOL) -> (unless r (failed 'EmptyClipboard)))) + +(define-user32 RegisterClipboardFormatW (_wfun _string/utf-16 -> (r : _UINT) + -> (if (zero? r) + (failed 'RegisterClipboardFormatW) + r))) + +(define-kernel32 GlobalFree (_wfun _HANDLE -> (r : _HANDLE) + -> (unless r (failed 'GlobalFree))) + #:wrap (deallocator)) +(define-kernel32 GlobalAlloc (_wfun _UINT _SIZE_T -> (r : _HANDLE) + -> (or r (failed 'GlobalAlloc))) + #:wrap (allocator GlobalFree)) + +(define-kernel32 GlobalLock (_wfun _HANDLE -> (r : _pointer) + -> (or r (failed 'GlobalLock)))) +(define-kernel32 GlobalUnlock (_wfun _HANDLE -> _BOOL)) +(define-kernel32 GlobalSize (_wfun _HANDLE -> (r : _SIZE_T) + -> (if (zero? r) + (failed 'GlobalSize) + r))) + +(define-user32 SetClipboardData (_wfun _UINT _HANDLE -> (r : _HANDLE) + -> (unless r (failed 'SetClipboardData))) + ;; SetClipboardData accepts responsibility for the handle: + #:wrap (deallocator cadr)) + +(define-user32 GetClipboardData (_wfun _UINT -> _HANDLE)) + +(define GHND #x0042) + (defclass clipboard-driver% object% (init x-selection?) ; always #f + + (define client #f) + (define counter -1) + + (define/public (clear-client) + ;; called in event-pump thread + (set! client #f)) + + (define/public (get-client) + (and client + (if (ptr-equal? clipboard-owner-hwnd + (GetClipboardOwner)) + client + (let ([c client]) + (set! client #f) + (drop-client c) + #f)))) + + (define/private (drop-client c) + (queue-event (send c get-client-eventspace) + (lambda () + (send c on-replaced)))) + + (define/public (set-client c types) + (let* ([type-ids (for/list ([t (in-list types)]) + (if (string=? t "TEXT") + CF_UNICODETEXT + (RegisterClipboardFormatW t)))] + [all-data (for/list ([t (in-list types)] + [t-id (in-list type-ids)]) + (let ([d (send c get-data t)]) + (cond + [(equal? t-id CF_UNICODETEXT) + ;; convert UTF-8 to UTF-16: + (let ([p (cast (bytes->string/utf-8 d #\?) + _string/utf-16 + _gcpointer)]) + (let ([len (let loop ([i 0]) + (if (and (zero? (ptr-ref p _byte i)) + (zero? (ptr-ref p _byte (add1 i)))) + (+ i 2) + (loop (+ i 2))))]) + (scheme_make_sized_byte_string p + len + 0)))] + [else + ;; no conversion: + d])))] + [all-handles (for/list ([d (in-list all-data)]) + (let ([h (GlobalAlloc GHND (bytes-length d))]) + (let ([p (GlobalLock h)]) + (memcpy p d (bytes-length d))) + (GlobalUnlock h) + h))]) + (if (null? types) + (drop-client c) + (atomically + (if (OpenClipboard clipboard-owner-hwnd) + (begin + (EmptyClipboard) + (for ([t (in-list type-ids)] + [h (in-list all-handles)]) + (SetClipboardData t h)) + (if (CloseClipboard) + (set! client c) + (drop-client c))) + (drop-client c)))))) + + (define/public (get-data format [as-text? #f]) + (let ([t (if (string=? format "TEXT") + CF_UNICODETEXT + (RegisterClipboardFormatW format))]) + (atomically + (and (OpenClipboard clipboard-owner-hwnd) + (let ([d (GetClipboardData t)]) + (begin0 + (and d + (let ([hsize (GlobalSize d)] + [p (GlobalLock d)]) + (begin0 + (if as-text? + (cast p _pointer _string/utf-16) + (scheme_make_sized_byte_string p hsize 1)) + (GlobalUnlock d)))) + (CloseClipboard))))))) + + (define/public (get-text-data) + (or (get-data "TEXT" #t) "")) + (super-new)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 38fd5882d7..030cd0dce6 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -212,6 +212,8 @@ (when (pair? focus-window-path) (SetFocus (send (last focus-window-path) get-focus-hwnd)))) + (define/override (can-accept-focus?) + #f) (define/override (child-can-accept-focus?) #t) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index a13516f477..db2f8d7a9e 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -4,6 +4,7 @@ (only-in racket/list drop take) "../../lock.rkt" "../../syntax.rkt" + "../common/event.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -16,15 +17,25 @@ -> (unless r (failed 'AppendMenuW)))) (define-user32 EnableMenuItem (_wfun _HMENU _UINT _UINT -> _BOOL)) +(define-user32 TrackPopupMenu(_wfun _HMENU _UINT _int _int _int _HWND (_or-null _RECT-pointer) + -> _int)) + +(define TPM_LEFTBUTTON #x0000) +(define TPM_RIGHTBUTTON #x0002) +(define TPM_NONOTIFY #x0080) +(define TPM_RETURNCMD #x0100) + (defclass menu% object% (init lbl - callback + cb font) (define label lbl) (define parent #f) (define items null) + (define callback cb) + (define hmenu (CreatePopupMenu)) (define/public (get-hmenu) hmenu) @@ -42,6 +53,20 @@ (def/public-unimplemented set-width) (def/public-unimplemented set-title) + (define/public (popup gx gy hwnd call-callback) + (let ([cmd (TrackPopupMenu hmenu + (bitwise-ior + TPM_LEFTBUTTON + TPM_RIGHTBUTTON + TPM_NONOTIFY + TPM_RETURNCMD) + gx gy + 0 hwnd #f)]) + (let* ([e (new popup-event% [event-type 'menu-popdown])]) + (unless (zero? cmd) + (send e set-menu-id cmd)) + (call-callback (lambda () (callback this e)))))) + (define/private (with-item id proc) (let loop ([items items] [pos 0]) (cond diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index f1aae1b417..295e4584d2 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -3,6 +3,7 @@ "../../syntax.rkt" "window.rkt" "wndclass.rkt" + "utils.rkt" "const.rkt" "cursor.rkt") diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index f280b81f6e..4c3ccfd433 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -17,6 +17,7 @@ _SHORT _HRESULT _WCHAR + _SIZE_T _HINSTANCE _HWND @@ -27,6 +28,7 @@ _HDC _HFONT _HBITMAP + _HANDLE _COLORREF @@ -58,6 +60,7 @@ (define _BYTE _uint8) (define _HRESULT _int32) (define _WCHAR _int16) +(define _SIZE_T _long) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) @@ -68,6 +71,7 @@ (define _HDC (_cpointer/null 'HDC)) (define _HFONT (_cpointer/null 'HFONT)) (define _HBITMAP (_cpointer/null 'HBITMAP)) +(define _HANDLE (_cpointer/null 'HANDLE)) (define _COLORREF _DWORD) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 20617d4ed4..70786d9d5b 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -12,6 +12,7 @@ define-mz failed + CreateWindowExW GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str @@ -47,6 +48,13 @@ (error who "call failed (~s)" (GetLastError))) +(define-user32 CreateWindowExW (_wfun _DWORD + _string/utf-16 + _string/utf-16 + _UDWORD + _int _int _int _int + _HWND _HMENU _HINSTANCE _pointer + -> _HWND)) (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index a53dfecd80..29fe8829a6 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -21,7 +21,6 @@ queue-window-event queue-window-refresh-event - CreateWindowExW GetWindowRect GetClientRect) @@ -41,13 +40,6 @@ (define HTHSCROLL 6) (define HTVSCROLL 7) -(define-user32 CreateWindowExW (_wfun _DWORD - _string/utf-16 - _string/utf-16 - _UDWORD - _int _int _int _int - _HWND _HMENU _HINSTANCE _pointer - -> _HWND)) (define-user32 GetWindowRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> (if r rect (failed 'GetWindowRect)))) (define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> @@ -305,7 +297,14 @@ (resize (max (->int (+ w dw)) (->int (* dlu-x min-w))) (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) - (def/public-unimplemented popup-menu) + (define/public (popup-menu m x y) + (let ([gx (box x)] + [gy (box y)]) + (client-to-screen gx gy) + (send m popup (unbox gx) (unbox gy) + hwnd + (lambda (thunk) (queue-window-event this thunk))))) + (def/public-unimplemented center) (define/public (get-parent) parent) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index cd40e1b55a..a0b94cce7d 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -71,7 +71,7 @@ (define-user32 RegisterClassW (_wfun _WNDCLASS-pointer -> _ATOM)) (define-kernel32 GetModuleHandleW (_wfun _pointer -> _HINSTANCE)) (define-user32 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR)) -(define-user32 LoadIconW (_wfun _HINSTANCE _pointer -> _HICON)) +(define-user32 LoadIconW (_wfun _HINSTANCE _string/utf-16 -> _HICON)) (define-user32 GetClassInfoW (_wfun _HINSTANCE _string/utf-16 (i : (_ptr o _WNDCLASS)) -> (r : _BOOL) -> (if r i (failed 'GetClassInfoW)))) @@ -97,7 +97,7 @@ 0 0 hInstance - (LoadIconW #f IDI_APPLICATION) + (LoadIconW hInstance "WXSTD_FRAME") #f background-hbrush #f ; menu