racket/gui: implement set-clipboard-bitmap' in clipboard<%>'

Closes PR 12689

Cocoa implementation provided by Jens Axel Søgaard

original commit: 58db5f8b46bc8e9603a1557c1804a8a87e70b1c4

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

@@ -100,4 +100,14 @@
       (let ([i (tell (tell NSImage alloc) 
                      initWithPasteboard: (tell NSPasteboard generalPasteboard))])
         (and i
-             (image->bitmap i)))))))
+             (image->bitmap i))))))
+
+  (define/public (set-bitmap-data bm timestamp)
+    (define image (bitmap->image bm))
+    (atomically
+     (with-autorelease
+      (let ([pasteboard (tell NSPasteboard generalPasteboard)])
+        (tell pasteboard clearContents)
+        (let ([copied-objects (tell NSArray arrayWithObject: image)])
+          (tell pasteboard writeObjects: copied-objects)
+          (void)))))))

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

@@ -1,5 +1,6 @@
 #lang racket/base
 (require racket/class
+         (only-in racket/draw bitmap%)
          "../../syntax.rkt"
          "../platform.rkt"
          "local.rkt"
@@ -61,7 +62,8 @@
 
   (def/public (get-clipboard-bitmap [exact-integer? timestamp])
     (send driver get-bitmap-data))
-  (def/public-unimplemented set-clipboard-bitmap)
+  (def/public (set-clipboard-bitmap [bitmap% bm] [exact-integer? timestamp])
+    (send driver set-bitmap-data bm timestamp))
   (def/public (get-clipboard-data [string? type]
                                   [exact-integer? timestamp])
     (send driver get-data type))

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

@@ -127,6 +127,8 @@
   (_fun _GtkClipboard (_fpointer = string_request_received) _pointer -> _void))
 (define-gtk gtk_clipboard_request_image 
   (_fun _GtkClipboard (_fpointer = image_request_received) _pointer -> _void))
+(define-gtk gtk_clipboard_set_image 
+  (_fun _GtkClipboard _GdkPixbuf -> _void))
 
 ;; ----------------------------------------
 
@@ -295,6 +297,10 @@
       (let-values ([(l backref) (make-request-backref)])
 	(gtk_clipboard_request_image cb backref)
 	l))))
+
+  (define/public (set-bitmap-data bm timestamp)
+    (define pb (bitmap->pixbuf bm))
+    (gtk_clipboard_set_image cb pb))
   
   (super-new))
 

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

@@ -196,7 +196,17 @@
           (begin0
            (get-bitmap-from-clipboard)
            (CloseClipboard)))))
-                
+
+  (define/public (set-bitmap-data bm timestamp)
+    (define h (bitmap->hbitmap bm))
+    (set-cpointer-tag! h '(HBITMAP HANDLE))
+    (atomically
+     (when (OpenClipboard clipboard-owner-hwnd)
+       (EmptyClipboard)
+       (SetClipboardData CF_BITMAP h)
+       (CloseClipboard)
+       (void))))
+
   (super-new))