ensure that dimensions of canvas are below 2000 by 2000; closes PR 11907

collects/2htdp/private/universe-image.rkt

@@ -6,7 +6,7 @@
          htdp/error)
 
 (provide image? scene? image-width image-height text 2:image?
-         check-image check-scene check-scene-result
+         check-image check-scene check-scene-result check-scene-dimensions
          disable-cache)
 
 (define (disable-cache x)
@@ -60,5 +60,10 @@
           (check-result tname 1:scene? "scene" i (image-pins i))
           (check-result tname (lambda _ #f) "scene" i))))
 
+(define (check-scene-dimensions name width height)
+  (unless(and (<= 0 width 2000) (<= 0 height 2000))
+    (define basics "cannot render images larger than 2000 x 2000 pixels")
+    (error 'big-bang "~a; the dimension demanded by ~a are ~a by ~a" basics name width height)))
+      
 (define (image-pins i)
   (format "image with pinhole at (~s,~s)" (1:pinhole-x i) (1:pinhole-y i)))

collects/2htdp/private/world.rkt

@@ -137,12 +137,17 @@
         (send visible set-cursor (make-object cursor% 'arrow))
         (let ([fst-scene (ppdraw)])
           (if (2:image? fst-scene)
-              (begin
-                (set! width  (if width width (+ (image-width fst-scene) 1)))
-                (set! height (if height height (+ (image-height fst-scene) 1))))
-              (begin
-                (set! width  (if width width (image-width fst-scene)))
-                (set! height (if height height (image-height fst-scene)))))              
+              (let ([first-width  (+ (image-width fst-scene) 1)]
+                    [first-height (+ (image-height fst-scene) 1)])
+                (unless (and width height)
+                  (check-scene-dimensions (name-of draw 'your-draw) first-width first-height)
+                  (set! width first-width)
+                  (set! height first-height)))
+              (let ([first-width  (image-width fst-scene)]
+                    [first-height (image-height fst-scene)])
+                (unless (and width height)
+                  (set! width first-width)
+                  (set! height first-height))))
           (create-frame)
           (show fst-scene)))
       
@@ -352,7 +357,9 @@
       
       (define/public (start!)
         (with-handlers ([exn? (handler #t)])
-          (when draw (show-canvas))
+          (when width ;; and height
+            (check-scene-dimensions "your to-draw clause" width height))
+          (if draw (show-canvas) (error 'big-bang "internal error: draw can never be false"))
           (when register (register-with-host))
           (define w (send world get))
           (cond

collects/2htdp/tests/image-too-large.rkt

@@ -0,0 +1,40 @@
+#lang racket
+
+(require 2htdp/universe 2htdp/image rackunit)
+
+(define width 100000)
+(define height 10)
+(define image (rectangle width height 'solid 'red))
+(define small (rectangle 100 100 'solid 'black))
+
+(define (draw-large i)
+  image)
+
+(check-true
+ (with-handlers ([exn:fail? (lambda (x)
+                              (define msg (exn-message x))
+                              (define reg (regexp-match "draw-large" msg))
+                              (pair? reg))])
+   (big-bang 0 (to-draw draw-large) (on-tick add1) (stop-when zero?))
+   #false))
+
+
+(check-true
+ (with-handlers ([exn:fail? (lambda (x)
+                              (define msg (exn-message x))
+                              (define reg (regexp-match "to-draw" msg))
+                              (pair? reg))])
+   (big-bang 0
+             (to-draw draw-large width height)
+             (on-tick add1)
+             (stop-when zero?))
+   #false))
+
+(check-true
+ (local ((define first-time #true))
+   (big-bang 0
+             (to-draw (lambda (_) (begin0 (if first-time small image) (set! first-time #false))))
+             (on-tick add1)
+             (stop-when zero?))
+   #true))
+

collects/2htdp/tests/xtest

@@ -8,6 +8,8 @@ gracket clause-once.rkt
 echo "done:--- clause-once.rkt ---" echo ""
 gracket full-scene-visible.rkt 
 echo "done:--- full-scene-visible.rkt  ---" echo ""
+gracket image-too-large.rkt
+echo "done:--- image-too-large.rkt  ---" echo ""
 gracket image-equality-performance-htdp.rkt 
 echo "done:--- image-equality-performance-htdp.rkt  ---" echo ""
 gracket image-equality-performance.rkt