adjust DrRacket to still start up if all of the splash-related images

are broken

I don't know if this really closes PR 13794 but DrRacket does now
pass the error given in that PR.

collects/drracket/private/drracket-normal.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require mred
+(require racket/gui/base
          racket/class
          racket/cmdline
          racket/list
@@ -8,6 +8,7 @@
          framework/splash
          racket/runtime-path
          racket/file
+	 (for-syntax racket/base)
          "frame-icon.rkt"
          "eb.rkt")
 
@@ -22,6 +23,24 @@
          (string->number ssec)
          (current-seconds)))))
 
+(define-syntax (def-imgs stx)
+  (syntax-case stx ()
+    [(_ img ...)
+     (with-syntax ([(str ...) (map (compose symbol->string syntax-e)
+                                   (syntax->list #'(img ...)))])
+       #'(begin (define img str) ...
+                (when (getenv "PLTDRBREAKIMAGES")
+                  (set! img (string-append "PLTDRBREAKIMAGES-dne-" img)) ...)))]))
+
+(def-imgs 
+  plt-logo-red-shiny.png
+  plt-logo-red-diffuse.png
+  heart.png
+  texas-plt-bw.gif
+  PLT-pumpkin.png
+  PLT-206-larval.png
+  PLT-206-mars.jpg)
+
 ;; updates the command-line-arguments with only the files
 ;; to open. See also main.rkt.
 (current-command-line-arguments (apply vector files-to-open))
@@ -62,8 +81,8 @@
 ;; magic strings and their associated images.  There should not be a string
 ;; in this list that is a prefix of another.
 (define magic-images
-  (list #;(magic-img "larval" "PLT-206-larval.png")
-        (magic-img "mars"   "PLT-206-mars.jpg")))
+  (list #;(magic-img "larval" PLT-206-larval.png)
+        (magic-img "mars"   PLT-206-mars.jpg)))
 
 (define (load-magic-images)
   (set! load-magic-images void) ; run only once
@@ -114,9 +133,9 @@
 
 (when (eb-bday?) (install-eb))
 
-(define weekend-bitmap-spec (collection-file-path "plt-logo-red-shiny.png" "icons"))
-(define normal-bitmap-spec (collection-file-path "plt-logo-red-diffuse.png" "icons"))
-(define valentines-days-spec (collection-file-path "heart.png" "icons"))
+(define weekend-bitmap-spec (collection-file-path plt-logo-red-shiny.png "icons" #:fail (λ (x) plt-logo-red-shiny.png)))
+(define normal-bitmap-spec (collection-file-path plt-logo-red-diffuse.png "icons" #:fail (λ (x) plt-logo-red-diffuse.png)))
+(define valentines-days-spec (collection-file-path heart.png "icons" #:fail (λ (x) heart.png)))
 
 (define the-bitmap-spec
   (cond
@@ -129,14 +148,19 @@
                size 
                size))]
     [texas-independence-day?
-     (collection-file-path "texas-plt-bw.gif" "icons")]
+     (collection-file-path texas-plt-bw.gif "icons")]
     [halloween?
-     (collection-file-path "PLT-pumpkin.png" "icons")]
+     (collection-file-path PLT-pumpkin.png "icons")]
     [(weekend-date? startup-date)
      weekend-bitmap-spec]
     [else normal-bitmap-spec]))
 
-(define the-splash-bitmap (and (path? the-bitmap-spec) (read-bitmap the-bitmap-spec)))
+(define (read-bitmap/no-crash fn)
+  (with-handlers ((exn:fail? (λ (x) (make-object bitmap% "dne.png"))))
+    (read-bitmap fn)))
+
+(define the-splash-bitmap (and (path? the-bitmap-spec)
+                               (read-bitmap/no-crash the-bitmap-spec)))
 (set-splash-char-observer drracket-splash-char-observer)
 
 (when (eq? (system-type) 'macosx)
@@ -154,13 +178,13 @@
   (define (set-icon state)
     (case state
       [(valentines) 
-       (unless valentines-bitmap (set! valentines-bitmap (read-bitmap valentines-days-spec)))
+       (unless valentines-bitmap (set! valentines-bitmap (read-bitmap/no-crash valentines-days-spec)))
        (set-doc-tile-bitmap valentines-bitmap)]
       [(weekend)
-       (unless weekend-bitmap (set! weekend-bitmap (read-bitmap weekend-bitmap-spec)))
+       (unless weekend-bitmap (set! weekend-bitmap (read-bitmap/no-crash weekend-bitmap-spec)))
        (set-doc-tile-bitmap weekend-bitmap)]
       [(normal) 
-       (unless weekday-bitmap (set! weekday-bitmap (read-bitmap normal-bitmap-spec)))
+       (unless weekday-bitmap (set! weekday-bitmap (read-bitmap/no-crash normal-bitmap-spec)))
        (set-doc-tile-bitmap weekday-bitmap)]))
   (set-icon initial-state)
   (void

collects/framework/splash.rkt

@@ -157,8 +157,6 @@
    (let/ec k
      (define (no-splash)
        (set! splash-bitmap #f)
-       (set! splash-canvas #f)
-       (set! splash-eventspace #f)
        (k (void)))
      (send (get-gauge) set-range splash-max-width)
      (send splash-tlw set-label splash-title)
@@ -187,7 +185,6 @@
            (set! splash-bitmap splash-draw-spec)])
         
         (unless (send splash-bitmap ok?)
-          (eprintf "WARNING: bad bitmap ~s\n" splash-draw-spec)
           (no-splash))
         
         (send splash-canvas min-width (send splash-bitmap get-width))

collects/tests/drracket/private/easter-egg-lib.rkt

@@ -23,7 +23,16 @@
   (printf "trying ~a, ~a/~a PLTDREASTERSECONDS=~a\n" what month day the-seconds)
   (unless (putenv "PLTDREASTERSECONDS" (number->string the-seconds))
     (error 'easter-egg-lib.rkt "putenv failed"))
-  (start-up-and-check-car))
+  (start-up-and-check-car)
+  
+  ;; start up with (an approximation to) broken image files
+  (unless (putenv "PLTDRBREAKIMAGES" "yes")
+    (error 'easter-egg-lib.rkt "putenv.2 failed"))
+  (printf "trying ~a, ~a/~a PLTDREASTERSECONDS=~a PLTDRBREAKIMAGES=yes\n" what month day the-seconds)
+  (start-up-and-check-car)
+  (environment-variables-set! (current-environment-variables)
+                              #"PLTDRBREAKIMAGES"	 
+                              #f))
 
 (define (start-up-and-check-car)
   (fire-up-separate-drracket-and-run-tests