From edd2035f88b571afc9ed85ba0f7c6167332fb5b3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 23 Aug 2012 09:42:34 -0600
Subject: [PATCH] racket/draw: fix `set-clipping-rect' in `record-dc%'

---
 collects/racket/draw/private/record-dc.rkt | 25 +++++++++++++++++++---
 collects/tests/gracket/dc.rktl             | 22 +++++++++++++++++++
 2 files changed, 44 insertions(+), 3 deletions(-)

diff --git a/collects/racket/draw/private/record-dc.rkt b/collects/racket/draw/private/record-dc.rkt
index 6a09bc621c..3221940cb5 100644
--- a/collects/racket/draw/private/record-dc.rkt
+++ b/collects/racket/draw/private/record-dc.rkt
@@ -544,10 +544,13 @@
       (super erase)
       (reset-recording))
 
-    ;; For the compsable part of the DC, we writ things out the long way.
+    ;; For the compsable part of the DC, we write things out the long way.
     ;; For everythign else, we use `define/record'.
 
     (define/override (set-clipping-region r)
+      (do-set-clipping-region r))
+
+    (define/private (do-set-clipping-region r)
       (super set-clipping-region r)
       (when (continue-recording?)
         (let-values ([(make-r paths has-dc?) (region-maker r)])
@@ -558,6 +561,14 @@
                     state)
                   (lambda () (list 'set-clipping-region (convert-region paths has-dc?)))))))
 
+    (def/override (set-clipping-rect [real? x] 
+                                     [real? y] 
+                                     [nonnegative-real? w]
+                                     [nonnegative-real? h])
+      (let ([r (make-object region% this)])
+        (send r set-rectangle x y w h)
+        (do-set-clipping-region r)))
+
     (define/override (set-alpha a)
       (super set-alpha a)
       (record (lambda (dc state)
@@ -595,6 +606,16 @@
                                                                                (dc-state-region state)
                                                                                (make-r dc state)))
                                  state))]
+      [(set-clipping-rect) ;; backward compatibility for old datums
+       (lambda (x y w h)
+         (define r (make-object region% #f))
+         (send r set-rectangle x y w h)
+         (define make-r (unconvert-region (convert-region r #f)))
+         (lambda (dc state)
+           (send dc set-clipping-region (combine-regions dc
+                                                         (dc-state-region state)
+                                                         (make-r dc state)))
+           state))]
       [(set-alpha) (lambda (a)
                      (lambda (dc state)
                        (send dc set-alpha (* a (dc-state-alpha state)))
@@ -631,8 +652,6 @@
      
      (define/record (set-text-mode m))
 
-     (define/record (set-clipping-rect x y w h))
-
      (define/record (clear))
      
      (define/record (draw-arc x y width height start-radians end-radians))
diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl
index b04cf8ca50..21da9ad3d1 100644
--- a/collects/tests/gracket/dc.rktl
+++ b/collects/tests/gracket/dc.rktl
@@ -596,6 +596,28 @@
       (send gl1 call-as-current (lambda () (error "fail"))))
     (test 12 'post-exn (send gl1 call-as-current (lambda () 12)))))
 
+
+;; ----------------------------------------
+;; check clipping
+
+(let ()
+  (define rdc (new record-dc%))
+  (send rdc set-brush "green" 'solid)
+  (send rdc set-clipping-rect 2 2 5 5)
+  (send rdc draw-rectangle 0 0 9 9)
+
+  (define bm (make-bitmap 25 25))
+  (define bm-dc (make-object bitmap-dc% bm))
+
+  (send bm-dc set-clipping-rect 10 10 5 5)
+
+  ((send rdc get-recorded-procedure) bm-dc)
+
+  (define s (make-bytes (* 20 20 4)))
+  (send bm get-argb-pixels 0 0 20 20 s)
+  (for ([i (in-range 0 (* 20 20 4) 4)])
+    (test 0 'record-dc-clipping-byte (bytes-ref s i))))
+
 ;; ----------------------------------------
 
 (report-errs)