win32: paste bitmap

original commit: 003ba8439a8196c90f450174607b987123c6dfb1

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

@@ -9,7 +9,8 @@
          "utils.rkt"
          "const.rkt"
          "../../syntax.rkt"
-         "wndclass.rkt")
+         "wndclass.rkt"
+         "hbitmap.rkt")
 
 (provide clipboard-driver%
          has-x-selection?)
@@ -27,6 +28,31 @@
                    #f))
 
 (define CF_UNICODETEXT      13)
+(define CF_BITMAP           2)
+(define CF_DIB              8)
+
+(define DIB_RGB_COLORS      0)
+(define SRCCOPY             #x00CC0020)
+
+(define-cstruct _BITMAPINFOHEADER
+  ([biSize _DWORD]
+   [biWidth _LONG]
+   [biHeight _LONG]
+   [biPlanes _WORD]
+   [biBitCount _WORD]
+   [biCompression _DWORD]
+   [biSizeImage _DWORD]
+   [biXPelsPerMeter _LONG]
+   [biYPelsPerMeter _LONG]
+   [biClrUsed _DWORD]
+   [biClrImportant _DWORD]))
+
+(define-cstruct _BITMAPCOREHEADER
+  ([bcSize _DWORD]
+   [bcWidth _LONG]
+   [bcHeight _LONG]
+   [bcPlanes _WORD]
+   [bcBitCount _WORD]))
 
 (define-user32 GetClipboardOwner (_wfun -> _HWND))
 (define-user32 OpenClipboard (_wfun _HWND -> _BOOL))
@@ -60,6 +86,10 @@
 
 (define-user32 GetClipboardData (_wfun _UINT -> _HANDLE))
 
+(define-gdi32 StretchDIBits(_wfun _HDC _int _int _int _int _int _int _int _int
+                                  _pointer _BITMAPINFOHEADER-pointer _UINT _DWORD
+                                  -> _int))
+
 (define GHND #x0042)
 
 (defclass clipboard-driver% object%
@@ -154,6 +184,75 @@
     (or (get-data "TEXT" #t) ""))
 
   (define/public (get-bitmap-data)
-    #f)
+    (atomically
+     (and (OpenClipboard clipboard-owner-hwnd)
+          (begin0
+           (get-bitmap-from-clipboard)
+           (CloseClipboard)))))
                 
   (super-new))
+
+
+(define (get-bitmap-from-clipboard)
+  ;; atomic mode
+  (cond
+   ;; I think we should be able to use CF_BITMAP always, but
+   ;; it doesn't work right under Windows XP with a particular 
+   ;; image created by copying in Firefox. So, we do things the
+   ;; hard way.
+   [(GetClipboardData CF_DIB)
+    => (lambda (bits)
+         (let ([bmi (cast (GlobalLock bits) _pointer _BITMAPINFOHEADER-pointer)])
+           (let ([w (BITMAPINFOHEADER-biWidth bmi)]
+                 [h (BITMAPINFOHEADER-biHeight bmi)]
+                 [bits/pp (BITMAPINFOHEADER-biBitCount bmi)])
+             (let* ([screen-hdc (GetDC #f)]
+                    [hdc (CreateCompatibleDC screen-hdc)]
+                    [hbitmap (if (= bits/pp 1)
+                                 (CreateBitmap w h 1 1 #f)
+                                 (CreateCompatibleBitmap screen-hdc w h))]
+                    [old-hbitmap (SelectObject hdc hbitmap)]
+                    [psize (PaletteSize bmi)])
+               (ReleaseDC #f screen-hdc)
+               (StretchDIBits hdc 0 0 w h
+                              0 0 w h
+                              (ptr-add bmi (+ (BITMAPINFOHEADER-biSize bmi) psize))
+                              bmi DIB_RGB_COLORS SRCCOPY)
+               (SelectObject hdc old-hbitmap)
+               (GlobalUnlock bits)
+               (DeleteDC hdc)
+               (begin0
+                (hbitmap->bitmap hbitmap)
+                (DeleteObject hbitmap))))))]
+   [(GetClipboardData CF_BITMAP)
+    => (lambda (hbitmap)
+         (hbitmap->bitmap hbitmap))]
+   [else #f]))
+
+;; Copied from MS example:
+
+(define (DibNumColors bmc? bmi)
+  ;; /*  With the BITMAPINFO format headers, the size of the palette
+  ;;  *  is in biClrUsed, whereas in the BITMAPCORE - style headers, it
+  ;;  *  is dependent on the bits per pixel ( = 2 raised to the power of
+  ;;  *  bits/pixel).
+  ;;  */
+  (if (and (not bmc?)
+           (not (zero? (BITMAPINFOHEADER-biClrUsed bmi))))
+      (BITMAPINFOHEADER-biClrUsed bmi)
+      (let ([bits (BITMAPINFOHEADER-biBitCount bmi)])
+        (case bits
+          [(1) 2]
+          [(4) 16]
+          [(8) 256]
+          [else
+           ;; A 24 bitcount DIB has no color table
+           0]))))
+
+(define (PaletteSize bmi)
+  (let* ([bmc? (= (BITMAPINFOHEADER-biSize bmi)
+                  (ctype-sizeof _BITMAPCOREHEADER))]
+         [num-colors (DibNumColors bmc? bmi)])
+    (if bmc?
+        (* num-colors 3)
+        (* num-colors 4))))

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

@@ -8,7 +8,8 @@
          "utils.rkt"
          "const.rkt")
 
-(provide bitmap->hbitmap)
+(provide bitmap->hbitmap
+         hbitmap->bitmap)
 
 (define (bitmap->hbitmap bm 
                          #:mask [mask-bm #f]
@@ -56,4 +57,40 @@
       (DeleteDC hdc)
       hbitmap)))
 
+(define-cstruct _BITMAP
+  ([bmType _LONG]
+   [bmWidth _LONG]
+   [bmHeight _LONG]
+   [bmWidthBytes _LONG]
+   [bmPlanes _WORD]
+   [bmBitsPixel _WORD]
+   [bmBits _pointer]))
 
+(define-gdi32 GetObjectW (_wfun _pointer _int _pointer -> (r : _int)
+                                -> (when (zero? r) (failed 'GetObject))))
+
+(define (hbitmap->bitmap hbitmap)
+  (let* ([bmi (let ([b (make-BITMAP 0 0 0 0 0 0 #f)])
+                (GetObjectW hbitmap (ctype-sizeof _BITMAP) b)
+                b)]
+         [w (BITMAP-bmWidth bmi)]
+         [h (BITMAP-bmHeight bmi)]
+         [screen-hdc (GetDC #f)]
+         [hdc (CreateCompatibleDC screen-hdc)]
+         [old-hbitmap (SelectObject hdc hbitmap)]
+         [bm (make-object bitmap% w h (= 1 (BITMAP-bmBitsPixel bmi)) #t)])
+    (ReleaseDC #f screen-hdc)
+    (let* ([s (cairo_win32_surface_create hdc)]
+           [cr (cairo_create (send bm get-cairo-surface))])
+      (let ([p (cairo_get_source cr)])
+        (cairo_pattern_reference p)
+        (cairo_set_source_surface cr s 0 0)
+        (cairo_new_path cr)
+        (cairo_rectangle cr 0 0 w h)
+        (cairo_fill cr)
+        (cairo_set_source cr p)
+        (cairo_pattern_destroy p))
+      (cairo_destroy cr)
+      (SelectObject hdc old-hbitmap)
+      (DeleteDC hdc)
+      bm)))