140 lines
5.7 KiB
Racket
140 lines
5.7 KiB
Racket
#lang racket/base
|
|
(require "test-suite-utils.rkt")
|
|
|
|
(define ((check-equal? x) y) (equal? x y))
|
|
(define pref-sym 'plt:not-a-real-preference)
|
|
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
|
|
(define default-test-sym 'plt:not-a-real-preference-default-test)
|
|
|
|
(shutdown-mred)
|
|
|
|
(test
|
|
'preference-unbound
|
|
(check-equal? 'passed)
|
|
`(with-handlers ([exn:unknown-preference?
|
|
(lambda (x)
|
|
'passed)])
|
|
(preferences:get ',pref-sym)))
|
|
(test 'preference-set-default/get
|
|
(check-equal? 'passed)
|
|
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
|
|
(preferences:get ',pref-sym)))
|
|
(test 'preference-set/get
|
|
(check-equal? 'new-pref)
|
|
`(begin (preferences:set ',pref-sym 'new-pref)
|
|
(preferences:get ',pref-sym)))
|
|
|
|
(test 'preference-marshalling
|
|
(check-equal? 'the-answer)
|
|
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
|
|
(preferences:set-un/marshall ',marshalling-pref-sym
|
|
(lambda (f) (f))
|
|
(lambda (v) (lambda () v)))
|
|
(begin0 ((preferences:get ',marshalling-pref-sym))
|
|
(preferences:set ',marshalling-pref-sym (lambda () 2)))))
|
|
(shutdown-mred)
|
|
(test 'preference-marshalling
|
|
(check-equal? 2)
|
|
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
|
|
(preferences:set-un/marshall ',marshalling-pref-sym
|
|
(lambda (f) (f))
|
|
(lambda (v) (lambda () v)))
|
|
((preferences:get ',marshalling-pref-sym))))
|
|
|
|
(with-handlers ([eof-result? (lambda (x) (void))])
|
|
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f)
|
|
(exit:exit)
|
|
|
|
;; do this yield here so that exit:exit
|
|
;; actually exits on this interaction.
|
|
;; right now, exit:exit queue's a new event to exit
|
|
;; instead of just exiting immediately.
|
|
(yield (make-semaphore 0)))))
|
|
|
|
(test 'preference-get-after-restart
|
|
(check-equal? 'new-pref)
|
|
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
|
|
(preferences:get ',pref-sym)))
|
|
|
|
(test 'preference-no-set-default-stage1
|
|
(check-equal? 'stage1)
|
|
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
|
|
(preferences:set ',default-test-sym 'new-value)
|
|
'stage1))
|
|
(shutdown-mred)
|
|
(test 'preference-no-set-default-stage2
|
|
(check-equal? 'stage2)
|
|
`(begin 'stage2))
|
|
(shutdown-mred)
|
|
(test 'preference-no-set-default-stage3
|
|
(check-equal? 'new-value)
|
|
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
|
|
(preferences:get ',default-test-sym)))
|
|
|
|
(test 'preference-add-callback
|
|
(check-equal? 2)
|
|
`(begin
|
|
(let ([x 1])
|
|
(define remove-it (preferences:add-callback ',default-test-sym (λ (a b) (set! x (+ x 1)))))
|
|
(preferences:set ',default-test-sym 'xyz)
|
|
(remove-it)
|
|
(preferences:set ',default-test-sym 'pdq)
|
|
x)))
|
|
|
|
(test 'preference-add-weak-callback
|
|
(check-equal? 2)
|
|
`(begin
|
|
(let ([x 1])
|
|
(define f (λ (a b) (set! x (+ x 1))))
|
|
(define remove-it (preferences:add-callback ',default-test-sym f #t))
|
|
(preferences:set ',default-test-sym 'xyz)
|
|
(remove-it)
|
|
(preferences:set ',default-test-sym 'pdq)
|
|
x)))
|
|
|
|
(test 'preference-add-weak-callback2
|
|
(check-equal? 3)
|
|
`(begin
|
|
(let ([x 1])
|
|
(define f (λ (a b) (set! x (+ x 1))))
|
|
(unless (zero? (random 1)) (set! f 'not-a-proc)) ;; try to stop inlining
|
|
(define remove-it (preferences:add-callback ',default-test-sym f #t))
|
|
(collect-garbage) (collect-garbage) (collect-garbage)
|
|
(preferences:set ',default-test-sym 'xyz)
|
|
(remove-it)
|
|
(preferences:set ',default-test-sym 'pdq)
|
|
(f 'a 'b) ;; make sure safe-for-space doesn't free 'f' earlier
|
|
x)))
|
|
|
|
(test 'preference-weak-callback-is-weak
|
|
(check-equal? #t)
|
|
`(begin
|
|
(let ([x 1])
|
|
(define f (λ (a b) (set! x (+ x 1))))
|
|
(define wb (make-weak-box f))
|
|
(define remove-it (preferences:add-callback ',default-test-sym f #t))
|
|
(set! f #f)
|
|
(begin0
|
|
(let loop ([n 10])
|
|
(cond
|
|
[(not (weak-box-value wb)) #t]
|
|
[(zero? n) 'f-still-alive]
|
|
[else
|
|
(collect-garbage)
|
|
(loop (- n 1))]))
|
|
(remove-it)))))
|
|
|
|
(test 'dialog-appears
|
|
(check-equal? 'passed)
|
|
(lambda ()
|
|
(queue-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
|
|
(preferences:show-dialog)))
|
|
(wait-for-frame "Preferences")
|
|
(queue-sexp-to-mred '(begin (preferences:hide-dialog)
|
|
(let ([f (get-top-level-focus-window)])
|
|
(if f
|
|
(if (string=? "Preferences" (send f get-label))
|
|
'failed
|
|
'passed)
|
|
'passed))))))
|