suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add PLTJUSTSAVEFAILURES support; makes it easier to build a good

Browse Source 
set of bitmaps on others' machines (no clicking required)
This commit is contained in:
Robby Findler 2012-05-31 23:26:17 -05:00
parent c2d9f7ed9a
commit d17f93db30
1 changed files with 10 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/redex/tests/bitmap-test-util.rkt
View File

@ -13,6 +13,8 @@
(define show-bitmap-test-gui? (make-parameter #t)) (define show-bitmap-test-gui? (make-parameter #t))
(define just-save-failures? (getenv "PLTJUSTSAVEFAILURES"))
(define tests 0) (define tests 0)
(define failed-tests 0) (define failed-tests 0)
(define failed-panels '()) (define failed-panels '())
@ -56,9 +58,14 @@
(send bdc set-bitmap #f) (send bdc set-bitmap #f)
(unless (bitmaps-same? old-bitmap new-bitmap) (unless (bitmaps-same? old-bitmap new-bitmap)
(set! failed-tests (+ failed-tests 1)) (set! failed-tests (+ failed-tests 1))
(when (show-bitmap-test-gui?) (cond
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap)]) [just-save-failures?
(set! failed-panels (append failed-panels (list failed-panel)))))))) (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) (define (set-fonts/call thunk)
(case (system-type) (case (system-type)