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

win32: clipboard and popup menu

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-10 15:57:41 -06:00
parent 22e7cb437d
commit 90a1c3f4e4
8 changed files with 198 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
collects/mred/private/wx/win32/clipboard.rkt
View File

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

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

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

27
collects/mred/private/wx/win32/menu.rkt
View File

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

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

@ -3,6 +3,7 @@
"../../syntax.rkt"
"window.rkt"
"wndclass.rkt"
"utils.rkt"
"const.rkt"
"cursor.rkt")

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

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

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

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

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

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

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

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