d5024f0f20
Cairo doesn't seem to deal correctly with an HDC produced by BeginPaint() that has a clipping region. The problem affects only Win64. Work around the problem by drawing to a separate HDC and copying to/from the screen. (To see the problem before this patch, draw the DrRacket window to the edge of the screen and back, and observe tha the toolbar doesn't update correctly.) This change could affect performance, but it should mostly be limited to refresh when a window moves.
178 lines
5.5 KiB
Racket
178 lines
5.5 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/winapi
|
|
racket/class
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"gl-context.rkt"
|
|
"../../lock.rkt"
|
|
"../common/backing-dc.rkt"
|
|
"../common/delay.rkt"
|
|
racket/draw/unsafe/cairo
|
|
racket/draw/private/dc
|
|
racket/draw/private/bitmap
|
|
racket/draw/private/local
|
|
ffi/unsafe/alloc)
|
|
|
|
(provide
|
|
(protect-out dc%
|
|
win32-bitmap%
|
|
do-backing-flush
|
|
request-flush-delay
|
|
cancel-flush-delay))
|
|
|
|
(define-gdi32 SelectClipRgn (_wfun _pointer _pointer -> _int))
|
|
|
|
(define-gdi32 GetClipBox (_wfun _pointer _RECT-pointer -> _int))
|
|
(define SIMPLEREGION 2)
|
|
|
|
(define-gdi32 BitBlt (_wfun _pointer _int _int _int _int _pointer _int _int _DWORD -> _BOOL))
|
|
(define SRCCOPY #X00cc0020)
|
|
|
|
(define hwnd-param (make-parameter #f))
|
|
|
|
(define win32-bitmap%
|
|
(class win32-no-hwnd-bitmap%
|
|
(init w h hwnd [gl-config #f])
|
|
(inherit get-cairo-surface)
|
|
(parameterize ([hwnd-param hwnd])
|
|
(super-new [w w] [h h]))
|
|
|
|
(define/override (build-cairo-surface w h)
|
|
(define hwnd (hwnd-param))
|
|
(if hwnd
|
|
(atomically
|
|
(let ([hdc (GetDC hwnd)])
|
|
(begin0
|
|
(cairo_win32_surface_create_with_ddb hdc
|
|
CAIRO_FORMAT_RGB24 w h)
|
|
(ReleaseDC hwnd hdc))))
|
|
(super build-cairo-surface w h)))
|
|
|
|
(define gl (and gl-config
|
|
(let ([hdc (cairo_win32_surface_get_dc (get-cairo-surface))])
|
|
(set-cpointer-tag! hdc 'HDC)
|
|
(create-gl-context hdc
|
|
gl-config
|
|
#t))))
|
|
(define/override (get-bitmap-gl-context) gl)))
|
|
|
|
(define dc%
|
|
(class backing-dc%
|
|
(init [(cnvs canvas)]
|
|
transparent?)
|
|
(inherit end-delay)
|
|
(define canvas cnvs)
|
|
|
|
(super-new [transparent? transparent?])
|
|
|
|
(inherit internal-get-bitmap)
|
|
(define/override (reset-clip cr)
|
|
(super reset-clip cr)
|
|
;; Work around a Cairo(?) bug. When a clipping
|
|
;; region is set, we draw text, and then the clipping
|
|
;; region is changed, the change doesn't take
|
|
;; until we draw more text --- but only under Win64,
|
|
;; and only with DDB surfaces.
|
|
(when win64?
|
|
(let ([bm (internal-get-bitmap)])
|
|
(when (bm . is-a? . win32-bitmap%)
|
|
(SelectClipRgn (cairo_win32_surface_get_dc
|
|
(send bm get-cairo-surface))
|
|
#f)))))
|
|
|
|
(define gl #f)
|
|
(define/override (get-gl-context)
|
|
(or gl
|
|
(let ([v (create-gl-context (GetDC (send canvas get-client-hwnd))
|
|
(send canvas get-gl-config)
|
|
#f)])
|
|
(when v (set! gl v))
|
|
v)))
|
|
|
|
|
|
(define/override (make-backing-bitmap w h)
|
|
(if (send canvas get-canvas-background)
|
|
(make-object win32-bitmap% w h (send canvas get-hwnd))
|
|
(super make-backing-bitmap w h)))
|
|
|
|
(define/override (get-backing-size xb yb)
|
|
(send canvas get-client-size xb yb))
|
|
|
|
(define/override (get-size)
|
|
(let ([xb (box 0)]
|
|
[yb (box 0)])
|
|
(send canvas get-virtual-size xb yb)
|
|
(values (unbox xb) (unbox yb))))
|
|
|
|
(define/override (queue-backing-flush)
|
|
;; Re-enable expose events so that the queued
|
|
;; backing flush will be handled:
|
|
(end-delay)
|
|
(send canvas queue-backing-flush))
|
|
|
|
(define/override (flush)
|
|
(send canvas flush))
|
|
|
|
(define/override (request-delay)
|
|
(request-flush-delay canvas))
|
|
(define/override (cancel-delay req)
|
|
(cancel-flush-delay req))))
|
|
|
|
(define (do-backing-flush canvas dc hdc)
|
|
(send dc on-backing-flush
|
|
(lambda (bm)
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(send canvas get-client-size w h)
|
|
(define r (make-RECT 0 0 (unbox w) (unbox h)))
|
|
(define clip-type
|
|
(if win64?
|
|
(GetClipBox hdc r)
|
|
SIMPLEREGION))
|
|
(cond
|
|
[(and win64?
|
|
(not (and (= clip-type SIMPLEREGION)
|
|
(= (RECT-left r) 0)
|
|
(= (RECT-top r) 0)
|
|
(= (RECT-right r) (unbox w))
|
|
(= (RECT-bottom r) (unbox h)))))
|
|
;; Another workaround: a clipping region installed by BeginPaint()
|
|
;; seems to interfere with Cairo drawing. So, draw to a
|
|
;; fresh context and copy back and forth using Win32.
|
|
(define cw (- (RECT-right r) (RECT-left r)))
|
|
(define ch (- (RECT-bottom r) (RECT-top r)))
|
|
(let* ([surface (cairo_win32_surface_create_with_ddb hdc
|
|
CAIRO_FORMAT_RGB24
|
|
cw
|
|
ch)]
|
|
[cr (cairo_create surface)]
|
|
[hdc2 (cairo_win32_surface_get_dc surface)])
|
|
(BitBlt hdc2 0 0 cw ch hdc (RECT-left r) (RECT-top r) SRCCOPY)
|
|
(backing-draw-bm bm cr (unbox w) (unbox h) (- (RECT-left r)) (- (RECT-top r)))
|
|
(cairo_surface_flush surface)
|
|
(BitBlt hdc (RECT-left r) (RECT-top r) cw ch hdc2 0 0 SRCCOPY)
|
|
(cairo_surface_destroy surface)
|
|
(cairo_destroy cr))]
|
|
[else
|
|
(let* ([surface (cairo_win32_surface_create hdc)]
|
|
[cr (cairo_create surface)])
|
|
(cairo_surface_destroy surface)
|
|
(backing-draw-bm bm cr (unbox w) (unbox h))
|
|
(cairo_destroy cr))])))))
|
|
|
|
(define (request-flush-delay canvas)
|
|
(do-request-flush-delay
|
|
canvas
|
|
(lambda (gtk)
|
|
(send canvas suspend-paint-handling))
|
|
(lambda (gtk)
|
|
(send canvas resume-paint-handling))))
|
|
|
|
(define (cancel-flush-delay req)
|
|
(when req
|
|
(do-cancel-flush-delay
|
|
req
|
|
(lambda (canvas)
|
|
(send canvas resume-paint-handling)))))
|