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

adjusted test-engine to use the framework preferences library so that drracket still starts up when there is a locked preference file under windows

Browse Source
This commit is contained in:
Robby Findler 2011-01-20 14:04:01 -06:00
parent 2ddf90f3fc
commit 1b29fd590b
2 changed files with 19 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/test-engine/test-display.scm
View File

@ -31,8 +31,7 @@
(define (docked?) (define (docked?)
(and drscheme-frame (and drscheme-frame
(get-preference 'test:test-window:docked? (preferences:get 'test-engine:test-window:docked?)))
(lambda () (put-preferences '(test:test-window:docked?) '(#f)) #f))))
(define/public (report-success) (define/public (report-success)
(when current-rep (when current-rep
@ -489,8 +488,7 @@
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(send this show #f) (send this show #f)
(put-preferences '(test:test-window:docked?) (preferences:set 'test-engine:test-window:docked? #t)
'(#t))
(switch-func)))) (switch-func))))
(make-object grow-box-spacer-pane% button-panel))) (make-object grow-box-spacer-pane% button-panel)))
@ -543,7 +541,7 @@
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(put-preferences '(test:test-window:docked?) '(#f)) (preferences:set 'test-engine:test-window:docked? #f)
(send frame undock-tests)))) (send frame undock-tests))))
(define/public (update-editor e) (define/public (update-editor e)
@ -555,8 +553,7 @@
(define/public (remove) (define/public (remove)
(let ([parent (get-parent)]) (let ([parent (get-parent)])
(put-preferences '(test:test-dock-size) (preferences:set 'test-engine:test-dock-size (send parent get-percentages))
(list (send parent get-percentages)))
(send parent delete-child this))))) (send parent delete-child this)))))
(provide test-panel% test-window% test-display%) (provide test-panel% test-window% test-display%)

25
collects/test-engine/test-tool.scm
View File

@ -5,6 +5,12 @@
(require "test-display.scm") (require "test-display.scm")
(provide tool@) (provide tool@)
(preferences:set-default 'test-engine:test-dock-size
'(2/3 1/3)
(λ (x) (and (list? x) (= (length x) 2) (andmap number? x) (= 1 (apply + x)))))
(preferences:set-default 'test-engine:test-window:docked? #f boolean?)
(preferences:set-default 'test-engine:enable? #t boolean?)
(define tool@ (define tool@
(unit (import drscheme:tool^) (export drscheme:tool-exports^) (unit (import drscheme:tool^) (export drscheme:tool-exports^)
@ -71,9 +77,8 @@
(send test-panel update-editor editor) (send test-panel update-editor editor)
(unless (send test-panel is-shown?) (unless (send test-panel is-shown?)
(send test-frame add-child test-panel) (send test-frame add-child test-panel)
(let ([test-box-size (send test-frame set-percentages
(get-preference 'test:test-dock-size (lambda () '(2/3 1/3)))]) (get-preference 'test-engine:test-dock-size))))
(send test-frame set-percentages test-box-size))))
(define test-panel null) (define test-panel null)
(define test-frame null) (define test-frame null)
@ -107,7 +112,7 @@
(define/augment (on-tab-change from-tab to-tab) (define/augment (on-tab-change from-tab to-tab)
(let ([test-editor (send to-tab get-test-editor)] (let ([test-editor (send to-tab get-test-editor)]
[panel-shown? (send test-panel is-shown?)] [panel-shown? (send test-panel is-shown?)]
[dock? (get-preference 'test:test-window:docked? (lambda () #f))]) [dock? (preferences:get 'test-engine:test-window:docked?)])
(cond [(and test-editor panel-shown? dock?) (cond [(and test-editor panel-shown? dock?)
(send test-panel update-editor test-editor)] (send test-panel update-editor test-editor)]
[(and test-editor dock?) [(and test-editor dock?)
@ -135,14 +140,14 @@
(send this set-label undock-label)) (send this set-label undock-label))
(set! docked? (not docked?))) (set! docked? (not docked?)))
(define/public (dock-report) (define/public (dock-report)
(unless docked? (dock-tests) (put-preferences '(test:test-window:docked?) '(#t)))) (unless docked? (dock-tests) (preferences:set 'test-engine:test-window:docked? #t)))
(define/public (undock-report) (define/public (undock-report)
(when docked? (undock-tests) (put-preferences '(test:test-window:docked?) '(#f)))) (when docked? (undock-tests) (preferences:set 'test-engine:test-window:docked? #f)))
(super-instantiate ()))) (super-instantiate ())))
(define/override (add-show-menu-items show-menu) (define/override (add-show-menu-items show-menu)
(super add-show-menu-items show-menu) (super add-show-menu-items show-menu)
(let ([dock? (get-preference 'test:test-window:docked? (lambda () #t))]) (let ([dock? (preferences:get 'test-engine:test-window:docked?)])
(when (eq? dock-menu-item 'not-init) (when (eq? dock-menu-item 'not-init)
(set! dock-menu-item (set! dock-menu-item
(make-object dock-menu-item% (make-object dock-menu-item%
@ -171,14 +176,14 @@
(unless enabled? (unless enabled?
(set! enabled? #t) (set! enabled? #t)
(send this set-label disable-label) (send this set-label disable-label)
(put-preferences '(tests:enable?) '(#t)))) (preferences:set 'test-engine:enable? #t)))
(define/public (disable-tests) (define/public (disable-tests)
(when enabled? (when enabled?
(set! enabled? #f) (set! enabled? #f)
(send this set-label enable-label) (send this set-label enable-label)
(put-preferences '(tests:enable?) '(#f)))) (preferences:set 'test-engine:enable? #t)))
(super-instantiate ()))] (super-instantiate ()))]
[enable? (get-preference 'tests:enable? (lambda () #t))] [enable? (preferences:get 'test-engine:enable?)]
[enable-menu-item (make-object enable-menu-item% [enable-menu-item (make-object enable-menu-item%
(if enable? disable-label enable-label) (if enable? disable-label enable-label)
language-menu language-menu