win32: clipboard and popup menu

collects/mred/private/wx/win32/clipboard.rkt

@@ -1,12 +1,156 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/class
+(require racket/class
-          "../../syntax.rkt")
+         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))

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)
 

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

collects/mred/private/wx/win32/panel.rkt

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

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)
 

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

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)

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