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

cocoa: bitmap from clipboard

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-20 16:09:21 -07:00
parent be5920618d
commit 56f311d204
8 changed files with 100 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/mred/private/wx/cocoa/bitmap.rkt Normal file
View File

@ -0,0 +1,43 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
racket/draw/cairo
racket/draw/bitmap
racket/draw/local
"types.rkt"
"utils.rkt"
"../../lock.rkt"
"cg.rkt")
(provide quartz-bitmap%)
(define quartz-bitmap%
(class bitmap%
(init w h)
(super-make-object (make-alternate-bitmap-kind w h))
(define s
(let ([s (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32
w
h)])
;; initialize bitmap to empty - needed?
#;
(let ([cr (cairo_create s)])
(cairo_set_operator cr CAIRO_OPERATOR_CLEAR)
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
(cairo_paint cr)
(cairo_destroy cr))
s))
(define/override (ok?) #t)
(define/override (is-color?) #t)
(define/override (get-cairo-surface) s)
(define/override (get-cairo-alpha-surface) s)
(define/override (release-bitmap-storage)
(atomically
(when s
(cairo_surface_destroy s)
(set! s #f))))))

13
collects/mred/private/wx/cocoa/clipboard.rkt
View File

@ -4,6 +4,7 @@
ffi/unsafe/objc
"utils.rkt"
"types.rkt"
"image.rkt"
"../common/bstr.rkt"
"../../syntax.rkt"
"../../lock.rkt")
@ -11,7 +12,7 @@
(provide clipboard-driver%
has-x-selection?)
(import-class NSPasteboard NSArray NSData)
(import-class NSPasteboard NSArray NSData NSImage NSGraphicsContext)
(import-protocol NSPasteboardOwner)
(define (has-x-selection?) #f)
@ -85,4 +86,12 @@
(and data
(let ([len (tell #:type _NSUInteger data length)]
[bstr (tell #:type _pointer data bytes)])
(scheme_make_sized_byte_string bstr len 1))))))))
(scheme_make_sized_byte_string bstr len 1)))))))
(define/public (get-bitmap-data)
(atomically
(with-autorelease
(let ([i (tell (tell NSImage alloc)
initWithPasteboard: (tell NSPasteboard generalPasteboard))])
(and i
(image->bitmap i)))))))

31
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -8,6 +8,7 @@
racket/draw/gl-context
"types.rkt"
"utils.rkt"
"bitmap.rkt"
"window.rkt"
"../../lock.rkt"
"../common/queue.rkt"
@ -20,36 +21,6 @@
(import-class NSOpenGLContext)
(define quartz-bitmap%
(class bitmap%
(init w h)
(super-make-object (make-alternate-bitmap-kind w h))
(define s
(let ([s (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32
w
h)])
;; initialize bitmap to empty - needed?
#;
(let ([cr (cairo_create s)])
(cairo_set_operator cr CAIRO_OPERATOR_CLEAR)
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
(cairo_paint cr)
(cairo_destroy cr))
s))
(define/override (ok?) #t)
(define/override (is-color?) #t)
(define/override (get-cairo-surface) s)
(define/override (get-cairo-alpha-surface) s)
(define/override (release-bitmap-storage)
(atomically
(when s
(cairo_surface_destroy s)
(set! s #f))))))
(define dc%
(class backing-dc%
(init [(cnvs canvas)])

33
collects/mred/private/wx/cocoa/image.rkt
View File

@ -2,18 +2,24 @@
(require ffi/unsafe
ffi/unsafe/objc
racket/class
racket/draw/cairo
racket/draw/local
"../common/bstr.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"cg.rkt"
"bitmap.rkt"
"../../lock.rkt"
(only-in '#%foreign ffi-callback))
(provide bitmap->image)
(provide bitmap->image
image->bitmap)
(import-class NSImage NSGraphicsContext)
(define NSCompositeCopy 1)
(define _CGImageRef (_cpointer 'CGImageRef))
(define _CGColorSpaceRef (_cpointer 'CGColorSpaceRef))
(define _CGDataProviderRef (_cpointer 'GCDataProviderRef))
@ -103,3 +109,28 @@
(tellv i unlockFocus)
i))))))
(define (image->bitmap i)
(let* ([s (tell #:type _NSSize i size)]
[w (NSSize-width s)]
[h (NSSize-height s)]
[bm (make-object quartz-bitmap%
(inexact->exact (ceiling w))
(inexact->exact (ceiling h)))]
[surface (let ([s (send bm get-cairo-surface)])
(cairo_surface_flush s)
s)]
[cg (cairo_quartz_surface_get_cg_context surface)]
[gc (tell NSGraphicsContext
graphicsContextWithGraphicsPort: #:type _pointer cg
flipped: #:type _BOOL #f)])
(CGContextSaveGState cg)
(CGContextTranslateCTM cg 0 h)
(CGContextScaleCTM cg 1 -1)
(tellv NSGraphicsContext saveGraphicsState)
(tellv NSGraphicsContext setCurrentContext: gc)
(let ([r (make-NSRect (make-NSPoint 0 0) (make-NSSize w h))])
(tellv i drawInRect: #:type _NSRect r fromRect: #:type _NSRect r
operation: #:type _int NSCompositeCopy fraction: #:type _CGFloat 1.0))
(tellv NSGraphicsContext restoreGraphicsState)
(CGContextRestoreGState cg)
bm))

2
collects/mred/private/wx/common/clipboard.rkt
View File

@ -37,7 +37,7 @@
(eq? c (send driver get-client)))
(def/public (get-clipboard-bitmap [exact-integer? timestamp])
#f)
(send driver get-bitmap-data))
(def/public-unimplemented set-clipboard-bitmap)
(def/public (get-clipboard-data [string? type]
[exact-integer? timestamp])

3
collects/mred/private/wx/gtk/clipboard.rkt
View File

@ -171,5 +171,8 @@
(define/public (get-text-data)
(or (gtk_clipboard_wait_for_text cb) ""))
(define/public (get-bitmap-data)
#f)
(super-new))

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

@ -152,5 +152,8 @@
(define/public (get-text-data)
(or (get-data "TEXT" #t) ""))
(define/public (get-bitmap-data)
#f)
(super-new))

7
collects/racket/draw/cairo.rkt
View File

@ -28,7 +28,7 @@
(define _cairo_t (_cpointer 'cairo_t))
(define _cairo_pattern_t (_cpointer 'cairo_pattern_t))
(define _cairo_font_options_t (_cpointer/null 'cairo_font_options_t))
(define _CGContextRef _pointer)
(define _CGContextRef (_cpointer 'CGContextRef))
(define-cstruct _cairo_matrix_t ([xx _double*]
[yx _double*]
@ -55,10 +55,15 @@
(_fun _CGContextRef _uint _uint -> _cairo_surface_t)
#:make-fail make-not-available
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_quartz_surface_get_cg_context
(_fun _cairo_surface_t -> _CGContextRef)
#:make-fail make-not-available)
(define-cairo cairo_win32_surface_create
(_fun _pointer -> _cairo_surface_t)
#:make-fail make-not-available
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_surface_create_similar
(_fun _cairo_surface_t _int _int _int -> _cairo_surface_t))