From d17f93db3085925a0c6c47a3cc52be14e082849a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 31 May 2012 23:26:17 -0500 Subject: [PATCH] add PLTJUSTSAVEFAILURES support; makes it easier to build a good set of bitmaps on others' machines (no clicking required) --- collects/redex/tests/bitmap-test-util.rkt | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/collects/redex/tests/bitmap-test-util.rkt b/collects/redex/tests/bitmap-test-util.rkt index c8ca85e64e..4b6a9d7db5 100644 --- a/collects/redex/tests/bitmap-test-util.rkt +++ b/collects/redex/tests/bitmap-test-util.rkt @@ -13,6 +13,8 @@ (define show-bitmap-test-gui? (make-parameter #t)) +(define just-save-failures? (getenv "PLTJUSTSAVEFAILURES")) + (define tests 0) (define failed-tests 0) (define failed-panels '()) @@ -56,9 +58,14 @@ (send bdc set-bitmap #f) (unless (bitmaps-same? old-bitmap new-bitmap) (set! failed-tests (+ failed-tests 1)) - (when (show-bitmap-test-gui?) - (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap)]) - (set! failed-panels (append failed-panels (list failed-panel)))))))) + (cond + [just-save-failures? + (eprintf "saving ~a\n" bitmap-filename) + (void (send new-bitmap save-file bitmap-filename 'png))] + [else + (when (show-bitmap-test-gui?) + (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap)]) + (set! failed-panels (append failed-panels (list failed-panel)))))])))) (define (set-fonts/call thunk) (case (system-type)